Dateieigenschaften ausgeben
21.03.2006 14:07:45
Walter
habe ein Laufwerk mit einer Vielzahl von Unterordnern, die wieder aus vielen Unterordnern usw. bestehen.
Folgendes Makro habe ich zur Ausgabe der Dateieigenschaften.
Es funktioniert auch ganz gut bis auf den Pfad, der bei mehreren Unterordnern nicht das richtige ausgibt.
Vielleicht hat jemand eine Lösung für mein Problem.
Gruß
Walter Beyersdorf
Option Explicit
Dim varName As Object
Dim x As Byte
Dim spalte As Integer
Dim zeile As Long
Dim objShell As Object
Dim objFolder As Object
Dim arrHeaders(34)
Dim sPath As String
' Benötigte API-Deklarationen
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Const MAX_PATH = 260
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = 1
Private Declare Sub CoTaskMemFree Lib "ole32.dll" ( _
ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" _
Alias "lstrcatA" ( _
ByVal lpString1 As String, _
ByVal lpString2 As String) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" ( _
ByVal pidList As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" ( _
lpbi As BrowseInfo) As Long
Private Declare Function SendMessage Lib "user32.dll" _
Alias "SendMessageA" ( _
ByVal hWnd As Long, _
ByVal Msg As Long, _
wParam As Any, _
lParam As Any) As Long
Private m_BrowseInitDir As String
Sub Dateieigenschaften_ausgeben_alt()
' Alte Daten löschen
Sheets("Tabelle1").Select
Columns("A:AZ").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
Dim STRFOLDER
STRFOLDER = OrdnerAuswählen("Bitte Ordner auswählen")
If Right$(STRFOLDER, 1) "\" Then STRFOLDER = STRFOLDER & "\"
If Dir(STRFOLDER, 16) = "" Then
MsgBox "Der Ordner " & STRFOLDER & " wurde nicht gefunden!" & Space(10), 64, "weise hin..."
Exit Sub
End If
Application.ScreenUpdating = False
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(STRFOLDER)
spalte = 1
' Schreibt die Überschriften
For x = 0 To 10 '33
Select Case x
Case 1, 3, 6, 7, 10
arrHeaders(x) = objFolder.GetDetailsOf(varName, x)
Cells(1, spalte + 0) = "Pfad"
Cells(1, spalte + 1) = "Dateiname"
Cells(1, spalte + x + 2) = arrHeaders(x)
End Select
Next
Rows(1).Font.Bold = True
zeile = 2
getDetails objFolder
Application.ScreenUpdating = True
Columns.AutoFit
Range("C:C,E:E,G:H,K:L").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
Set objShell = Nothing
Set objFolder = Nothing
End Sub
' Ordnerauswahl-Dialog mit optionaler Angabe eines Startverzeichnisses
Public Function OrdnerAuswählen(ByVal sPrompt As String, _
Optional ByVal sInitDir As String) As String
Dim nPos As Long
Dim nIDList As Long
Dim oInfo As BrowseInfo
m_BrowseInitDir = sInitDir
' Datenstruktur füllen
With oInfo
.hWndOwner = GetActiveWindow()
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
If sInitDir "" Then
' Callback-Funktionsadresse
.lpfnCallback = FuncCallback(AddressOf BrowseCallback)
End If
End With
' Dialog anzeigen und auswerten
nIDList = SHBrowseForFolder(oInfo)
If nIDList Then
sPath = String$(MAX_PATH, 0)
Call SHGetPathFromIDList(nIDList, sPath)
Call CoTaskMemFree(nIDList)
nPos = InStr(sPath, vbNullChar)
If nPos Then sPath = Left$(sPath, nPos - 1)
End If
OrdnerAuswählen = sPath
End Function
Private Function getDetails(objF)
Dim objSF As Object
Dim Length As Integer
For Each varName In objF.Items
If varName.IsFolder Then
Set objSF = objShell.Namespace(varName)
getDetails objSF
Else
If varName Like "*.*" Then
For x = 0 To 10 '33
Select Case x
Case 1, 3, 6, 7, 10
Length = Len(objF)
If Right$(sPath, Length) = objF Then
Cells(zeile, 1) = sPath & "\" 'Pfad
Cells(zeile, 2) = varName 'Dateiname
Cells(zeile, spalte + x + 2) = objF.GetDetailsOf(varName, x) 'Eigenschaften
Else
Cells(zeile, 1) = sPath & "\" & objF & "\" 'Pfad
Cells(zeile, 2) = varName 'Dateiname
Cells(zeile, spalte + x + 2) = objF.GetDetailsOf(varName, x) 'Eigenschaften
End If
End Select
Next
zeile = zeile + 1
End If
End If
Next
Set objSF = Nothing
End Function
Private Function BrowseCallback(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Select Case uMsg
Case BFFM_INITIALIZED
' Start-Ordner
Call SendMessage(hWnd, BFFM_SETSELECTION, ByVal 1&, _
ByVal m_BrowseInitDir)
End Select
BrowseCallback = 0
End Function
' Hilfsfunktion für AddressOf
Private Function FuncCallback(ByVal nParam As Long) As Long
FuncCallback = nParam
End Function