Die Community zu .NET und Classic VB.
Menü

Tipp-Upload: VB 5/6 0170: FolderBrowserDialog, voreingestellter Pfad mit Callback

 von 

Über den Tipp  

Dieser Tippvorschlag ist noch unbewertet.

Der Vorschlag ist in den folgenden Kategorien zu finden:

  • Dateien und Laufwerke
  • Steuerelemente
  • System

Dem Tippvorschlag wurden folgende Schlüsselwörter zugeordnet:
FolderBrowserDialog, CallBack

Der Vorschlag wurde erstellt am: 03.01.2008 02:31.
Die letzte Aktualisierung erfolgte am 06.12.2018 19:55.

Zurück zur Übersicht

Beschreibung  

FolderBrowserDialog, voreingestellter Pfad mit Callback - Anstatt mühsam eigene Dialoge zu schreiben oder sich mit der Ordner-Listbox rumzuschlagen, nimmt man besser gleich die systemeigenen Dialoge. Hier für die Auswahl bestimmter Objekte, oder Ordner.
Aktualisierung von Tipp 0477 von Oliver Meyer 28.04.2007:
Der Tipp enthält nun zusätzlich eine Callback-Prozedur, die es ermöglicht, den Pfad im Dialog einzustellen, der vom FolderBrowserDialog beim Start angezeigt werden soll.

Schwierigkeitsgrad

Schwierigkeitsgrad 1

Verwendete API-Aufrufe:

CoTaskMemFree, GetActiveWindow, SHBrowseForFolder, SHGetPathFromIDList, SHGetSpecialFolderLocation, SendMessageA, lstrlenA

Download:

Download des Beispielprojektes [7,63 KB] 

' Dieser Source stammt von http://www.activevb.de
' und kann frei verwendet werden. Für eventuelle Schäden
' wird nicht gehaftet.

' Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
' Ansonsten viel Spaß und Erfolg mit diesem Source!

' ------------- Anfang Projektdatei Projekt1.vbp -------------

' --------- Anfang Formular "Form1" alias Form1.frm  ---------

' Steuerelement: Beschriftungsfeld "Label1"
' Steuerelement: Kontrollkästchen-Steuerelement "ChkShowNewFolderButton"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Textfeld "TxtSelectedPath"
' Steuerelement: Kontrollkästchen-Steuerelement "ChkShowEditBox"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Schaltfläche "Command3"
' Steuerelement: Schaltfläche "BtnFolderBrowser"
' Steuerelement: Schaltfläche "Command4"
' Steuerelement: Kombinationsliste "CmbSpecialFolder"
' Steuerelement: Kontrollkästchen-Steuerelement "ChkSelectedPath"

Option Explicit

