Pfadauswahl mit Baum und Default Pfad

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(Optional Msg As String) As String Dim bInfo As BROWSEINFO Dim Path As String Dim r As Long, x As Long, pos As Integer bInfo.pidlRoot = 0& If IsMissing(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)) GetDirectory = Left(Path, pos - 1) Else GetDirectory = "" End If End Function

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub get_Folder(Optional capt, Optional initF) Dim objShell As Object, objFolder As Object, objItem As Object Set objShell = CreateObject("Shell.Application") With objShell Set objFolder = .BrowseForFolder(0&, capt, 0, initF) End With If Not objFolder Is Nothing Then Set objItem = objFolder.Self MsgBox objItem.Path End If End Sub

Hallo, Option Explicit Sub get_Folder(Optional capt, Optional initF) Dim objShell As Object, objFolder As Object, objItem As Object Set objShell = CreateObject("Shell.Application") With objShell Set objFolder = .BrowseForFolder(0&, capt, 0, initF) End With If Not objFolder Is Nothing Then Set objItem = objFolder.Self MsgBox objItem.Path End If End Sub Sub Aufruf() Call get_Folder("Was soll ich machen?", "C:\Eigene Dateien") End Sub Gruß K.Rola

Hi,
stellt euch doch nicht so an. Klar geht das:

Option Explicit
Private Declare Function SHBrowseForFolder Lib "shell32" ( _
    lpbi As InfoT) As Long
Private Declare Function CoTaskMemFree Lib "ole32" ( _
    ByVal hMem As Long) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _
    ByVal lpStr1 As String, _
    ByVal lpStr2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" ( _
    ByVal pList As Long, _
    ByVal lpBuffer As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassname As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hWnd As Long, _
    ByVal Msg As Long, _
    wParam As Any, _
    lParam As Any) As Long

Private Type InfoT
    hWnd As Long
    Root As Long
    DisplayName As Long
    Title As Long
    Flags As Long
    FName As Long
    lParam As Long
    Image As Long
End Type
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_RETURNONLYFSDIRSCREATENEW As Long = &H40
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = &H1
Private s_BrowseInitDir As String
Private Function fncGetFolder( _
    Optional ByVal sMsg As String = "Bitte wählen Sie ein Verzeichnis", _
    Optional ByVal lFlag As Long = BIF_RETURNONLYFSDIRS, _
    Optional ByVal sPath As String = "C:\") As String
    Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
    s_BrowseInitDir = sPath
    With xl
        .hWnd = FindWindow("XLMAIN", vbNullString)
        .Root = 0
        .Title = lstrcat(sMsg, "")
        .Flags = lFlag
        .FName = FuncCallback(AddressOf BrowseCallback)
    End With
    IDList = SHBrowseForFolder(xl)
    If IDList <> 0 Then
        FolderName = Space(256)
        RVal = SHGetPathFromIDList(IDList, FolderName)
        CoTaskMemFree (IDList)
        FolderName = Trim$(FolderName)
        FolderName = Left$(FolderName, Len(FolderName) - 1)
    End If
    fncGetFolder = FolderName
End Function
Private Function BrowseCallback( _
    ByVal hWnd As Long, _
    ByVal uMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long
    If uMsg = BFFM_INITIALIZED Then _
        Call SendMessage(hWnd, BFFM_SETSELECTION, ByVal 1&, ByVal s_BrowseInitDir)
    BrowseCallback = 0
End Function
Private Function FuncCallback(ByVal nParam As Long) As Long
    FuncCallback = nParam
End Function
Public Sub test()
    Dim sFolder As String
    sFolder = Trim$(fncGetFolder(, , "C:\Temp"))
    If sFolder <> "" Then MsgBox sFolder
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Pfadauswahl mit Baum und Default Pfad

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread