Hallo,
der folgende Code gehört in ein Standardmodul deiner Arbeitsmappe. Der Artikelname wird im Code aus der Zelle A2 eingelesen. Das musst du noch auf deine Verhältnisse anpassen, ebenso wie den Pfad. Das Makro ist aus deiner Protokollseite auszuführen. Sämtliche in der aktiven Tabellen vorhandenen Bilder werden gelöscht, bevor die neuen Bilder eingefügt werden. Es werden die ersten zwei Bilder eingefügt, die in dem gesuchten Unterordner gefunden werden. Falls du mehr als 100 Bilder hast, musst die Dimensionierung bei arrVerzeichnis entsprechend anpassen.
Hier der Code:
Dim arrVerzeichnis(100) As Variant
Dim lngZaehler As Long
Sub Bilder_einfuegen()
Dim strPfad As String
Dim strSuche As String
Dim shpBild As Shape
Dim i As Long
Dim b As Long
'Pfad in dem die Unterordner mit den Bildern liegen - ggf. anpassen
strPfad = "C:\Test\"
'Suchbegriff (= Artikelname) einlesen - Zelle anpassen
strSuche = Range("A2").Value
'Routine zum Einlesen der Unterverzeichnisse und Dateien aufrufen
Call MWReadSubFolder(strPfad)
'vorhandene Bilder im aktiven Blatt löschen
For Each shpBild In ActiveSheet.Shapes
shpBild.Delete
Next
'Unterverzeichnis suchen
For i = 0 To lngZaehler - 1
If InStr(1, arrVerzeichnis(i), strSuche) Then
If b = 0 Then
'1. Bild in F 66 skaliert 8 x 10 cm einfügen
'1 cm = 28,35 pt; 1. Wert Breite, 2. Wert Höhe
ActiveSheet.Shapes.AddPicture arrVerzeichnis(i), msoFalse, msoTrue, Range("F66").Left, Range("F66").Top, 283.5, 226.8
b = b + 1
End If
If b = 1 Then
'2. Bild in F 94 einfügen, ebenfalls skaliert
ActiveSheet.Shapes.AddPicture arrVerzeichnis(i + 1), msoFalse, msoTrue, Range("F94").Left, Range("F94").Top, 283.5, 226.8
Exit For 'Schleife verlassen
End If
End If
Next i
End Sub
Private Sub MWReadSubFolder(ByVal sPath As String)
'Autor/en des ursprünglichen Codes: http://www.online-vba.de - Marc Wershoven
'modifiziert
Dim oFSO As Object
Dim oFolder As Object
Dim oSubFolder As Object
Dim oFile As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.getfolder(sPath)
For Each oSubFolder In oFolder.subfolders
'Alle Dateien auflisten
For Each oFile In oSubFolder.Files
arrVerzeichnis(lngZaehler) = oSubFolder.Path & "\" & oFile.Name
lngZaehler = lngZaehler + 1
Next oFile
'Alle Unterverzeichnisse verarbeiten (rekursiv)
Call MWReadSubFolder(oSubFolder.Path)
Next oSubFolder
Set oFSO = Nothing
Set oFile = Nothing
Set oFolder = Nothing
Set oSubFolder = Nothing
End Sub
Beachte bitte, dass der Code genau so in das Modul kopiert werden muss.
Gruß
M.O.