Private Sub Form_Load()

    TxtSelectedPath.Text = App.Path

    With CmbSpecialFolder

        Call .AddItem("SpecialFolder_Desktop"):     .ItemData(.NewIndex) = SpecialFolder_Desktop
        Call .AddItem("CSIDL_INTERNET"):            .ItemData(.NewIndex) = CSIDL_INTERNET
        Call .AddItem("SpecialFolder_Programs"):    .ItemData(.NewIndex) = SpecialFolder_Programs
        Call .AddItem("CSIDL_CONTROLS"):            .ItemData(.NewIndex) = CSIDL_CONTROLS
        Call .AddItem("CSIDL_PRINTERS"):            .ItemData(.NewIndex) = CSIDL_PRINTERS
        Call .AddItem("SpecialFolder_Personal"):    .ItemData(.NewIndex) = SpecialFolder_Personal
        Call .AddItem("SpecialFolder_Favorites"):   .ItemData(.NewIndex) = SpecialFolder_Favorites
        Call .AddItem("SpecialFolder_Startup"):     .ItemData(.NewIndex) = SpecialFolder_Startup
        Call .AddItem("SpecialFolder_Recent"):      .ItemData(.NewIndex) = SpecialFolder_Recent
        Call .AddItem("SpecialFolder_SendTo"):      .ItemData(.NewIndex) = SpecialFolder_SendTo
        Call .AddItem("CSIDL_BITBUCKET"):           .ItemData(.NewIndex) = CSIDL_BITBUCKET
        Call .AddItem("SpecialFolder_StartMenu"):   .ItemData(.NewIndex) = SpecialFolder_StartMenu

        ' &HC ??
        Call .AddItem("SpecialFolder_MyMusic"):     .ItemData(.NewIndex) = SpecialFolder_MyMusic

        ' &HE, &HF ??
        Call .AddItem("SpecialFolder_DesktopDirectory")

        .ItemData(.NewIndex) = SpecialFolder_DesktopDirectory

        Call .AddItem("SpecialFolder_MyComputer"):  .ItemData(.NewIndex) = SpecialFolder_MyComputer
        Call .AddItem("CSIDL_NETWORK"):             .ItemData(.NewIndex) = CSIDL_NETWORK

        ' Hood = Umgebung
        Call .AddItem("CSIDL_NETHOOD"):             .ItemData(.NewIndex) = CSIDL_NETHOOD
        Call .AddItem("CSIDL_FONTS"):               .ItemData(.NewIndex) = CSIDL_FONTS
        Call .AddItem("SpecialFolder_Templates"):   .ItemData(.NewIndex) = SpecialFolder_Templates
        Call .AddItem("CSIDL_COMMON_STARTMENU"):    .ItemData(.NewIndex) = CSIDL_COMMON_STARTMENU
        Call .AddItem("CSIDL_COMMON_PROGRAMS"):     .ItemData(.NewIndex) = CSIDL_COMMON_PROGRAMS
        Call .AddItem("CSIDL_COMMON_STARTUP"):      .ItemData(.NewIndex) = CSIDL_COMMON_STARTUP
        Call .AddItem("CSIDL_COMMON_DESKTOPDIRECTORY")

        .ItemData(.NewIndex) = CSIDL_COMMON_DESKTOPDIRECTORY

        Call .AddItem("SpecialFolder_ApplicationData")

        .ItemData(.NewIndex) = SpecialFolder_ApplicationData

        Call .AddItem("CSIDL_PRINTHOOD"):           .ItemData(.NewIndex) = CSIDL_PRINTHOOD
        Call .AddItem("SpecialFolder_LocalApplicationData")

        .ItemData(.NewIndex) = SpecialFolder_LocalApplicationData

        Call .AddItem("CSIDL_ALTSTARTUP"):          .ItemData(.NewIndex) = CSIDL_ALTSTARTUP
        Call .AddItem("CSIDL_COMMON_ALTSTARTUP"):   .ItemData(.NewIndex) = CSIDL_COMMON_ALTSTARTUP
        Call .AddItem("CSIDL_COMMON_FAVORITES"):    .ItemData(.NewIndex) = CSIDL_COMMON_FAVORITES
        Call .AddItem("SpecialFolder_InternetCache")

        .ItemData(.NewIndex) = SpecialFolder_InternetCache

        Call .AddItem("SpecialFolder_Cookies"):     .ItemData(.NewIndex) = SpecialFolder_Cookies
        Call .AddItem("SpecialFolder_History"):     .ItemData(.NewIndex) = SpecialFolder_History
        Call .AddItem("SpecialFolder_CommonApplicationData")

        .ItemData(.NewIndex) = SpecialFolder_CommonApplicationData

        Call .AddItem("CSIDL_WINDOWS"):             .ItemData(.NewIndex) = CSIDL_WINDOWS
        Call .AddItem("SpecialFolder_System"):      .ItemData(.NewIndex) = SpecialFolder_System
        Call .AddItem("SpecialFolder_ProgramFiles")

        .ItemData(.NewIndex) = SpecialFolder_ProgramFiles

        Call .AddItem("SpecialFolder_MyPictures"):  .ItemData(.NewIndex) = SpecialFolder_MyPictures
        Call .AddItem("CSIDL_PROFILE"):             .ItemData(.NewIndex) = CSIDL_PROFILE
        Call .AddItem("CSIDL_SYSTEMX86"):           .ItemData(.NewIndex) = CSIDL_SYSTEMX86
        Call .AddItem("CSIDL_PROGRAM_FILESX86"):    .ItemData(.NewIndex) = CSIDL_PROGRAM_FILESX86
        Call .AddItem("SpecialFolder_CommonProgramFiles")

        .ItemData(.NewIndex) = SpecialFolder_CommonProgramFiles

        Call .AddItem("CSIDL_PROGRAM_FILES_COMMONX86")

        .ItemData(.NewIndex) = CSIDL_PROGRAM_FILES_COMMONX86

        Call .AddItem("CSIDL_COMMON_TEMPLATES"):    .ItemData(.NewIndex) = CSIDL_COMMON_TEMPLATES
        Call .AddItem("CSIDL_COMMON_DOCUMENTS"):    .ItemData(.NewIndex) = CSIDL_COMMON_DOCUMENTS
        Call .AddItem("CSIDL_COMMON_ADMINTOOLS"):   .ItemData(.NewIndex) = CSIDL_COMMON_ADMINTOOLS
        Call .AddItem("CSIDL_ADMINTOOLS"):          .ItemData(.NewIndex) = CSIDL_ADMINTOOLS
        Call .AddItem("CSIDL_CONNECTIONS"):         .ItemData(.NewIndex) = CSIDL_CONNECTIONS
        Call .AddItem("CSIDL_FLAG_DONT_VERIFY"):    .ItemData(.NewIndex) = CSIDL_FLAG_DONT_VERIFY
        Call .AddItem("CSIDL_FLAG_CREATE"):         .ItemData(.NewIndex) = CSIDL_FLAG_CREATE
        Call .AddItem("CSIDL_FLAG_MASK"):           .ItemData(.NewIndex) = CSIDL_FLAG_MASK
        Call .AddItem("CSIDL_FLAG_PFTI_TRACKTARGET")

        .ItemData(.NewIndex) = CSIDL_FLAG_PFTI_TRACKTARGET

        ' .Text = "SpecialFolder_Desktop"
        .ListIndex = 0
    End With

