Nimm besser die Shapes.Add Methode, ist flexibler
Option Explicit
Sub BesserBilder_Einfuegen()
'
'
Dim Path As String
Dim Func As String
Dim Form As String
Dim i As Integer
Dim j As Integer
Dim oShp As Shape
'wegen Test auskommentiert / geändert **********
Rem Path = "XXX\"
Rem Func = ActiveSheet.Name
Rem Form = ".png"
Form = ".jpg"
'***********************************************
'
i = 2
j = 3
While (i < 180) '18 Zeilen
While (j < 6) ' 3 Spalten
'Cells(i, j).Select wozu??
On Error Resume Next
'einfach mit den Parametern(Pflicht) herumspielen
Set oShp = ActiveSheet.Shapes.AddPicture( _
Filename:=Path & Cells(i, j).Value & Func & Form, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=Cells(i, j + 3).Left, _
Top:=Cells(i, j).Top, _
Width:=Cells(i + 10, j).Top - Cells(i, j).Top, _
Height:=Cells(i + 10, j).Top - Cells(i, j).Top)
If Err.Number = 0 Then
'jetzt alle weiteren möglichen Eigenschaften
With oShp
'Test (kann natürlich auch der Zellinhalt sein)
.Name = "Pict " & Cells(i, j).Address(0, 0)
End With
'Test++++++++++++++++++++++++++++++++++++++++++++++
Call MsgBox("Bild " & oShp.Name & vbNewLine & _
"an Position " & oShp.TopLeftCell.Address, _
vbInformation, _
"Gewonnen!")
End If
On Error GoTo 0
j = j + 1
Wend
i = i + 10 'Zeilen immer zu 10. zusammengefasst "Easy Scroling"
j = 3 'Erste Spalte ist C
Wend
End Sub
Sub Bonus()
'lösche alle Bilder wo der Zelleintrag fehlt
Dim oShp As Shape
Dim arrN() As String
For Each oShp In ActiveSheet.Shapes
arrN = Split(oShp.Name, " ")
If Range(arrN(1)).Value = "" Then
If MsgBox("Bild " & oShp.Name & vbNewLine & _
"an Position " & oShp.TopLeftCell.Address, _
vbQuestion + vbYesNo, _
"Sicherheitsabfrage!") = vbYes Then oShp.Delete
End If
Next oShp
End Sub
|