hallo ich wollte wissen wie ich auch die unterordner durchsuchen kann nach bilder, weil aktuell mit dem code unten durchsucht er mir nur den angegebenen ordner ? Vielen Dank im Voraus !
Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Sub copyPicture()
Dim objFSO As Object
Dim strPath As String, strNewPath As String
Dim rng As Range
strPath = "C:\Users\info\Desktop\ideal" 'Verzeichnis mit den Bildern - Anpassen!
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strNewPath = "C:\Users\info\Desktop\bilderfürwilly" 'Verzeichnis in welches die Bilder kopiert werden sollen - Anpassen!
If Right(strNewPath, 1) <> "\" Then strNewPath = strNewPath & "\"
If MakeSureDirectoryPathExists(strNewPath) <> 0 Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each rng In Sheets("Tabelle1").Range("A1:A500") 'Tabellenname und Bereich anpassen
If rng <> "" Then
If Dir(strPath & rng.Text) <> "" Then
objFSO.CopyFile strPath & rng.Text, strNewPath & rng.Text
End If
End If
Next
Else
MsgBox strNewPath & " konnte nicht erstellt werden!"
End If
End Sub
|