End Sub

Private Sub BtnFolderBrowser_Click()

    Call ShowFBD(CmbSpecialFolder.ItemData(CmbSpecialFolder.ListIndex))

End Sub

Private Sub Command1_Click()

    Call ShowFBD(SpecialFolder_MyComputer)

End Sub

Private Sub Command2_Click()

    Call ShowFBD(CSIDL_NETWORK)

End Sub

Private Sub Command3_Click()

    Call ShowFBD(CSIDL_PRINTERS)

End Sub

Private Sub Command4_Click()

    Call ShowFBD(SpecialFolder_Personal)

End Sub

Private Sub ShowFBD(spf As Environment_SpecialFolder)

    With New FolderBrowserDialog ' FBD
        .RootFolder = spf

        Select Case spf

        Case SpecialFolder_MyComputer
            .Flags = .Flags Or BIF_RETURNONLYFSDIRS

        Case CSIDL_NETWORK
            .Flags = 0 ' vorher zu null setzen!
            .Flags = .Flags Or BIF_BROWSEFORCOMPUTER

        Case CSIDL_PRINTERS
            .Flags = .Flags Or BIF_BROWSEFORPRINTER

        Case SpecialFolder_Personal

            ' .Flags = .Flags Or BIF_DONTGOBELOWDOMAIN
            .Flags = 0
            .Flags = .Flags Or BIF_RETURNFSANCESTORS

        End Select

        If ChkShowEditBox.Value = vbChecked Then
            .Flags = .Flags Or BIF_EDITBOX
        End If

        If Me.ChkShowNewFolderButton = vbUnchecked Then
            .Flags = .Flags Or BIF_DONTSHOWNEWFOLDERBUTTON
        End If

        ' maximal 3 Zeilen Beschreibungstext
        .Description = "Hier sollte ein Hinweis stehen für den Benutzer was er hier tun " & _
            "soll. In maximal 3 Zeilen erklärt. 12345 67890 12345 67890 12345 67890 12345 " & _
            "67890 12345 67890 12345 67890 12345!"

        If (ChkSelectedPath.Value = vbChecked) And (Len(TxtSelectedPath.Text) > 0) Then
            .SelectedPath = TxtSelectedPath.Text
        End If

        If .ShowDialog = DialogResult_OK Then
            TxtSelectedPath.Text = .SelectedPath
        End If

    End With

