Probleme mit Verzeichnisauswahl
12.01.2004 10:15:28
Ben
folgendes Makro liest alle Dateinamen mit der Endung .jpg aus der Spalte einer Excel-Datei aus und sucht dann in einem vorher angegebenen Verzeichnis danach. Die gefundenen Bilder werden anschließend automatisch in ein ebenfalls vorher angegebenes Zielverzeichnis kopiert. Die Verzeichniswahl erfolgt über eine InputBox.
Sub Suche()
Dim PfadQuelle As String, PfadZiel As String
Dim fs As Object
Dim iZeile As Long
Set fs = Application.FileSearch
PfadQuelle = InputBox("In welchem Pfad soll gesucht werden?", "Suchpfad", "C:/")
If PfadQuelle = "" Then Exit Sub
PfadZiel = InputBox("In welches Verzeichnis sollen die gefundenen Dateien kopiert werden?", "Zielpfad", "C:/")
If PfadZiel = "" Then Exit Sub
For iZeile = 1 To Range("A65536").End(xlUp).Row
If Cells(iZeile, 1) <> "" Then
If UCase(Right(Cells(iZeile, 1), 4)) <> ".JPG" Then
MsgBox "Die in Zeile " & iZeile & " aufgeführte Datei " & Cells(iZeile, 1) & " kann aufgrund der fehlenden Dateibezeichnung nicht gefunden werden."
Else
With fs
.LookIn = PfadQuelle
.Filename = Cells(iZeile, 1)
.SearchSubFolders = True
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
FileCopy .FoundFiles(1), PfadZiel & Cells(iZeile, 1)
Else
MsgBox "Die in Zeile " & iZeile & " aufgeführte Datei " & Cells(iZeile, 1) & " kann nicht gefunden werden."
End If
End With
End If
End If
Next iZeile
End Sub
Komfortabler als die Auswahl des Suchpfades und des Zielverzeichnisses per InputBox wäre natürlich, wenn man wie im Explorer die Möglichkeit zum Suchen und Auswählen hätte. Dazu habe ich hier unter den VBA-Beispielen auch einen passenden Code gefunden (siehe unten). Das Problem ist nur, dass ich aufgrund mangelnder Kenntnisse leider nicht weiss, wie ich den Code korrekt in mein Makro einbinden muss, damit auch alles funktioniert. Wenn Ihr mir da behilflich sein könntet, wäre ich Euch wirklich dankbar. Hier der besagte Code:
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare
Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare
Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Sub DirAuswahl()
Dim sMsg As String, sPath As String
sMsg = "Wählen Sie bitte einen Ordner aus:"
sPath = getdirectory(sMsg)
If sPath <> "" Then MsgBox sPath
End Sub
Function getdirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(msg) Then
bInfo.lpszTitle = "In welchem Pfad soll gesucht werden?"
Else
bInfo.lpszTitle = msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
getdirectory = Left(Path, pos - 1)
Else
getdirectory = ""
End If
End Function
Schöne Grüsse,
Ben