Jak vložit obrázek do oblasti buněk

Vložit obrázek do listu není nijak složité. Lze využít schránku nebo kartu Vložení / Obrázek. Zarovnání do buňky či oblasti buněk (lépe řečeno přichycení k mřížce) zajistí držení klávesy ALT během přesunu či změně velikosti obrázku. V praxi narážím na dva požadavky – měnit obrázek na základě výběru buňky (obsah udává zdroj obrázku) a přizpůsobovat obrázky buňkám bez zásahu uživatele (nejednotné velikosti obrázků pro produkty, logotypy, …).

Obrázky pro vložení

Obrázky pro vložení

Provázanost obrázku na obsah buňky je velmi často řešena komentářem buňky. My tuto možnost ponecháme stranou ze dvou důvodů. Zobrazení komentáře nelze nikdy spolehlivě uřídit (jsou schopny se vykreslit mimo obrazovku), navíc se běžně netisknou. Jednoduše vyhradíme místo na listu pro obrázky, jeho viditelnost zajistíme příčkami a obsah budeme měnit na základě události Worksheet_Change.

Vybraná položka definuje vložený obrázek

Vybraná položka definuje vložený obrázek

Nejprve startovací procedura pro případ, že načtení obrázku budete chtít realizovat s pomocí tlačítka a ne události.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub TestVlozitObrazek()

    Dim rngOblastObrazek As Range
    Dim strCestaSouborObrazek As String
   
    'definice oblasti pro vložení obrázku
    Set rngOblastObrazek = Worksheets("List1").Range("B2:F10")
   
    'zdroj obrázku
    strCestaSouborObrazek = ThisWorkbook.Path & "\obrazek1.jpg"
    'strCestaSouborObrazek = ThisWorkbook.Path & "\obrazek2.jpg"
    'strCestaSouborObrazek = ThisWorkbook.Path & "\obrazek3.jpg"
   
    'vymazání případných původních obrázků v oblasti
    Call OblastSmazatObjekty(rngOblastObrazek)
   
    'vložení obrázku do oblasti
    'vycentrování v obou směrech a nevynucené přizpůsobení
    'tj. větší obrázky se zmenší, menší obrázky se nezvětší
    Call VlozitObrazek(strCestaSouborObrazek, rngOblastObrazek, True, _
        True, False)

End Sub

Následuje výpis nejdůležitější obslužné procedury. Parametry pro vycentrování jsou volitelné a stejně tak zvládá přizpůsobení menších obrázků oblasti buněk.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
Sub VlozitObrazek(ByVal strSouborObrazek As String, ByVal rngOblastVlozeni As _
    Range, Optional ByVal bNaStredVodorovne As Boolean = False, Optional ByVal _
    bNaStredSvisle As Boolean = False, Optional ByVal bZvetsitMensi As Boolean = _
    False)

    Dim objObrazek As Object
    Dim dOblastShora As Double
    Dim dOblastZleva As Double
    Dim dOblastSirka As Double
    Dim dOblastVyska As Double
    Dim dObrazekSirka As Double
    Dim dObrazekVyska As Double
    Dim dPomerSirky As Double
    Dim dPomerVysky As Double
    Dim dPomerMax As Double

    'zamezení překreslování obrazovky
    Application.ScreenUpdating = False

    'vložení obrázku
    Set objObrazek = ActiveSheet.Pictures.Insert(strSouborObrazek)

    'rozměry oblasti pro vložení
    With rngOblastVlozeni
        dOblastShora = .Top
        dOblastZleva = .Left
        dOblastSirka = .Width
        dOblastVyska = .Height
    End With

    'původní rozměry obrázku
    With objObrazek
        dObrazekSirka = .Width
        dObrazekVyska = .Height
    End With

    'maximální poměr (převrácená hodnota měřítka)
    dPomerSirky = dObrazekSirka / dOblastSirka
    dPomerVysky = dObrazekVyska / dOblastVyska
    dPomerMax = WorksheetFunction.Max(dPomerSirky, dPomerVysky)

    'je potřeba obrázek zmenšit nebo je požadováno
    'zvětšení malých obrázků do velikosti oblasti?
    'poměr stran zachován vždy
    If (dPomerMax > 1) Or (bZvetsitMensi = True) Then
        'zmenšení (zvětšení)
        dSirka = dObrazekSirka / dPomerMax
        dVyska = dObrazekVyska / dPomerMax
    Else
        'ponechání rozměrů
        dSirka = dObrazekSirka
        dVyska = dObrazekVyska
    End If

    dShora = dOblastShora
    dZleva = dOblastZleva

    'vodorovné vycentrování?
    If bNaStredVodorovne Then
        dZleva = dZleva + dOblastSirka / 2 - dSirka / 2
    End If

    'svislé vycentrování?
    If bNaStredSvisle Then
        dShora = dShora + dOblastVyska / 2 - dVyska / 2
    End If

    'nastavení obrázku
    With objObrazek
        .Top = dShora
        .Left = dZleva
        .Width = dSirka
        .Height = dVyska
    End With

    'odstranění proměnné z paměti
    Set objObrazek = Nothing

    'překreslení obrazovky
    Application.ScreenUpdating = True