End Sub

' ---------- Ende Formular "Form1" alias Form1.frm  ----------

' ----- Anfang Modul "ModCallBack" alias ModCallBack.bas -----

Option Explicit

Public Function FolderBrowserDialogCallBack(ByVal hwnd As Long, ByVal msg As Long, ByVal _
    lParam As Long, ByVal lpData As Object) As Long

    If Not lpData Is Nothing Then
        If TypeOf lpData Is ICallBack Then

            Call CCallBack(lpData).CallBack(hwnd, msg, lParam)

        End If
    End If

End Function

Public Function CCallBack(ByVal obj As Object) As ICallBack

    Set CCallBack = obj

End Function

' ------ Ende Modul "ModCallBack" alias ModCallBack.bas ------

' --- Anfang Klasse "FolderBrowserDialog" alias FolderBrowserDialog.cls  ---

' Public NotInheritable Class FolderBrowserDialog
'          Inherits System.Windows.Forms.CommonDialog
'     Member von: System.Windows.Forms
'
' Zusammenfassung:
' Stellt ein Standarddialogfeld dar, in dem Benutzer einen Ordner auswählen können.
Option Explicit

Implements ICallBack

' Private Const CSIDL_DESKTOP                 As Long = &H0
' Private Const CSIDL_INTERNET                As Long = &H1
' Private Const CSIDL_PROGRAMS                As Long = &H2
' Private Const CSIDL_CONTROLS                As Long = &H3
' Private Const CSIDL_PRINTERS                As Long = &H4
' Private Const CSIDL_PERSONAL                As Long = &H5
' Private Const CSIDL_FAVORITES               As Long = &H6
' Private Const CSIDL_STARTUP                 As Long = &H7
' Private Const CSIDL_RECENT                  As Long = &H8
' Private Const CSIDL_SENDTO                  As Long = &H9
' Private Const CSIDL_BITBUCKET               As Long = &HA
' Private Const CSIDL_STARTMENU               As Long = &HB
' '&HC, &HD, &HE, &HF ??
'
' Private Const CSIDL_DESKTOPDIRECTORY        As Long = &H10
' Private Const CSIDL_DRIVES                  As Long = &H11
' Private Const CSIDL_NETWORK                 As Long = &H12
' Private Const CSIDL_NETHOOD                 As Long = &H13
' Private Const CSIDL_FONTS                   As Long = &H14
' Private Const CSIDL_TEMPLATES               As Long = &H15
' Private Const CSIDL_COMMON_STARTMENU        As Long = &H16
' Private Const CSIDL_COMMON_PROGRAMS         As Long = &H17
' Private Const CSIDL_COMMON_STARTUP          As Long = &H18
' Private Const CSIDL_COMMON_DESKTOPDIRECTORY As Long = &H19
' Private Const CSIDL_APPDATA                 As Long = &H1A
' Private Const CSIDL_PRINTHOOD               As Long = &H1B
' Private Const CSIDL_LOCAL_APPDATA           As Long = &H1C
' Private Const CSIDL_ALTSTARTUP              As Long = &H1D
' Private Const CSIDL_COMMON_ALTSTARTUP       As Long = &H1E
' Private Const CSIDL_COMMON_FAVORITES        As Long = &H1F
'
' Private Const CSIDL_INTERNET_CACHE          As Long = &H20
' Private Const CSIDL_COOKIES                 As Long = &H21
' Private Const CSIDL_HISTORY                 As Long = &H22
' Private Const CSIDL_COMMON_APPDATA          As Long = &H23
' Private Const CSIDL_WINDOWS                 As Long = &H24
' Private Const CSIDL_SYSTEM                  As Long = &H25
' Private Const CSIDL_PROGRAM_FILES           As Long = &H26
' Private Const CSIDL_MYPICTURES              As Long = &H27
' Private Const CSIDL_PROFILE                 As Long = &H28
' Private Const CSIDL_SYSTEMX86               As Long = &H29
' Private Const CSIDL_PROGRAM_FILESX86        As Long = &H2A
' Private Const CSIDL_PROGRAM_FILES_COMMON    As Long = &H2B
' Private Const CSIDL_PROGRAM_FILES_COMMONX86 As Long = &H2C
' Private Const CSIDL_COMMON_TEMPLATES        As Long = &H2D
' Private Const CSIDL_COMMON_DOCUMENTS        As Long = &H2E
' Private Const CSIDL_COMMON_ADMINTOOLS       As Long = &H2F
'
' Private Const CSIDL_ADMINTOOLS              As Long = &H30
' Private Const CSIDL_CONNECTIONS             As Long = &H31
' Private Const CSIDL_FLAG_DONT_VERIFY        As Long = &H4000
'
' Private Const CSIDL_FLAG_CREATE As Long = &H8000
' Private Const CSIDL_FLAG_MASK As Long = &HFF00&
' Private Const CSIDL_FLAG_PFTI_TRACKTARGET As Long = CSIDL_FLAG_DONT_VERIFY
'
' im .NET-FX gibt es auch ein Enum Environment.SpecialFolder
Public Enum Environment_SpecialFolder
    SpecialFolder_Desktop = &H0    ' = CSIDL_DESKTOP
    CSIDL_INTERNET = &H1
    SpecialFolder_Programs = &H2   ' = CSIDL_PROGRAMS 'Programmgruppen im Startverzeichnis
    CSIDL_CONTROLS = &H3
    CSIDL_PRINTERS = &H4
    SpecialFolder_Personal = &H5   ' = CSIDL_PERSONAL
    SpecialFolder_Favorites = &H6  ' = CSIDL_FAVORITES
    SpecialFolder_Startup = &H7    ' = CSIDL_STARTUP
    SpecialFolder_Recent = &H8     ' = CSIDL_RECENT
    SpecialFolder_SendTo = &H9     ' = CSIDL_SENDTO
    CSIDL_BITBUCKET = &HA          ' Papierkorb
    SpecialFolder_StartMenu = &HB  ' = CSIDL_STARTMENU

    ' &HC ??
    SpecialFolder_MyMusic = &HD

    ' &HE, &HF ??
    SpecialFolder_DesktopDirectory = &H10
    SpecialFolder_MyComputer = &H11
    CSIDL_NETWORK = &H12
    CSIDL_NETHOOD = &H13
    CSIDL_FONTS = &H14
    SpecialFolder_Templates = &H15
    CSIDL_COMMON_STARTMENU = &H16
    CSIDL_COMMON_PROGRAMS = &H17
    CSIDL_COMMON_STARTUP = &H18
    CSIDL_COMMON_DESKTOPDIRECTORY = &H19
    SpecialFolder_ApplicationData = &H1A
    CSIDL_PRINTHOOD = &H1B
    SpecialFolder_LocalApplicationData = &H1C
    CSIDL_ALTSTARTUP = &H1D
    CSIDL_COMMON_ALTSTARTUP = &H1E
    CSIDL_COMMON_FAVORITES = &H1F
    SpecialFolder_InternetCache = &H20
    SpecialFolder_Cookies = &H21
    SpecialFolder_History = &H22
    SpecialFolder_CommonApplicationData = &H23
    CSIDL_WINDOWS = &H24
    SpecialFolder_System = &H25
    SpecialFolder_ProgramFiles = &H26 ' Programmdateien
    SpecialFolder_MyPictures = &H27
    CSIDL_PROFILE = &H28
    CSIDL_SYSTEMX86 = &H29
    CSIDL_PROGRAM_FILESX86 = &H2A
    SpecialFolder_CommonProgramFiles = &H2B
    CSIDL_PROGRAM_FILES_COMMONX86 = &H2C
    CSIDL_COMMON_TEMPLATES = &H2D
    CSIDL_COMMON_DOCUMENTS = &H2E
    CSIDL_COMMON_ADMINTOOLS = &H2F
    CSIDL_ADMINTOOLS = &H30
    CSIDL_CONNECTIONS = &H31
    CSIDL_FLAG_DONT_VERIFY = &H4000
    CSIDL_FLAG_CREATE = &H8000
    CSIDL_FLAG_MASK = &HFF00&
    CSIDL_FLAG_PFTI_TRACKTARGET = CSIDL_FLAG_DONT_VERIFY
