Option Explicit
'Variablen
'=========
Private varFSArr As Variant
'Funktionen
'==========
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
ByVal DirPath As String) As Long
Sub A_Start()
'Konstanten
'==========
Const strSuchVerzC As String = "U:\GROSSER\BILDER\" '<<<<<<<BilderVerzeichnis anpassen
Const strNoImage As String = "_NoImage.jpg" '<<<<<<<Name für NoImage anpassen
Const strTabelle As String = "Tabelle1" '<<<<<<<TabellenName anpassen
Const strSpalte As String = "D" '<<<<<<<Spalte anpassen
Const lngStartZeile As Long = 2 '<<<<<<<Erste Zeile anpassen
Const strErgSpalte As String = "F" '<<<<<<<ErgebnisSpalte anpassen
'Variablen
'=========
Dim varArrD() As Variant
Dim varFSArr2() As Variant
Dim lngLRow As Long
Dim lngCount As Long, lngCount2 As Long
Dim strPathToNoImage As String
Dim strSuchVerz As String
'PublicVar=> varFSArr As Variant
'Spalte in DateiArray
'====================
With ThisWorkbook.Worksheets(strTabelle)
lngLRow = IIf(IsEmpty(.Range(strSpalte & .Rows.Count)), _
.Range(strSpalte & .Rows.Count).End(xlUp).Row, .Rows.Count) 'letzte Zeile ermitteln
varArrD = .Range(strSpalte & lngStartZeile & ":" & strSpalte & lngLRow).Value 'Spalte in Array
ReDim Preserve varArrD(1 To UBound(varArrD, 1), 1 To 4) '2.Dimension vergrössern
'(für Dat.Name, gefunden in...)
End With
'Dateinamen im DateiArray extrahieren
'====================================
For lngCount = 1 To UBound(varArrD, 1) 'Für Elemente der 1.Dimension
'wenn "\" in ,1 vorhanden, finde "\" von rechts,
'schreibe Dateiname in ,3 und reinen Pfad in ,2
If Not VarType(varArrD(lngCount, 1)) = vbEmpty Then _
If InStrRev(varArrD(lngCount, 1), "\", Len(varArrD(lngCount, 1))) Then _
varArrD(lngCount, 3) = Right(varArrD(lngCount, 1), _
Len(varArrD(lngCount, 1)) - InStrRev(varArrD(lngCount, 1), "\")): _
varArrD(lngCount, 2) = Left(varArrD(lngCount, 1), _
InStrRev(varArrD(lngCount, 1), "\"))
Next lngCount
'SuchVerz in FSArray abbilden
'============================
ReDim varFSArr(0) 'FSArray leeren
strSuchVerz = strSuchVerzC 'Suchverz. holen
If Right(strSuchVerz, 1) <> "\" Then strSuchVerz = strSuchVerz & "\" '"\" am Ende sichern
SuchRoot (strSuchVerz)
'Dateinamen ins FSArray2 extrahieren
'====================================
ReDim varFSArr2(UBound(varFSArr)) 'Grössen angleichen
For lngCount = 1 To UBound(varFSArr) 'Für jedes Element
'wenn "\" vorhanden, finde "\" von rechts, schreibe Dateiname in FSArray2
If InStrRev(varFSArr(lngCount), "\", Len(varFSArr(lngCount))) Then _
varFSArr2(lngCount) = Right(varFSArr(lngCount), _
Len(varFSArr(lngCount)) - InStrRev(varFSArr(lngCount), "\"))
'Pfad zu strNoImage herauspicken
If LCase(varFSArr2(lngCount)) = LCase(strNoImage) Then strPathToNoImage = varFSArr(lngCount)
Next lngCount
'kein strNoImage=> Meldung und raus
If strPathToNoImage = "" Then MsgBox "Datei " & strNoImage & _
" nicht vorhanden!!!", vbCritical + vbOKOnly, "Fehler" _
: End
'DateiArray durchlaufen und mit
'FSArray2 abgleichen und Quelle
'in DateiArray notieren
'==============================
For lngCount = 1 To UBound(varArrD, 1)
For lngCount2 = 1 To UBound(varFSArr2)
If LCase(varArrD(lngCount, 3)) = LCase(varFSArr2(lngCount2)) Then
varArrD(lngCount, 4) = varFSArr(lngCount2)
Exit For
Else 'Wenn kein Bild->
varArrD(lngCount, 4) = strPathToNoImage ' _noimage.jpg als Quelle
End If
Next lngCount2
Next lngCount
'DateiArray durchlaufen und Dateien kopieren
'existiert ein Bild nicht im Suchverzeichnis
'wird das _noimage.jpg mit dem gesuchtenNamen
'im Ziel eingefügt
'===========================================
For lngCount = 1 To UBound(varArrD, 1)
If VarType(varArrD(lngCount, 1)) = vbString And varArrD(lngCount, 1) Like "?:\*" _
And Not (Mid(varArrD(lngCount, 1), 4) Like "*[/:*?<>|]*") Then
'Sicherstellen, dass der Zielpfad existiert
If MakeSureDirectoryPathExists(varArrD(lngCount, 1)) Then
'Kopieren
FileCopy varArrD(lngCount, 4), varArrD(lngCount, 1)
End If
Else
varArrD(lngCount, 4) = ">>>!!!Fehler im Zielpfad!!!<<<"
End If
Next lngCount
'Quellen aus DateiArray in nun
'nutzloses FSArray2 um es am
'Stück in die Ergebnisspalte
'schieben zu können
'=============================
ReDim varFSArr2(1 To UBound(varArrD, 1), 1)
For lngCount = 1 To UBound(varArrD, 1)
varFSArr2(lngCount, 0) = varArrD(lngCount, 4)
Next lngCount
With ThisWorkbook.Worksheets(strTabelle)
.Range(strErgSpalte & lngStartZeile).Resize(UBound(varFSArr2), 1) = varFSArr2
End With
End Sub
Sub SuchRoot(strQuelle As String)
'Variablen
'=========
Dim objFS As Object
Dim fldQuelle As Object
Set objFS = CreateObject("Scripting.FileSystemObject")
Set fldQuelle = objFS.GetFolder(strQuelle)
Verzeichnisse fldQuelle
Set fldQuelle = Nothing
Set objFS = Nothing
End Sub
Sub Verzeichnisse(objFld As Object)
'!!!Rekursiver Aufruf!!!
'aus "Sub SuchRoot" heraus angestossen
'Variablen
'=========
Dim objSubFld As Object
Dim objFile As Object
Dim objFS As Object
Set objFS = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFld.Files
ReDim Preserve varFSArr(UBound(v
