Folder-Dialog

07/03/2009 - 15:55 von Christian Hahn | Report spam
Hallo,
ich möchte in einem Makro die Namen aller Dateien in einem bestimmten Ordner
auslesen.
Dazu brauchte ich einen Dialog, in dem der betreffende Ordner ausgewàhlt
werden kann und den Pfad nur des Ordners zurückliefert.
Wo kann ich soetwas finden?

besten Gruß und Dank, Christian Hahn.
 

Lesen sie die antworten

#1 Andreas Killer
07/03/2009 - 16:11 | Warnen spam
Christian Hahn schrieb:

ich möchte in einem Makro die Namen aller Dateien in einem bestimmten
Ordner auslesen.
Dazu brauchte ich einen Dialog, in dem der betreffende Ordner ausgewàhlt
werden kann und den Pfad nur des Ordners zurückliefert.
Wo kann ich soetwas finden?


Ist nicht grad toll der Dialog, aber immerhin. Code hàngt unten dran,
zum Test starte die Sub Main().

Andreas.

Option Explicit
Private fs As Object

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
pszPath As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Private 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

Sub Main()
Dim Pfad As String, Verzeichnisse() As String, Anzahl As Long, _
I As Long
Pfad = GetOpenFolderName("Bitte Ordner zum löschen wàhlen:")
If Pfad <> "" Then
Anzahl = GetSubFoldersA(Pfad, Verzeichnisse, True)
For I = 0 To Anzahl - 1
Debug.Print Verzeichnisse(I)
Next
End If
End Sub

Function GetOpenFolderName(Optional Msg As String = "") As String
'Zeigt das Dialogfeld "Ordner suchen", liefert den Ordnernamen _
oder "" für Abbruch
Dim bInfo As BROWSEINFO
Dim Path As String
Dim R As Long, X As Long, Pos As Integer
bInfo.pidlRoot = 0&
If Msg = "" Then
bInfo.lpszTitle = "Wàhlen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
X = SHBrowseForFolder(bInfo)
Path = Space$(512)
R = SHGetPathFromIDList(ByVal X, ByVal Path)
If R Then
Pos = InStr(Path, Chr$(0))
GetOpenFolderName = Left(Path, Pos - 1)
Else
GetOpenFolderName = ""
End If
End Function

Function GetSubFolders(ByVal Pfad As String) As Variant
'Gibt eine Folders-Auflistung zurück, die aus allen in einem _
bestimmten Ordner enthaltenen Ordnern, einschließlich derer mit _
dem Attribut "Verborgen" und "Systemdatei", besteht.
Dim F As Object
If fs Is Nothing Then Set fs = CreateObject( _
"Scripting.FileSystemObject")
Set F = fs.GetFolder(Pfad)
Set GetSubFolders = F.SubFolders
Set F = Nothing
End Function

Function GetSubFoldersA(ByVal Pfad As String, ByRef PfadArray() _
As String, Optional SearchSubFolders As Boolean = True) As Long
'Liefert die Anzahl der Unterverzeichnisse in Pfad und deren _
Pfadnamen in PfadArray, 0 für keine.
Dim I As Long, J As Long, U As Long, Sf As Object, F As Object

'Verzeichnisse festellen
GetSubFoldersA = 0
On Error Resume Next
Set Sf = GetSubFolders(Pfad)
If Err.Number <> 0 Then GoTo ExitPoint
If Sf.Count = 0 Then GoTo ExitPoint

'Obere Grenze des Array feststellen
J = UBound(PfadArray)
If Err.Number <> 0 Then
'Es ist () => leer
I = -1
ReDim PfadArray(0 To Sf.Count - 1) As String
Else
I = J
'Letztes Element feststellen
Do While Len(PfadArray(I)) = 0
I = I - 1
If I < LBound(PfadArray) Then Exit Do
Loop
'Genug Platz um die Namen aufzunehmen?
If J - I < Sf.Count Then
ReDim Preserve PfadArray(LBound(PfadArray) To I + Sf.Count) _
As String
'Konnte das Datenfeld dimensioniert werden?
If Err.Number <> 0 Then GoTo ExitPoint
End If
End If
On Error GoTo 0

'Start im Array für Unterverzeichnissuche merken
J = I
'Alle Verzeichnisse ins Array eintragen
For Each F In Sf
I = I + 1
PfadArray(I) = F
Next
'Anzahl hinzugefügter Eintràge im Array berechnen
U = I - J

'Durchlaufe alle gefundenen Unterverzeichnisse
If SearchSubFolders Then
Do While J < I
J = J + 1
'Addiere Anzahl gefundener Unterverzeichnisse
U = U + GetSubFoldersA(PfadArray(J), PfadArray)
Select Case Err.Number
Case 0
Case 70
'Zugriff verweigert
Err.Clear
Case Else
Exit Do
End Select
Loop
End If
GetSubFoldersA = U

ExitPoint:
'Subfolder-Objekt freigeben
Set Sf = Nothing
End Function

Ähnliche fragen