End Enum

Public Enum DialogResult
    DialogResult_None = 0
    DialogResult_OK = VbMsgBoxResult.vbOK
    DialogResult_Cancel = VbMsgBoxResult.vbCancel
    DialogResult_Abort = VbMsgBoxResult.vbAbort
    DialogResult_Retry = VbMsgBoxResult.vbRetry
    DialogResult_Ignore = VbMsgBoxResult.vbIgnore
    DialogResult_Yes = VbMsgBoxResult.vbYes
    DialogResult_No = VbMsgBoxResult.vbNo
End Enum

Private Type BrowseInfo
    hwndOwner      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

Private mFlags        As Long
Private mDescription  As String
Private mRootFolder   As Long
Private mSelectedPath As String
Private mTag          As Variant

Private Const WM_USER              As Long = &H400

Public Enum BrowseInfoFlags ' ulFlags:
    BIF_RETURNONLYFSDIRS = &H1        ' : Gestattet nur Dateisystemordner als Auswahl.
    BIF_DONTGOBELOWDOMAIN = &H2       ' : Der Dialog zeigt keine Netzwerkordner unterhalb
                                      ' der aktuellen Domain.
    BIF_STATUSTEXT = &H4              ' : Der Dialog enthält eine Statuszeile. Die
                                      ' Rückruffunktion kann die Statuszeile ausfüllen.
    BIF_RETURNFSANCESTORS = &H8       ' : Gestattet nur Dateisystemobjekte als Auswahl
    BIF_EDITBOX = &H10
    BIF_VALIDATE = &H20
    BIF_NEWDIALOGSTYLE = &H40
    BIF_USENEWUI = &H40
    BIF_BROWSEINCLUDEURLS = &H80
    BIF_DONTSHOWNEWFOLDERBUTTON = &H200  ' 512
    BFFM_SETSTATUSTEXTA = (WM_USER + 100)
    BFFM_ENABLEOK = (WM_USER + 101)      ' 1125
    BFFM_SETSELECTIONA = (WM_USER + 102) ' 1126
    BFFM_SETSELECTIONW = (WM_USER + 103)
    BFFM_SETSTATUSTEXTW = (WM_USER + 104)
    BIF_BROWSEFORCOMPUTER = &H1000       ' : Als Auswahl sind nur Computer erlaubt. Wenn der
                                         ' Anwender andere Objekte, also Ordner oder
                                         ' Laufwerke markiert, kann der OK-Button nicht
                                         ' ausgewählt werden.
    BIF_BROWSEFORPRINTER = &H2000        ' : Gestattet nur Drucker als Auswahl.
    BIF_BROWSEINCLUDEFILES = &H4000      ' : Der Dialog zeigt neben Computern, Laufwerken
                                         ' und Ordnern auch Dateien an.
    BIF_SHAREABLE = &H8000
