Bilder in Zellen importieren

Per VBA lassen sich Bilder aus einem angegebenen Verzeichnis auslesen und importieren. Die vorgestellte Prozedur liest die Bilder aus dem eingestellten Verzeichnis "F:\Pic" aus. Die im Verzeichnis vorhandenen Bilder werden entsprechend der Spaltenbreite der Spalte A skaliert. Die Bilder werden vergrößert oder verkleinert, wobei die Seitenverhältnise unverändert bleiben. Damit befindet sich das Bild genau innerhalb einer Zelle.

Im vorstellten Beispiel beginnt der Import in Zeile 5 der Spalte A.

Erfassen Sie den VBA-Code in einem Code-Modulblatt.

Sub BilderImport()
 '*********************************************************************************
 '** Bilder werden in die Spalte A eingefügt. Die Bilder werden auf die  
 '** eingestellte Spaltebreite skaliert. Die Zeilenhöhe wird an die         
 '** skalierte Bildhöhe angepasst                                                     
 '*********************************************************************************
 
 '* * Dimensionierung der Variablen
 Dim strVerzeichnis$, strDatei$
 Dim pct As Picture
 Dim lngZeile As Long'Zeile zum Eintragen der Bilder
 Dim lngSpalte As Long'Spalte zum Eintragen der Bilder
 Dim varBreite As Variant'Spaltenbreite
 Dim varHoehe As Variant
 
 
 '** Verzeichnis und Dateinamen definieren und auslesen
 strVerzeichnis = "F:\Pic"
 strDatei = Dir(strVerzeichnis & "\*.jpg")
 
 '** Startzeile + Spalte festelegen
 lngZeile = 5
 lngSpalte = 1
 
 '** Ermittlung der Spaltenbreite
 varBreite = Columns("A:A").Width
 
 Cells(lngZeile, lngSpalte).Select
 Cells(lngZeile, lngSpalte + 1) = strDatei  ' schreiben Dateinamen
 Set pct = ActiveSheet.Pictures.Insert(strVerzeichnis & "\" & strDatei)
 
 With ActiveSheet.Shapes("Picture 1")
   '** Auslesen der Breite
   ActiveSheet.Shapes("Picture 1").Select
   Selection.ShapeRange.LockAspectRatio = msoTrue
   
   '** Bild auf aktuelle Spaltenbreite skalieren
   Selection.ShapeRange.Width = varBreite
   
   '** Zeilenhöhe festlegen
   varHoehe = ActiveSheet.Shapes("Picture 1").Height
   Rows(lngZeile).RowHeight = varHoehe
 End With
 
 '** Zähler für Shape definieren
 shp = 2
 
 '** Zeilenzähler erhöhen
 lngZeile = lngZeile + 1
 
 
 '** Bild 2 bis n durchlaufen
 Do While strDatei <> ""
   strDatei = Dir()
   If strDatei = "" Then Exit  Do
   Cells(lngZeile, lngSpalte).Select
   Set pct = ActiveSheet.Pictures.Insert(strVerzeichnis & "\" & strDatei)
   ActiveSheet.Shapes("Picture " & shp).Select
   Cells(lngZeile, lngSpalte + 1) = strDatei  ' schreiben Dateinamen
   Selection.ShapeRange.LockAspectRatio = msoTrue
   
   Selection.ShapeRange.Width = varBreite '* 5.355 'Bild auf Spaltenbreite skallieren
   
   '** Zeilenhöhe festlegen
   varHoehe = ActiveSheet.Shapes("Picture " & shp).Height
   Rows(lngZeile).RowHeight = varHoehe
   
   '** Zeilenzähler erhöhen
   lngZeile = lngZeile + 1
   
   '** Shape-Zahler erhöhen
   shp = shp + 1
   
 Loop
 End Sub