AW: Dateisuche mit VBA unter Excel
17.09.2007 10:53:55
Ramses
Hallo
ich kann zwar nicht mit Nepumuk konkurrieren, aber vielleicht hilft das ja auch schon
Sub Read_File_Properties_with_Hyperlink()
'(C) Ramses
'Liest Daten aus einem bestimmten Verzeichnis ein
'mit spezifischen Dateieigenschaften
'und erstellt auf die jeweilige Datei einen Hyperlink
Dim checkFolder As String
Dim myShell As Object, myFolder As Object
Dim chkFileName ', arrHeaders(34)
Dim startRow As Long, tarCol As Integer
Dim SuchDialog As FileDialog, sInt As Integer
Set SuchDialog = Application.FileDialog(msoFileDialogFolderPicker)
'********************
'Startspalte
tarCol = 1
'Startzeile
startRow = 1
'********************
'Ab hier eigentlich keine Änderung mehr nötig
'Hier wird der FolderPickerDialog aufgerufen
'Erst ab EXCEL XP möglich ?
With SuchDialog
.Title = "Bitte wählen Sie ein Verzeichnis aus"
'Environ(25) ermittelt den Aktuellen Userpfad
.InitialFileName = Application.DefaultFilePath
.ButtonName = "Auswahl übernehmen"
.Show
If .SelectedItems.count = 0 Then
MsgBox "Sie haben keine Auswahl getroffen", vbInformation
Set SuchDialog = Nothing
Exit Sub
Else
For sInt = 1 To .SelectedItems.count
checkFolder = .SelectedItems(sInt)
Next sInt
End If
End With
'*******************
'Für Versionen kleiner EXCEL XP
'checkFolder = InputBox("Geben Sie den Ordner an der eingelesen werden soll:", "Datenimport", "C:\Data")
'If Dir(checkFolder, 16) = "" Then
'MsgBox "Der Ordner " & checkFolder & " existiert nicht!", vbOKOnly + vbCritical, "Fehler"
' Exit Sub
'End If
'*******************
Application.ScreenUpdating = False
Set myShell = CreateObject("Shell.Application")
Set myFolder = myShell.Namespace("" & checkFolder & "") 'checkFolder)
If Right(checkFolder, 1) <> "\" Then
checkFolder = checkFolder & "\"
End If
Cells.Clear
Cells(startRow, tarCol) = "Filename"
Cells(startRow, tarCol).Offset(0, 1) = "File Size"
Cells(startRow, tarCol).Offset(0, 2) = "Last Access"
Cells(startRow, tarCol).Offset(0, 3) = "Date Modified"
Cells(startRow, tarCol).Offset(0, 4) = "Date Created"
Rows(startRow).Font.Bold = True
startRow = startRow + 1
For Each chkFileName In myFolder.Items
'FileProperties
'1. Name
'2. Size
'3. Type
'4. Date Modified
'5. Date Created
'6. Date Accessed
'7. Attributes
'8. Status
'9. Owner
'10. Author
'11. Title
'12. Subject
'13. Category
'14. Pages
'15. Comments
With Cells(startRow, tarCol)
.Value = myFolder.GetDetailsOf(chkFileName, 0)
'Wenn keine Hyperlinks gebraucht werden, kann
'die nächste Zeile deaktiviert werden
.Hyperlinks.Add Anchor:=Cells(startRow, tarCol), Address:=checkFolder & .Value, TextToDisplay:=.Value
End With
Cells(startRow, tarCol).Offset(0, 1) = myFolder.GetDetailsOf(chkFileName, 1)
Cells(startRow, tarCol).Offset(0, 2) = myFolder.GetDetailsOf(chkFileName, 4)
Cells(startRow, tarCol).Offset(0, 3) = myFolder.GetDetailsOf(chkFileName, 3)
Cells(startRow, tarCol).Offset(0, 4) = myFolder.GetDetailsOf(chkFileName, 5)
startRow = startRow + 1
Next
Application.ScreenUpdating = True
End Sub
Gruss Rainer