habe ein Problem bei einem alten VBA, bei dem ich mehrere Bilder aus einem Ordner in vordefinierte Felder in einem Excel-Sheet speicher. Ich habe schon herausgefunden, dass unter Office 2010 "ActiveSheet.Picture.Insert" nicht funktioniert, aber noch keine passende Lösung gefunden. Vielleicht könnt ihr mir dabei helfen.
Hier mein Code
Sub BilderEinfuegen()
Dim i As Long
Dim PicBild As Picture
Dim PfadDatei$, PfadBilder$
Dim Objekt As Object
Dim arrBereiche As Variant
arrBereiche = Array("A6,L24", "N6,Y24", "A28,L46", "N28,Y46", "A51,L69", "N51,Y69", "A73,L91" _
_
, "N73,Y91", _
"A96,L114", "N96,Y114", "A118,L136", "N118,Y136", "A141,L159", "N141,Y159", "A163, _
_
L181", "N163,Y181", _
"A186,L204", "N186,Y204", "A208,L226", "N208,Y226")
PfadDatei = ThisWorkbook.Path
PfadBilder = PfadDatei & "\Bilder\"
Application.ScreenUpdating = False
'Löschen bereits eingefügter Bilder
For Each Objekt In ActiveSheet.Shapes
If Objekt.AlternativeText "Bilder einfügen" Then
Objekt.Delete
End If
Next
'In die Zellbereiche werden Bilder mit dem dort stehenden Namen eingefügt
For i = 0 To UBound(arrBereiche) Step 1
If Range(arrBereiche(i)).Value > "00" Then
Set PicBild = _
ActiveSheet.Pictures.Insert(PfadBilder & Range(arrBereiche(i)).Value & ".jpg")
With ActiveSheet.Pictures(ActiveSheet.Pictures.Select)
'Ausrichten der Bilder
PicBild.Top = Range(arrBereiche(i)).Top
PicBild.Left = Range(arrBereiche(i)).Left
'Bild quer
If ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Width > _
ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Height Then
PicBild.Width = Range(arrBereiche(i)).Width
PicBild.Top = Range(arrBereiche(i)).Top + _
(Range(arrBereiche(i)).Height - ActiveSheet.Pictures(ActiveSheet. _
Pictures.Count).Height) / 2
'Bild hochkant
Else
PicBild.Height = Range(arrBereiche(i)).Height
PicBild.Left = Range(arrBereiche(i)).Left + _
(Range(arrBereiche(i)).Width - ActiveSheet.Pictures(ActiveSheet. _
Pictures.Count).Width) / 2
End If
End With
Else
'In Zellbereichen mit dem Wert 00 werden keine Bilder eingefügt
End If
Next i
Application.ScreenUpdating = True
Set PicBild = Nothing
End Sub