End Sub

Další řádky kódu VBA řeší odstranění obrázku z oblasti buněk (před načtením nového).

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub OblastSmazatObjekty(ByVal rngOblast As Range)

    Dim shpObjekt As Shape

    With rngOblast.Parent

        'pro každý objekt kolekce Shapes na listu
        For Each shpObjekt In .Shapes

            'jestliže horní levý roh objektu leží v oblasti
            If Not Application.Intersect(shpObjekt.TopLeftCell, rngOblast) Is _
                Nothing Then
                'a je-li objekt typu obrázek
                If (shpObjekt.Type = msoPicture) Or (shpObjekt.Type = _
                    msoLinkedPicture) Then
                    'odstranění obrázku
                    shpObjekt.Delete
                End If
            End If

        Next shpObjekt

    End With

End Sub

Jestliže chcete aplikovat změnu na základě události Worksheet_Change, pak stačí drobná obměna startovací procedury. Kód je umístěn v modulu listu.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim rngOblastObrazek As Range
    Dim rngOblastTest As Range

    Dim strCestaSouborObrazek As String

    'oblast s názvy souborů
    Set rngOblastTest = Range("B13:F15")

    If Union(rngOblastTest, Target).Address = rngOblastTest.Address Then

        'definice oblasti pro vložení obrázku
        Set rngOblastObrazek = Range("B2:F10")

        'zdroj obrázku
        strCestaSouborObrazek = ThisWorkbook.Path & "" & Target.Cells(1).Text

        'vymazání případných původních obrázků v oblasti
        Call OblastSmazatObjekty(rngOblastObrazek)

        'vložení obrázku do oblasti
        'vycentrování v obou směrech a nevynucené přizpůsobení
        'tj. větší obrázky se zmenší, menší obrázky se nezvětší
        Call VlozitObrazek(strCestaSouborObrazek, rngOblastObrazek, True, True, _
            False)

    End If

End Sub

Na tomto místě předkládám ještě jednu možnost k zamyšlení. Tou je využití ovládacího prvku Image a jeho vlastností Picture a PictureSizeMode. Načítání obrázku do vlastnosti Picture zprostředkuje metoda LoadPicture. Pro PictureSizeMode doporučuji nastavení na 3 – fmPictureSizeModeZoom (malé obrázky se bohužel budou přizpůsobovat, i když v měřítku). Užití prvku vás zbavuje závislosti na mřížce listu.

Ovládací prvek Image

Ovládací prvek Image

Událostní procedura pak může vypadat takto:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim rngOblastTest As Range

    'oblast s názvy souborů
    Set rngOblastTest = Range("B13:F15")

    If Union(rngOblastTest, Target).Address = rngOblastTest.Address Then

        'načtení obrázku do prvku Image1
        Me.Image1.Picture = LoadPicture(ThisWorkbook.Path & "" & Target.Cells(1).Text)

    End If

End Sub

Příloha:
[download id=”1496″]

Klikni a stahuj!