Verzeichnis wechseln

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Christian,
folgenden Code in ein Modul:

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

Dann aus Deinem Makro heraus die Sub "test" aufrufen. In dieser Sub kannst Du auch Ordner voreinstellen (hier C:\Temp).
Mit der Variablen sFolder kannst Du dann in Deinem Makro weiterarbeiten.
Gruß aus Leipzig
P@ulchen

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread