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 an die Spaltenbreite der Spalte A skaliert. Abhängig von der Spaltenbreite werden die vorhandenen Bilder vergrößert oder verkleinert, wobei die Seitenverhältnise unverändert bleiben.

Nach dem Import wird die Zeilenhöhe an das skalierte Bild angepasst. 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 

________________________________________________________________________________