Code:
'// ---------------------------------------------------------------------------
'// Klasse: cSHFolder.cls
'// Kapselt den Zugriff auf den "Ordner auswählen" Dialog
'//
'// Zur Nutzung muss das Modul "modSHFolder" im Projekt enthalten sein.
'//
'// Copyright: ©1998-2001 Thorsten Dörfler (doerfler.t@vb-hellfire.de)
'// http://www.vb-hellfire.de
'// ---------------------------------------------------------------------------
Option Explicit
Option Compare TextPrivate Type BROWSEINFO
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const WM_USER = &H400
Private Const SWP_NOSIZE = 1
Private Const SWP_NOZORDER = 4
Private Const MAX_PATH = 260
'// BROWSEINFO ulFlags:
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4
' ab Shell32 4.71 (IE4/Win98)
Private Const BIF_EDITBOX = &H10
Private Const BIF_VALIDATE = &H32
Private Const BIF_BROWSEINCLUDEFILES = &H4000
' ab Shell32 5.0 (Win2000)
Private Const BIF_NEWDIALOGSTYLE = &H40
'// Gesendete CallBack Nachrichten:
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
' ab Shell32 4.71 (IE4/Win98)
Private Const BFFM_VALIDATEFAILED = 3
'// Zu sendende Nachrichten:
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_ENABLEOK = (WM_USER + 101)
Private Const BFFM_SETSELECTION = (WM_USER + 102)
Private Declare Function SHBrowseForFolder Lib "Shell32" (lpbi As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "Shell32" (ByVal hWndOwner As Long, ByVal nFolder As Integer, ppidl As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal hMem As Long)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Public Enum ShellSpecialFolderConstants
CSIDL_DESKTOP = 0& 'Alle Ressourcen ab Desktop
CSIDL_PROGRAMS = &H2& 'Startmenü Programme <aktueller Benutzer>
CSIDL_PRINTERS = &H4& 'Drucker
CSIDL_PERSONAL = &H5& 'Eigene Dateien <aktueller Benutzer>
CSIDL_FAVORITES = &H6& 'Favoriten <aktueller Benutzer>
CSIDL_STARTMENU = &HB& 'Gesamtes Startmenü <aktueller Benutzer>
CSIDL_DESKTOPDIRECTORY = &H10& 'Desktop (Ordner) <aktueller Benutzer>
CSIDL_DRIVES = &H11& 'Arbeitsplatz
CSIDL_NETWORK = &H12& 'Netzwerkumgebung
CSIDL_NETHOOD = &H13& 'Netzwerkumgebung (Ordner)
CSIDL_FONTS = &H14& 'Fonts (Ordner)
CSIDL_TEMPLATES = &H15& 'Vorlagen (Ordner)
CSIDL_COMMON_STARTMENU = &H16& 'Gesamtes Startmenü <alle Benutzer>
CSIDL_COMMON_PROGRAMS = &H17& 'Startmenü Programme <alle Benutzer>
CSIDL_COMMON_STARTUP = &H18& 'Autostart (Ordner) <alle Benutzer>
CSIDL_COMMON_DESKTOPDIRECTORY = &H18& 'Destop (Ordner) <alle Benutzer>
CSIDL_APPDATA = &H1A& 'Anwendungsdaten <aktueller Benutzer> (ab Shell32 4.71)
CSIDL_PRINTHOOD = &H1B& 'Druckumgebung (Ordner)
CSIDL_ALTSTARTUP = &H1D& 'Altern. Autostart (Ordner) <aktueller Benutzer>
CSIDL_COMMON_ALTSTARTUP = &H1E& 'Altern. Autostart (Ordner) <alle Benutzer>
CSIDL_COMMON_FAVORITES = &H1F& 'Favoriten <alle Benutzer>
CSIDL_INTERNET_CACHE = &H20& 'Temp. Internet Files (ab Shell32 4.72)
CSIDL_COOKIES = &H21& 'Internet Cookies (Ordner)
CSIDL_HISTORY = &H22& 'Internet Verlauf (Ordner)
' ab Shell32 5.0 (Win2000)
CSIDL_COMMON_APPDATA = &H23 'Anwendungsdaten <alle Benutzer>
CSIDL_WINDOWS = &H24 'GetWindowsDirectory()
CSIDL_SYSTEM = &H25 'GetSystemDirectory()
CSIDL_PROGRAM_FILES = &H26 'Programme
CSIDL_MYPICTURES = &H27 'Eigene Bilder
CSIDL_PROFILE = &H28 'Dokumente & Einstellungen
CSIDL_PROGRAM_FILES_COMMON = &H2B 'Gemeinsame Dateien
CSIDL_COMMON_TEMPLATES = &H2D 'Vorlagen (Ordner) <alle Benutzer>
CSIDL_COMMON_DOCUMENTS = &H2E 'Dokumente <alle Benutzer>
CSIDL_COMMON_ADMINTOOLS = &H2F 'Startmenü "Verwaltung" <alle Benutzer>
CSIDL_ADMINTOOLS = &H30 'Startmenü "Verwaltung" <aktueller Benutzer>
CSIDL_CONNECTIONS = &H31 'Netzwerk- und DFÜ-Verbindungen
End Enum
'// Eigenschaften:
Private pbol_CenterDialog As Boolean
Private pbol_EditBox As Boolean
Private pbol_IncludeFiles As Boolean
Private pbol_NewDialog As Boolean
Private pbol_StatusTextArea As Boolean
Private pstr_Caption As String
Private pstr_ValidFolder As String
Private pstr_DefaultPath As String
Private pstr_StatusText As String
Private pstr_DisplayName As String
Private plng_hWnd As Long
Private pudt_DefaultPIDL As ShellSpecialFolderConstants
Public Event Initialized()
Public Event SelectionChanged(ByVal PathSelected As String)
Public Event ValidationFailed(ByVal InvalidPath As String, ByRef Cancel As Boolean)
'// ---------------------------------------------------------------------------
'// Eigenschaft: DisplayName
'// Gibt den Titel des ausgewählten Elements zurück.
'// ---------------------------------------------------------------------------
Public Property Get DisplayName() As String
DisplayName = pstr_DisplayName
End Property
Private Function pPtrToStr(ByVal lPtr As Long) As String
Dim strBuffer As String
strBuffer = Space$(lstrlen(lPtr))
lstrcpy strBuffer, lPtr
pPtrToStr = strBuffer
End Function
'// BrowseCallback Empfängerprozedur:
Friend Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
Dim bolIsValid As Boolean
Dim strPath As String
Dim bolCancel As Boolean
Select Case uMsg
Case BFFM_INITIALIZED
plng_hWnd = hWnd '// Handle speichern
'// Dialogtitel/Statustext/DefaultPIDL|Path festlegen:
If pstr_Caption <> vbNullString Then Me.Caption = pstr_Caption
If pstr_StatusText <> vbNullString Then Me.StatusText = pstr_StatusText
If pudt_DefaultPIDL <> vbEmpty Then Me.DefaultPIDL = pudt_DefaultPIDL
If pstr_DefaultPath <> vbNullString Then Me.DefaultPath = pstr_DefaultPath
'// Dialog ggf. zentrieren:
If (pbol_CenterDialog) Then Me.CenterDialog = True
RaiseEvent Initialized
Case BFFM_SELCHANGED
'// Nur bestimmte Dateien/Verzeichnisse zur Auswahl zulassen:
If pstr_ValidFolder <> vbNullString Then
strPath = pPathFromPIDL(lParam)
Me.OKEnabled = (strPath Like "*" & pstr_ValidFolder)
End If
RaiseEvent SelectionChanged(pPathFromPIDL(lParam))
Case BFFM_VALIDATEFAILED
RaiseEvent ValidationFailed(pPtrToStr(lParam), bolCancel)
BrowseCallbackProc = CLng(Not bolCancel)
End Select
End Function
'// ---------------------------------------------------------------------------
'// Eigenschaft: DefaultPath
'// String. Legt den Pfad fest, der selektiert und expandiert
'// dargestellt werden soll.
'// ---------------------------------------------------------------------------
Public Property Let DefaultPath(ByVal New_Value As String)
pstr_DefaultPath = New_Value
If (plng_hWnd <> 0) Then
SendMessage plng_hWnd, BFFM_SETSELECTION, True, ByVal New_Value
End If
End Property
'// ---------------------------------------------------------------------------
'// Eigenschaft: DefaultPIDL
'// ShellSpecialFolder Konstante. Legt den Pfad fest über eine
'// CSIDL fest, der selektiert und expandiert dargestellt werden
'// soll.
'// ---------------------------------------------------------------------------
Public Property Let DefaultPIDL(ByVal New_Value As ShellSpecialFolderConstants)
Dim lngRootPIDL As Long
pudt_DefaultPIDL = New_Value
If (plng_hWnd <> 0) Then
SHGetSpecialFolderLocation plng_hWnd, New_Value, lngRootPIDL
SendMessage plng_hWnd, BFFM_SETSELECTION, False, ByVal lngRootPIDL
End If
End Property
'// ---------------------------------------------------------------------------
'// Eigenschaft: OKEnabled
'// Boolesch. Legt fest, ob der OK Button freigegeben oder
'// gesperrt ist (nur während der Anzeige des Dialogs gültig)
'// ---------------------------------------------------------------------------
Public Property Let OKEnabled(ByVal New_Value As Boolean)
If (plng_hWnd <> 0) Then
SendMessage plng_hWnd, BFFM_ENABLEOK, 0, ByVal CLng(New_Value)
End If
End Property
Private Function pPathFromPIDL(ByVal PIDL As Long) As String
Dim strPath As String
If (PIDL <> 0) Then
strPath = Space$(MAX_PATH)
SHGetPathFromIDList PIDL, strPath
strPath = Left$(strPath, InStr(strPath, Chr$(0)) - 1)
Else
strPath = vbNullString
End If
pPathFromPIDL = strPath
End Function
'// ---------------------------------------------------------------------------
'// Eigenschaft: StatusText
'// String. Legt den Text fest, der im Statusbereich unterhalb
'// des Dialogtitel angezeigt werden soll.
'// ---------------------------------------------------------------------------
Public Property Let StatusText(ByVal New_Value As String)
If plng_hWnd = 0 Then
pstr_StatusText = New_Value
Else
If (pbol_StatusTextArea) Then
SendMessage plng_hWnd, BFFM_SETSTATUSTEXT, 0, ByVal New_Value
End If
End If
End Property
'// ---------------------------------------------------------------------------
'// Eigenschaft: hWnd
'// Long. Gibt den Handle des Dialogs zurück.
'// ---------------------------------------------------------------------------
Public Property Get hWnd() As Long
hWnd = plng_hWnd
End Property
'// ---------------------------------------------------------------------------
'// Eigenschaft: NewDialog
'// Boolesch. Legt fest, ob der Dialog im erweitertem Stil (ab
'// Windows 2000) angezeigt werden soll.
'// ---------------------------------------------------------------------------
Public Property Let NewDialog(ByVal New_Value As Boolean)
pbol_NewDialog = New_Value
End Property
'// ---------------------------------------------------------------------------
'// Eigenschaft: StatusTextArea
'// Boolesch. Legt fest, ob ein Statusbereich unterhalb des
'// Titels angezeigt werden soll.
'// ---------------------------------------------------------------------------
Public Property Let StatusTextArea(ByVal New_Value As Boolean)
pbol_StatusTextArea = New_Value
End Property
'// ---------------------------------------------------------------------------
'// Eigenschaft: ValidFolder
'// Boolesch. Legt fest, welche Dateinamen eine zulässige
'// Auswahl darstellen. Platzhalter sind erlaubt.
'// ---------------------------------------------------------------------------
Public Property Let ValidFolder(ByVal New_Value As String)
pstr_ValidFolder = New_Value
End Property
'// ---------------------------------------------------------------------------
'// Eigenschaft: Caption
'// String. Legt fest, welcher Text in der Titelzeile des Dialogs
'// angezeigt werden soll.
'// ---------------------------------------------------------------------------
Public Property Let Caption(ByVal New_Value As String)
pstr_Caption = New_Value
If (plng_hWnd <> 0) Then
SetWindowText plng_hWnd, New_Value
End If
End Property
'// ---------------------------------------------------------------------------
'// Funktion: BrowseForFolder
'// Zeigt den "Ordner auswählen" Dialog an.
'// Parameter:
'// [Parent] => Form/UserControl Objekt zu dem der Dialog modal angezeigt wird
'// [Title] => Zeichenfolge, die im Dialog angezeigt werden soll
'// [RootFolder] => ShellSpecialFolder Konstante, die den Startordner angibt
'//
'// Rückgabe: => Zeichenfolge, die den gewählten Pfad angibt bzw.
'// vbNullString, wenn "Abbrechen" gewählt wurde.
'// ---------------------------------------------------------------------------
Public Function BrowseForFolder(Optional Parent As Variant, _
Optional Title As Variant, _
Optional RootFolder As ShellSpecialFolderConstants = CSIDL_DESKTOP) As String
Dim tBI As BROWSEINFO
Dim lhWndParent As Long
Dim lngOptions As Long
Dim lngRootPIDL As Long
Dim lngPIDL As Long
If IsMissing(Parent) = False Then lhWndParent = 0 'Parent.hWnd
If IsMissing(Title) Then Title = "Wählen Sie einen Ordner aus"
'// Optionen entsprechend den Eigenschaften setzen:
lngOptions = BIF_RETURNONLYFSDIRS
If (pbol_IncludeFiles) Then lngOptions = lngOptions Or BIF_BROWSEINCLUDEFILES
If (pbol_StatusTextArea) Then lngOptions = lngOptions Or BIF_STATUSTEXT
If (pbol_EditBox) Then lngOptions = lngOptions Or BIF_EDITBOX Or BIF_VALIDATE
If (pbol_NewDialog) Then lngOptions = lngOptions Or BIF_NEWDIALOGSTYLE
'// Eigentlich sollte sich pIDLRoot mit einer CSIDL - Konstante zufrieden
'// geben, wenn man aber den erweiterten Dialog Stil BIF_NEWDIALOGSTYLE ab
'// Win2000 nutzen will, muss die CSIDL Konstante in einen PIDL konvertiert
'// werden, da ansonsten die Anwendung abgeschossen wird. Warum? Wer es weiß,
'// darf es mir sagen.
SHGetSpecialFolderLocation lhWndParent, RootFolder, lngRootPIDL
With tBI
.hWndOwner = lhWndParent
.pszDisplayName = Space$(MAX_PATH)
.pIDLRoot = lngRootPIDL
.ulFlags = lngOptions
.lpszTitle = Title
.lpfnCallback = pGetProcAddress(AddressOf modSHFolder.BrowseCallbackProc)
End With
modSHFolder.Attach Me
lngPIDL = SHBrowseForFolder(tBI)
modSHFolder.Detach
plng_hWnd = 0
If pPathFromPIDL(lngPIDL) <> vbNullString Then
pstr_DisplayName = Left$(tBI.pszDisplayName, InStr(1, tBI.pszDisplayName, Chr$(0)) - 1)
End If
BrowseForFolder = pPathFromPIDL(lngPIDL)
CoTaskMemFree lngPIDL
End Function
'// ---------------------------------------------------------------------------
'// Eigenschaft: CenterDialog
'// Boolesch. Legt fest, ob der Dialog bildschirmmittig angezeigt
'// werden soll.
'// ---------------------------------------------------------------------------
Public Property Let CenterDialog(ByVal New_Value As Boolean)
Dim tRC As RECT
Dim lngLeft As Long
Dim lngTop As Long
pbol_CenterDialog = New_Value
If (plng_hWnd <> 0) Then
If (New_Value) Then
GetWindowRect plng_hWnd, tRC
With tRC
lngLeft = (Screen.Width \ Screen.TwipsPerPixelX - .Right + .Left) \ 2
lngTop = (Screen.Height \ Screen.TwipsPerPixelY - .Bottom + .Top) \ 2
End With
SetWindowPos plng_hWnd, 0, lngLeft, lngTop, 0, 0, SWP_NOSIZE Or SWP_NOZORDER
End If
End If
End Property
'// ---------------------------------------------------------------------------
'// Eigenschaft: EditBox
'// Boolesch. Legt fest, ob ein Eingabefeld zur manuellen
'// Pfadangabe angezeigt wird. (ab Shell32 4.71)
'// ---------------------------------------------------------------------------
Public Property Let EditBox(ByVal New_Value As Boolean)
pbol_EditBox = New_Value
End Property
'// ---------------------------------------------------------------------------
'// Eigenschaft: IncludeFiles
'// Boolesch. Legt fest, ob neben den Verzeichnissen auch Dateien
'// zur Auswahl stehen (ab Shell32 4.71).
'// ---------------------------------------------------------------------------
Public Property Let IncludeFiles(New_Value As Boolean)
pbol_IncludeFiles = New_Value
End Property
Private Function pGetProcAddress(ByVal ProcAddress As Long)
pGetProcAddress = ProcAddress
End Function