ich habe im Internet ein Makro gefunden der die Dateien auflistet.
Ich brauche aus dem Makro nur Pfad und Dateiname.
Wenn ich das Makro ausführe, sollte die Abfrage kommen sollen die alte Werte gelöscht werden, wenn JA, dann die Werte in Spalte B und Spalte F immer ab Zeile 2 (weil in Zeile 1 mein Überschrift ist) nach unten löschen. Wenn NEIN dann sollen die neue Werte in nächste leere Zeile hinzufügt werden.
Pfad soll in Spalte F und die Dateiname in Splate B eingefügt werden.
'############################################################################################'
' Die folgenden Makros durchsuchen einen Ordner und seine Unterordner '
' nach Dateien. Ordner und Dateityp können ausgewählt werden. '
' '
' Teile der Makros stammen aus dem Internet - Herkunft unbekannt. '
'############################################################################################'
'############################################################################################'
'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
Sub Suchen()
Dim Laufwerk$, Dateien$
'Erste Zeile, in der eine Eintragung erfolgt
z = 2
'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
Was muss ich ändert damit es so aussieht wie ich mir es vorgestellt habe???
Ich bedanke mich im voraus....
Viele Grüße
Dzana