AW: FileDialog
04.04.2005 22:50:54
Ramses
Hallo
eine einfache Variante für alle Office Versionen
Option Explicit
'############################################################################################'
' Die folgenden Makros durchsuchen einen Ordner und seine Unterordner '
' Modified by Ramses '
' Der Code besteht zu TeilFragmenten aus Forumsbeiträgen
' Die einzelnen Verfasser sind mir leider nicht mehr bekannt. '
'############################################################################################'
'############################################################################################'
'Dieser Bereich kann entfallen, wenn der Variable 'Laufwerk' ein fester Wert zugewiesen wird.'
Public 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 '
Declare
Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare
Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Msg) As String
Dim myInfo As BROWSEINFO
Dim mypath As String
Dim Root As Long, ID As Long, pos As Integer
With myInfo
.pidlRoot = 0&
.lpszTitle = Msg
.ulFlags = &H1
End With
ID = SHBrowseForFolder(myInfo)
mypath = Space$(512)
Root = SHGetPathFromIDList(ByVal ID, ByVal mypath)
If Root Then
pos = InStr(mypath, Chr$(0))
GetDirectory = Left(mypath, pos - 1)
Else
GetDirectory = ""
End If
End Function
Sub Select_Path()
Dim Msg As String, mypath As String
Msg = "Wählen Sie ein Verzeichnis aus," & Chr(13) & "dessen Inhalt angezeigt werden soll:"
mypath = GetDirectory(Msg)
If Len(mypath) > 0 Then
MsgBox "Sie haben das Verzeichnis: " & mypath & " ausgewählt"
Else
MsgBox "Nichts ausgewählt"
End If
End Sub
Und hier die Variante speziell für Office XP und höher
Sub A_Pfad_wählen()
Dim i As Integer, y As Integer, totFiles As Integer, Qe As Integer
Dim Sind As Long
Dim wks As Worksheet
Dim gefFile As String
Dim Suchbegriff As String, Suchpfad As String
Dim oldStatus As Variant
'Neue Funktion erst ab Office XP verwendbar
'bzw. auch unter 2000 wenn ein Verweis auf die Office 10 Library
'gesetzt werden kann.
'Öffnet einen Dialog indem der Pfad elegant wie im normalen
'Datei-Dialog gewählt werden kann.
Dim Suchdialog As FileDialog
Set Suchdialog = Application.FileDialog(msoFileDialogFolderPicker)
If Application.Version < 10 Then
Qe = MsgBox("Diese Datei bzw. dieser Suchdialog ist erst ab EXCEL XP möglich!", vbCritical + vbOKOnly, "Tut mir leid...")
Exit Sub
End If
Application.ScreenUpdating = False
oldStatus = Application.DisplayStatusBar
Application.DisplayStatusBar = True
'Hier wird der neue FolderPickerDialog aufgerufen
With Suchdialog
.Title = "Bitte wählen Sie ein Verzeichnis aus"
'Environ(25) ermittelt den Aktuellen Userpfad
.InitialFileName = Environ(25) & "\Eigene Dateien\"
.ButtonName = "Auswahl übernehmen"
.Show
If .SelectedItems.count = 0 Then
MsgBox "Sie haben keine Auswahl getroffen", vbInformation
Set Suchdialog = Nothing
Exit Sub
Else
For Sind = 1 To .SelectedItems.count
Suchpfad = Suchpfad & .SelectedItems(Sind) & vbCrLf
Next Sind
End If
End With
MsgBox ("Der Suchpfad den Sie gewählt haben lautet: " & Suchpfad)
End Sub
Gruss Rainer