AW: Verzeichnispfad entfernen - Dateinamen beibehalten
23.08.2003 09:01:09
micha
Hi Sacha-Michael,
ich habe in diesem Forum mal was ähnliches gefunden - evtl. hilft es Dir (ist 'ne VBA-Lösung)
Bau Dir einfach 'ne neue Exceldatei, wechsle mit ALT+F11 in den VBA-Editor, füge ein Modul ein, und kopiere dort den Code hinein.
Gruss Micha
'Dieser Bereich kann entfallen, wenn der Variable 'Laufwerk' ein fester Wert zugewiesen wird.'
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
Private z!
Sub Dateisuche(Laufwerk, Dateien)
Dim tmp, Wdhlg, Dateiname As String
On Error Resume Next
If Right(Laufwerk, 1) <> "\" Then Laufwerk = Laufwerk + "\"
tmp = Dir(Laufwerk & Dateien)
Do While Len(tmp)
Dateiname = Laufwerk & tmp
Application.StatusBar = Dateiname
'Die folgenden Angaben können auch in eine Feldvariable
'oder in eine Listbox eingelesen werden:
Cells(z, 1).Select
Cells(z, 1) = Laufwerk & tmp 'Pfad
Cells(z, 2) = FileLen(Laufwerk & tmp) 'Größe
Cells(z, 3) = FileDateTime(Laufwerk & tmp) 'Datum/Zeit
Cells(z, 4) = tmp 'nur Dateiname
z = z + 1
tmp = Dir()
Loop
tmp = Dir(Laufwerk, vbDirectory)
Do While Len(tmp)
If (tmp <> ".") And (tmp <> "..") Then
If (GetAttr(Laufwerk & tmp) And vbDirectory) = vbDirectory Then
Dateisuche Laufwerk & tmp, Dateien
z = z - 1
Wdhlg = Dir(Laufwerk, vbDirectory)
z = z + 1
Do While Wdhlg <> tmp
Wdhlg = Dir()
Loop
End If
End If
tmp = Dir()
Loop
On Error GoTo 0
Application.StatusBar = False
End Sub
'Aufruf mit dem folgenden Makro - Einer Schaltfläche zuweisen
Sub Suchen()
Dim Laufwerk$, Dateien$
'Erste Zeile, in der eine Eintragung erfolgt (z)
'z = 2 'Originalzeile (hier wird immer in A2 geschrieben
z = Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
'Alte Eintragungen löschen
'[a2:e50000] = ""
'Den Variablen Laufwerk und Dateien kann auch ein Wert direkt zugewiesen werden.
Laufwerk = GetDirectory("Bitte einen Ordner wählen") 'Ersatz: ... = C:\Eigene Dateien"
If Laufwerk = "" Then Exit Sub
'Ersatz: Dateien = "*.*"
Dateien = InputBox("Nach welchen Dateien soll in" & Chr(10) & " " & Laufwerk & Chr(10) & "gesucht werden (z. B. *.xls)?", "Dateityp", "*.*")
If Dateien = "" Then Exit Sub
Dateisuche Laufwerk, Dateien
End Sub
'Ruft das Dialogfeld zur Ordnerauswahl auf
Function GetDirectory(Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
With bInfo
.pidlRoot = 0&
.lpszTitle = Msg
.ulFlags = &H1
End With
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