End Enum

Private Const BFFM_INITIALIZED     As Long = 1
Private Const BFFM_SELCHANGED      As Long = 2

' Private Const BFFM_VALIDATEFAILEDA As Long = 3
' Private Const BFFM_VALIDATEFAILEDW As Long = 4
'
' HRESULT
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" ( _
                         ByVal hwnd As Long, _
                         ByVal csidl As Long, _
                         ByRef ppidl As Long) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" ( _
                         pBrowseInfo As BrowseInfo) As Long

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" ( _
                         ByVal pidList As Long, _
                         ByVal lpBuffer As String) As Long

Private Declare Function SendMessageA Lib "user32.dll" ( _
                         ByVal hwnd As Long, _
                         ByVal wMsg As Long, _
                         ByVal wParam As Long, _
                         lParam As Any) As Long

Private Declare Function GetActiveWindow Lib "user32" () As Long

Private Declare Function lstrlenA Lib "kernel32.dll" ( _
                         ByVal lpString As String) As Long

Private Declare Sub CoTaskMemFree Lib "ole32.dll" ( _
                    ByRef pv As Any)

Public Event HelpRequest(ByVal sender As FolderBrowserDialog)

Private Sub Class_Initialize()

    Call Reset

End Sub

Public Property Get Description() As String

    ' Ruft den beschreibenden Text ab, der im Dialogfeld über dem
    ' Strukturansichts-Steuerelement angezeigt wird, oder legt diesen fest.
    Description = mDescription

