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í 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.
Excelplus.NET | 1
Jak vložit obrázek do oblasti buněk
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. 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ší
Excelplus.NET | 2
Jak vložit obrázek do oblasti buněk 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. 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
Excelplus.NET | 3
Jak vložit obrázek do oblasti buněk 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
Excelplus.NET | 4
Jak vložit obrázek do oblasti buněk .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). 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
Excelplus.NET | 5
Jak vložit obrázek do oblasti buněk 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. 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.
Excelplus.NET | 6
Jak vložit obrázek do oblasti buněk
Ovládací prvek Image Událostní procedura pak může vypadat takto: Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rngOblastTest As Range 'oblast s názvy souborů
Excelplus.NET | 7
Jak vložit obrázek do oblasti buněk 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
Excelplus.NET | 8
