Suchen von Dateien mit Pfad
27.11.2006 21:20:22
Dateien
diesen Code habe ich aus der Recherche gefunden und etwas modifiziert. Die Dateien werden durch Hyperlinks verknüpft. Die Hyperlinks enthalten nur den Dateinamen, dass ist auch richtig so. Nun möchte ich zusätzlich in Spalte B (ab Zeile 2) auch den Pfad, der jeweiligen Datei ausgeben.
Bitte helft mir - vielen Danke!!!
Gruß
Uni
Code:
Sub Dateiname_Hyperlink()
Dim StDateiname As String
Dim Dateiname As String
Dim InI As Long, TotFiles As Long
Dim Suchpfad As String
Dim OldStatus As Variant
Application.ScreenUpdating = False
Range("A2:D65536").Delete
Application.ScreenUpdating = True
Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll.", "Pfad definieren", "F:\")
If Suchpfad = "" Then Exit
Sub
Dateiname = InputBox("Geben Sie den Dateityp an der gesucht werden soll", "Dateierweiterung", "*.xls")
If Dateiname = "" Then Exit
Sub
OldStatus = Application.StatusBar
' neue Tabelle anlegen
' Sheets.Add After:=Worksheets(Worksheets.Count)
Range("A1").Value = "Dateiname"
Range("B1").Value = "Pfad"
Range("C1").Value = "Dateigröße"
Range("D1").Value = "geändert am"
Range("A1:D1").Font.Bold = True
With Application.FileSearch
.NewSearch
.LookIn = Suchpfad
.SearchSubFolders = True
.Filename = Dateiname
.FileType = msoFileTypeAllFiles
.Execute SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending
If .Execute() > 0 Then
TotFiles = .FoundFiles.Count
Application.StatusBar = "Total " & TotFiles & " gefunden"
For InI = 1 To .FoundFiles.Count
Application.StatusBar = "Datei: " & InI & " von " & TotFiles
' Dateiname abtrennen ab OfficeXP
StDateiname = Mid(.FoundFiles(InI), InStrRev(.FoundFiles(InI), "\") + 1)
ActiveSheet.Hyperlinks.Add Anchor:=Cells(InI + 1, 1), _
Address:=.FoundFiles(InI), TextToDisplay:=StDateiname ' Hyperlink
Cells(InI + 1, 2) = FileLen(.FoundFiles(InI)) ' Pfad
Cells(InI + 1, 3) = FileLen(.FoundFiles(InI)) ' Dateigröße
Cells(InI + 1, 4) = FileDateTime(.FoundFiles(InI)) ' Dateidatum
Next InI
End If
End With
Range("C2:C65536").NumberFormat = "###,###,###,### ""Bytes"""
Columns("A:A").AutoFit
Columns("B:B").AutoFit
Columns("C:C").ColumnWidth = 18
Columns("D:D").ColumnWidth = 18
Application.StatusBar = OldStatus
Application.ScreenUpdating = True
End
Sub