End Property

Public Property Let Description(StrVal As String)

    mDescription = StrVal

End Property

Public Property Get Flags() As BrowseInfoFlags

    Flags = mFlags

End Property

Public Property Let Flags(FVal As BrowseInfoFlags)

    mFlags = FVal

End Property

Public Sub Reset()

    mFlags = 0&

    ' mFlags = mFlags Or BIF_RETURNONLYFSDIRS
    ' mFlags = mFlags Or BIF_DONTGOBELOWDOMAIN
    ' mFlags = mFlags Or BIF_STATUSTEXT
    ' mFlags = mFlags Or BIF_RETURNFSANCESTORS

    ' mFlags = mFlags Or BIF_EDITBOX
    ' mFlags = mFlags Or BIF_VALIDATE
    mFlags = mFlags Or BIF_NEWDIALOGSTYLE
    mFlags = mFlags Or BIF_USENEWUI

    ' mFlags = mFlags Or BIF_BROWSEINCLUDEURLS

    ' om 2007_02_06 neue Const
    ' mFlags = mFlags Or BIF_DONTSHOWNEWFOLDERBUTTON

    ' mFlags = mFlags Or BIF_BROWSEFORCOMPUTER
    ' mFlags = mFlags Or BIF_BROWSEFORPRINTER
    ' mFlags = mFlags Or BIF_BROWSEINCLUDEFILES
    ' mFlags = mFlags Or BIF_SHAREABLE
End Sub

Public Property Let RootFolder(LngVal As Environment_SpecialFolder)

    mRootFolder = LngVal

End Property

Public Property Get RootFolder() As Environment_SpecialFolder

    ' Ruft den Stammordner ab, von dem aus eine Suche gestartet wird, oder legt diesen fest.
    RootFolder = mRootFolder

End Property

Public Property Let SelectedPath(StrVal As String)

    mSelectedPath = StrVal

End Property

Public Property Get SelectedPath() As String

    ' Ruft den von den Benutzern ausgewählten Pfad ab oder legt diesen fest.
    SelectedPath = mSelectedPath

End Property

Public Property Let ShowNewFolderButton(BolVal As Boolean)

    mFlags = mFlags Or BIF_DONTSHOWNEWFOLDERBUTTON

    If BolVal Then
        mFlags = mFlags Xor BIF_DONTSHOWNEWFOLDERBUTTON
    End If

End Property

Public Property Get ShowNewFolderButton() As Boolean

    ' Ruft den Wert ab, der angibt, ob die Schaltfläche New Folder im Dialogfeld für die
    ' Ordnersuche angezeigt wird.
    ShowNewFolderButton = Not (mFlags And BIF_DONTSHOWNEWFOLDERBUTTON)

End Property

' wie schon hinlänglich bekann, füg einfach irgendwas hinzu
' wird intern nicht verwendet, kann extern verwendet werden
' Public Property Get Tag() As Object
Public Property Get Tag() As Variant

    Tag = mTag

End Property

Public Property Let Tag(VarVal As Variant)

    mTag = VarVal

End Property

Public Function ToString() As String

    ToString = "Windows.Forms.FolderBrowserDialog"

End Function

