Mit folgendem Makro füge ich Bilder in eine Exceldatei ein. Allerdings werden die Bilder nicht so ganz eingefügt, wie ich es mir vorgestellt habe. Das Bild soll sich beim Einfügen über das Makro so verhalten, als ob ich es nach dem Einfügen an einem Eckpunkt anfasse und in der Größe verändere. Dabei bleibt ja die Proportion des Bildes erhalten. Leider macht das das Makro nicht.
Sub Bilder_einfuegen()
Dim strPictureName As String
Dim strPfad As String
Dim varPicture As Variant
Dim varTop As Variant
Dim varLeft As Variant
Dim varHeight As Variant
Dim varWidth As Variant
Dim objBild As Object
Dim lngRow As Long
Application.ScreenUpdating = False
strPfad = "C:\Bilder\"
For lngRow = 2 To Range("B65536").End(xlUp).Row
varPicture = strPfad & Cells(lngRow, 2) & ".jpg"
'Bild falls vorhanden löschen
On Error Resume Next
ActiveSheet.Shapes(CStr(lngRow)).Delete
On Error GoTo 0
varTop = Cells(lngRow, 1).Top
varLeft = Cells(lngRow, 1).Left
'varHeight = Cells(lngRow, 1).Height
'varWidth = Cells(lngRow, 1).Width
'Bild in Zelle einfügen
Set objBild = ActiveSheet.Shapes.AddPicture(varPicture, _
False, True, varLeft, varTop, varWidth, varHeight)
'Name des Bildes ermitteln
strPictureName = objBild.Name
'Bei dem eingefügten Bild...
With ActiveSheet.Shapes(strPictureName)
'...Name des Bildes ändern
.Name = lngRow
'...Bildproportionen beibehalten
.LockAspectRatio = True
'...die Bildbreite an die Breite der Zelle anpassen
.Width = Cells(lngRow, 1).Width - 4
'...Bildhöhe an die Höhe der Zelle anpassen
.Height = Cells(lngRow, 1).Height * 3 / 4 '- 4
'Breite des Bildes erneut ändern wenn nach Größenänderung noch zu breit
If .Width > Cells(lngRow, 1).Width Then .Width = Cells(lngRow, 1).Width - 4
'Höhe des Bildes erneut ändern wenn nach Größenänderung noch zu hoch
If .Height > Cells(lngRow, 1).Height Then .Height = Cells(lngRow, 1).Height - 4
'...die Position Links an der linken Seite der Zelle ausrichten
.Left = Cells(lngRow, 1).Left + ((Cells(lngRow, 1).Width - .Width) / 2)
'...die Position Oben an der oberen Seite der Zelle ausrichten
.Top = Cells(lngRow, 1).Top + ((Cells(lngRow, 1).Height - .Height) / 2)
End With
Next
End Sub
hat eventuell jemand eine Idee, was ich ändern muss, damit das Bild zwar an die Zelle angepasst wird, aber die Proportion dabei behält?
Danke Euch schon mal,
Kasimir