Folder-Dialog

[Christian Hahn]

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.

[Andreas Killer]

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

[Christian Hahn]

Donnerwetter, lieber Andreas, das ist ja ein halbes Buch, alle Achtung.
Ich habe natürlich ein bisschen bebraucht, bis ich alle kapiert habe (hab'
wahrscheinlich noch nicht alles kapiert), und ich sitze nun daran, deine
Function GetSubFoldersA mit der FileSearch.LookIn-Funktion zu verbinden,
sodass ich am Ende ein Array habe, das etwa die gesamte Ordner- und auch die
Dateistruktur eines übergeordneten Ordners enthält.
besten Dank und beste Grüße, Christian Hahn.

"Andreas Killer" <andreas...@gmx.net> schrieb im Newsbeitrag
news:49b28ea0$0$32676$9b4e...@newsspool2.arcor-online.net...

[Andreas Killer]

Christian Hahn schrieb:

> Donnerwetter, lieber Andreas, das ist ja ein halbes Buch, alle Achtung.
> Ich habe natürlich ein bisschen bebraucht, bis ich alle kapiert habe
> (hab' wahrscheinlich noch nicht alles kapiert), und ich sitze nun daran,
> deine Function GetSubFoldersA mit der FileSearch.LookIn-Funktion zu
> verbinden, sodass ich am Ende ein Array habe, das etwa die gesamte
> Ordner- und auch die Dateistruktur eines übergeordneten Ordners enthält.
> besten Dank und beste Grüße, Christian Hahn.

Hmm? Du sagtest Du nicht ausdrücklich Verzeichnisse?

Egal, für Dateien hab ich das auch.

Andreas.

Option Explicit

Sub Test()
Dim I As Long, Dateien() As String, Anzahl As Long
Anzahl = GetFilesA("C:\Programme\Microsoft Office", "*.exe", _
Dateien)

For I = 0 To Anzahl - 1

Debug.Print Dateien(I)
Next
End Sub

Function GetFilesA(ByVal Pfad As String, ByVal Maske As String, _
ByRef FileArray() As String, Optional ByVal SearchSubFolders As _

Boolean = True) As Long

'Liefert die Anzahl Dateien in Pfad die Maske entsprechen und _
die Namen in FileArray()
Dim I As Long, U As Long
With Application.FileSearch
.NewSearch
.LookIn = Pfad
.SearchSubFolders = SearchSubFolders
.Filename = Maske
.FileType = msoFileTypeAllFiles

If .Execute() > 0 Then
On Error Resume Next
U = UBound(FileArray)

If Err.Number <> 0 Then
'Es ist () => leer
I = -1

ReDim FileArray(0 To .FoundFiles.Count - 1) As String
Else
I = U
'Letztes Element feststellen
Do While Len(FileArray(I)) = 0

I = I - 1

If I < LBound(FileArray) Then Exit Do

Loop
'Genug Platz um die Namen aufzunehmen?

If U - I < .FoundFiles.Count Then
ReDim Preserve FileArray(LBound(FileArray) To I + _
.FoundFiles.Count) As String

'Konnte das Datenfeld dimensioniert werden?
If Err.Number <> 0 Then

GetFilesA = I
Exit Function
End If

End If
End If
On Error GoTo 0

'Dateinamen ins array übertragen
For I = 1 To .FoundFiles.Count
FileArray(I - 1 + LBound(FileArray)) = .FoundFiles(I)
Next I
GetFilesA = .FoundFiles.Count
Else
GetFilesA = 0
End If
End With
End Function

[Michael Schwimmer]

Hallo Christian,

Am Sat, 7 Mar 2009 15:55:12 +0100 schrieb Christian Hahn:
> 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?

Option Explicit
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_STATUSTEXT As Long = &H4
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_EDITBOX As Long = &H10
Private Const BIF_VALIDATE As Long = &H20
Private Const BIF_NEWDIALOGSTYLE As Long = &H40
Private Const BIF_BROWSEINCLUDEURLS As Long = &H80
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const BIF_SHAREABLE As Long = &H8000
Private Const BIF_SHOWALLOBJECTS As Long = &H8
'Desktop
Private Const ssfDESKTOP As Long = &H0
'Programme Startmenü (alle Benutzer)
Private Const ssfPROGRAMS As Long = &H2
'Systemsteuerung
Private Const ssfCONTROLS As Long = &H3
'Drucker
Private Const ssfPRINTERS As Long = &H4
'Eigene Dateien (aktueller Benutzer)
Private Const ssfPERSONAL As Long = &H5
'Favoriten (aktueller Benutzer)
Private Const ssfFAVORITES As Long = &H6
'Autostart
Private Const ssfSTARTUP As Long = &H7
'Zuletzt verwendete Dokumente
Private Const ssfRECENT As Long = &H8
'Senden an - Ordner
Private Const ssfSENDTO As Long = &H9
'Recycled (Papierkorb)
Private Const ssfBITBUCKET As Long = &HA
'Startmenü (aktueller Benutzer)
Private Const ssfSTARTMENU As Long = &HB
'Desktop - Ordner (aktueller Benutzer)
Private Const ssfDESKTOPDIRECTORY As Long = &H10
'Arbeitsplatz
Private Const ssfDRIVES As Long = &H11
'Netzwerkumgebung
Private Const ssfNETWORK As Long = &H12
'Netzwerkumgebung - Ordner
Private Const ssfNETHOOD As Long = &H13
'Schriftarten - Ordner
Private Const ssfFONTS As Long = &H14
'Vorlagen - Ordner
Private Const ssfTEMPLATES As Long = &H15
'Startmenü (alle Benutzer)
Private Const ssfCOMMONSTARTMENU As Long = &H16
'Programme Startmenü (alle Benutzer)
Private Const ssfCOMMONPROGRAMS As Long = &H17
'Autostart (alle Benutzer)
Private Const ssfCOMMONSTARTUP As Long = &H18
'Desktop - Ordner (alle Benutzer)
Private Const ssfCOMMONDESKTOPDIR As Long = &H18
'Anwendungsdaten (aktueller Benutzer)
Private Const ssfAPPDATA As Long = &H1A
Private Const ssfLOCALAPPDATA As Long = &H1C
'Druckumgebung - Ordner
Private Const ssfPRINTHOOD As Long = &H1B
'Altern. Autostart - Ordner (aktueller Benutzer)
Private Const ssfALTSTARTUP As Long = &H1D
'Altern. Autostart - Ordner (alle Benutzer)
Private Const ssfCOMMONALTSTARTUP As Long = &H1E
'Favoriten (alle Benutzer)
Private Const ssfCOMMONFAVORITES As Long = &H1F
'Temporäre Internetdateien
Private Const ssfINTERNETCACHE As Long = &H20
'Internet Cookies - Ordner
Private Const ssfCOOKIES As Long = &H21
'Internet Verlauf - Ordner
Private Const ssfHISTORY As Long = &H22
'Anwendungsdaten <alle Benutzer>
Private Const ssfCOMMONAPPDATA As Long = &H23
'Windows-Ordner
Private Const ssfWINDOWS As Long = &H24
'System-Ordner
Private Const ssfSYSTEM As Long = &H25
'Programme
Private Const ssfPROGRAMFILES As Long = &H26
'Eigene Bilder
Private Const ssfMYPICTURES As Long = &H27
'Dokumente und Einstellungen
Private Const ssfPROFILE As Long = &H28
'Gemeinsame Dateien
Private Const ssfPROGRAMFILESCOMMON As Long = &H2B
'Vorlagen - Ordner (alle Benutzer)
Private Const ssfCOMMONTEMPLATES As Long = &H2D
'Dokumente (alle Benutzer)
Private Const ssfCOMMONDOCUMENTS As Long = &H2E
'Startmenü "Verwaltung" (alle Benutzer)
Private Const ssfCOMMONADMINTOOLS As Long = &H2F
'Startmenü "Verwaltung" (aktueller Benutzer)
Private Const ssfADMINTOOLS As Long = &H30
'Netzwerk- und DFÜ-Verbindungen
Private Const ssfCONNECTIONS As Long = &H31

Private Sub Testen()
Dim strFolder As String
Dim strResult As String
Dim varTemp As Variant

strFolder = ShellGetFolder("C:\Windows")

If strFolder = "" Then Exit Sub

For Each varTemp In SearchFiles(strFolder, "dll")
strResult = strResult & varTemp & vbCrLf
Next

If strResult = "" Then Exit Sub

MsgBox Left(strResult, Len(strResult) - 2)

End Sub

Public Function ShellGetFolder( _
Optional start As Variant = ssfDRIVES, _
Optional Caption As String = "Browse Folder" _
) As String
On Error Resume Next

Dim objShell As Object
Dim objBrowse As Object
Dim lngOptions As Long

' Eigenschaften des Dialoges setzen
lngOptions = BIF_RETURNONLYFSDIRS Or _
BIF_EDITBOX Or _
BIF_VALIDATE Or _
BIF_SHOWALLOBJECTS Or _
BIF_NEWDIALOGSTYLE Or _
BIF_STATUSTEXT Or _
BIF_SHOWALLOBJECTS

Set objShell = CreateObject("Shell.Application")

' Dialog starten und Pfad zurückgeben
If IsNumeric(start) Then
' Anfangspfad als Konstante
Set objBrowse = objShell.BrowseForFolder( _
&H0, Caption, lngOptions, CLng(start))
Else
' Anfangspfad als String
Set objBrowse = objShell.BrowseForFolder( _
&H0, Caption, lngOptions, start & Chr(0))
End If
objBrowse.ParentFolder.ParseName objBrowse.Title
ShellGetFolder = objBrowse.Self.Path
If ShellGetFolder = "" Then ShellGetFolder = "Nichts ausgewählt"

End Function

Public Function SearchFiles( _
ByVal strStart As String, _
Optional strFilter As String = "*", _
Optional avarResult As Variant, _
Optional lngCount As Long _
) As Variant

Dim astrFolder() As String
Dim strFolder As String
Dim strFile As String
Dim i As Long

On Error Resume Next
If lngCount = 0 Then ReDim avarResult(1 To 1)
' Erst einmal 100 Unterverzeichnisse annehmen
ReDim astrFolder(1 To 100)

If Left(strFilter, 1) <> "*" Then strFilter = "*" & strFilter

If Right$(strStart, 1) <> "\" Then
' Nachschauen, ob übergebener Pfad auch einen
' Backslash enthält. Wenn nicht, dann anhängen
strStart = strStart & "\"
End If

strFolder = strStart

' Alle Dateien liefern
strStart = strStart & "*"

' Suche mit Dir() initialisieren
strFile = Dir(strStart, vbSystem Or _
vbHidden Or vbDirectory Or vbNormal)

Do While strFile <> ""
' So lange durchlaufen, wie
' durch Dir() etwas geliefert wird
If GetAttr(strFolder & strFile) And vbDirectory Then
' wenn Datei ein Verzeichnis ist
If Right$(strFile, 1) <> "." Then
' und zwar ein untergeordnetes,
' (Punkte sind Übergeordnete Verzeichnisse)
i = i + 1
If i > UBound(astrFolder) Then
' Wenn Array zu klein ist, anpassen
ReDim Preserve astrFolder(1 To i + 1)
End If
' dann ein Array mit Verzeichnissen füllen.
astrFolder(i) = strFile
End If
Else
' Handelt es sich um eine Datei,
If LCase(strFile) Like LCase(strFilter) Then
' und entspricht sie noch den Filterbedingungen,
lngCount = lngCount + 1
ReDim Preserve avarResult(1 To lngCount)
avarResult(lngCount) = strFolder & strFile
End If
End If
strFile = Dir$()
Loop

If i <> 0 Then
' Array anpassen
ReDim Preserve astrFolder(1 To i)
' Jetzt erst werden die Unterverzeichnisse abgearbeitet,
' weil Dir$ mit Rekursionen nicht klarkommt.
For i = 1 To UBound(astrFolder)
' Jetzt ruft sich diese Prozedur noch einmal auf.
SearchFiles strFolder & astrFolder(i),strFilter,varResult,lngCount
Next
End If

SearchFiles = avarResult

End Function

Du kannst die Funktion ShellGetFolder wie in der Prozedur Testen mit einem
Anfangspfad als String aufrufen, oder du übergibst eine der Konstanten wie
ssfMYPICTURES.

Viele Grüße
Michael

--
http://michael-schwimmer.de
Masterclass Excel VBA ISBN-10: 3827325250
Das Excel-VBA Codebook ISBN-10: 3827324718
Microsoft Office Excel 2007-Programmierung ISBN-10: 3866454139

[Christian Hahn]

"Andreas Killer" <andreas...@gmx.net> schrieb im Newsbeitrag

news:49b3d26e$0$30228$9b4e...@newsspool1.arcor-online.net...

Sehr schön, besten Dank!
Ursprünglich suchte ich nur einem Dialog-Fenster, das mir einen Folder-Pfad
zurückliefert.
Von dort aus wollte ich mir die Datei-Namen selbst herausfummeln.
(Da hab' ich auch was, aber nicht so professionell, wie bei dir.)
Nun hast du mir mehr als das geliefert, großartig.
Was mir bleibt, ist noch, wie gesagt, mit beiden Funktionen den
Gesamtbestand aller Dateien und Unterordner einers übergeordneten Ordners
zusammenzusetzen.
beste Grüße, Christian Hahn.

[Michael Schwimmer]

Hallo Christian,

>> With Application.FileSearch

kaufen Sie Office 2007, dann können Sie endlich Ihren Code neu schreiben!
So könnte eine Werbung von M$ lauten.

Aber mal im Ernst, in Excel 2007 existiert das FileSearch Objekt nicht
mehr, wenn du also deine Mappe weitergeben, oder auf längere Sicht benutzen
möchtest, würde ich darauf verzichten.

[Bernd P]

Hallo Michael,

Ist Dein Code zukunftssicherer als Erlandsen's:
http://www.erlandsendata.no/english/index.php?t=envbafolders
http://erlandsendata.no/?cat=21
?

Ich versuche ja so wenig wie moeglich Benutzereingriffe zu
programmieren und alles in Param-Sheets oder via Ini-Dateien bereit zu
stellen...Dann kann ich meinen Code auch als Batch auf einen Server
stellen...

Viele Gruesse,
Bernd

[Michael Schwimmer]

Hallo Bernd,

Am Sun, 8 Mar 2009 16:15:58 -0700 (PDT) schrieb Bernd P:
> Ist Dein Code zukunftssicherer als Erlandsen's:
> http://www.erlandsendata.no/english/index.php?t=envbafolders
> http://erlandsendata.no/?cat=21

Ich denke mir, dass das Shell.Application-Object auch in zukünftigen
Versionen abwärtskompatibel ist. Momentan steckt ja die Shell32.dll
dahinter, zum Erfragen eines Folders kommt also die API Function
SHBrowseForFolder zum Einsatz.

Das Shell.Application-Object ist leichter zu handhaben, hat aber auch
gewisse Einschränkungen gegenüber der Raw Programmierung mit Declare und
Co. Wenn man beispielsweise einen Folder als Anfangspfad vorgibt, kann man
beim Shell-Objekt nicht mehr zum übergeordneten Folder, während das über
die API-Funktionen ohne Probleme möglich ist.

[Bernd P]

Hallo Michael,

Danke, das ist gut zu wissen. Dann stell doch bitte Deinen Code auf
Deine Homepage damit ich spaeter die Wahl habe, von wo ich den Code
kopieren (stehlen) kann :-)

Viele Gruesse,
Bernd

[Andreas Killer]

Michael Schwimmer schrieb:

> Option Explicit

> Private Const BIF_EDITBOX As Long = &H10
> Private Const BIF_VALIDATE As Long = &H20
> Private Const BIF_NEWDIALOGSTYLE As Long = &H40

> Private Const BIF_BROWSEFORPRINTER As Long = &H2000

...

> 'Drucker
> Private Const ssfPRINTERS As Long = &H4

...

> Set objShell = CreateObject("Shell.Application")

> Set objBrowse = objShell.BrowseForFolder( _
> &H0, Caption, lngOptions, CLng(start))

Das ist ja schick und da hab da mal 'ne Frage. :)

Wenn ich

Set objBrowse = objShell.BrowseForFolder( _

&H0, Caption, BIF_BROWSEFORPRINTER, ssfPRINTERS)
sage, dann werden wunderbar die Drucker angezeigt, aber auswählen kann
ich keinen.

Setze ich zusätzlich BIF_EDITBOX dann kann ich einen auswählen und auf
Ok klicken aber ich bekomme den Namen nicht.

Mach ich was falsch oder gibt es sowas speziell für Drucker auch?

Andreas.

[Michael Schwimmer]

Hallo Andreas,

> Set objBrowse = objShell.BrowseForFolder( _
> &H0, Caption, BIF_BROWSEFORPRINTER, ssfPRINTERS)

ich nehme an, das wird nicht funktionieren. BrowseForFolder sollte nur
Folder zurückgeben, Drucker sind aber keine.

Private Sub Testen()

On Error Resume Next

Dim objShell As Object

Dim objPrinters As Object
Dim objPrinter As Object
Dim strOut As String

Set objShell = CreateObject("Shell.Application")

Set objPrinters = objShell.Namespace(ssfPRINTERS).Items

For Each objPrinter In objPrinters
With objPrinter
strOut = strOut & .Name & " IsFolder=" & .IsFolder & vbCrLf
End With
Next

MsgBox strOut

End Sub

Die IsFolder-Eigenschaft der Drucker ist auf jeden Fall False.
So auf Anhieb kenne ich eigentlich keinen Dialog zur Druckerauswahl,
welcher den Drucker nicht ändert.

Eventuell funzt das über die API PrintDialog, ist aber, soweit ich das auf
die Schnelle überblicken kann, eine elendige Schinderei.