Public Function ShowDialog(Optional Frm As Variant) As DialogResult

    Dim BI         As BrowseInfo
    Dim hhwndOwner As Long
    Dim IDList     As Long
    Dim Buffer     As String
    Dim pRoot      As Long

    If IsMissing(Frm) Then
        hhwndOwner = GetActiveWindow
    Else
        hhwndOwner = Frm.hwnd
    End If

TryE:
    On Error GoTo CatchE

    Call SHGetSpecialFolderLocation(hhwndOwner, mRootFolder, pRoot)

    If (pRoot = 0&) Then

        Call SHGetSpecialFolderLocation(hhwndOwner, 0, pRoot)

        If (pRoot = 0&) Then

            ' Throw New InvalidOperationException(SR.GetString("FolderBrowserDialogNoRootFolder"))
            MsgBox "FolderBrowserDialogNoRootFolder"

            Exit Function

        End If
    End If

    With BI
        .hwndOwner = hhwndOwner
        .pidlRoot = pRoot

        ' .pszDisplayName = ""
        ' Beschreibung im Dialog 'als nullterminierter String
        .lpszTitle = mDescription ' & vbNullChar
        .ulFlags = mFlags
        .lpfn = FncPtr(AddressOf ModCallBack.FolderBrowserDialogCallBack)
        .lParam = ObjPtr(Me)
        .iImage = 0&
    End With

    ' Anzeigen des Dialogs und Übergabe an eine IID-Liste
    IDList = SHBrowseForFolder(BI)

    If IDList <> 0 Then
        Buffer = String$(1024, vbNullChar)

        Call SHGetPathFromIDList(IDList, Buffer)

        mSelectedPath = Left$(Buffer, lstrlenA(Buffer))
        ShowDialog = DialogResult_OK

        ' Free the IDList Memory !
        Call CoTaskMemFree(IDList)

    Else
        ShowDialog = DialogResult_Cancel
    End If

    Exit Function

CatchE:

    If Err.Number > 0 Then MsgBox Err.Description
    ShowDialog = DialogResult_Abort

End Function

Private Function FncPtr(p As Long) As Long

    FncPtr = p

End Function

' Callbackfunction ->>>
Private Sub ICallBack_CallBack(ByVal hhwnd As Long, ByVal msg As Long, ByVal lParam As Long)

    Dim rv     As Long
    Dim lflag  As Long
    Dim Buffer As String

    Select Case msg

    Case BFFM_INITIALIZED

        If (Len(mSelectedPath) > 0) Then
            rv = SendMessageA(hhwnd, BFFM_SETSELECTIONA, 1&, ByVal mSelectedPath)
        End If

    Case BFFM_SELCHANGED

        If (lParam <> 0&) Then
            Buffer = String$(1024, vbNullChar)
            lflag = SHGetPathFromIDList(lParam, Buffer)

            If lflag = 1 Then

                Call SendMessageA(hhwnd, BFFM_ENABLEOK, 0, ByVal 1)

            ElseIf lflag = 0 Then

                Call SendMessageA(hhwnd, BFFM_ENABLEOK, 0, ByVal 0)

            End If

            Call CoTaskMemFree(lParam)

        End If

    End Select

End Sub

' --- Ende Klasse "FolderBrowserDialog" alias FolderBrowserDialog.cls  ---

' ------ Anfang Klasse "ICallBack" alias ICallBack.cls  ------

Option Explicit

Public Sub CallBack(ByVal hhwnd As Long, ByVal msg As Long, ByVal lParam As Long)

End Sub

' ------- Ende Klasse "ICallBack" alias ICallBack.cls  -------

' -------------- Ende Projektdatei Projekt1.vbp --------------

Diskussion  

Diese Funktion ermöglicht es, Fragen, die die Veröffentlichung des Tipps betreffen, zu klären, oder Anregungen und Verbesserungsvorschläge einzubringen. Nach der Veröffentlichung des Tipps werden diese Beiträge nicht weiter verlinkt. Allgemeine Fragen zum Inhalt sollten daher hier nicht geklärt werden.
Folgende Diskussionen existieren bereits

Update - 23.02.2008 18:00

Um eine Diskussion eröffnen zu können, müssen sie angemeldet sein.