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, …).

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

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.

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:
excel_vlozeni_obrazku.zip

Uložit článek jako PDF