Option Compare Database
Option Explicit
 
Private 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
 
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
            "SHGetPathFromIDListA" (ByVal pidl As Long, _
            ByVal pszPath As String) As Long
 
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
            "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
            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 Const BIF_RETURNONLYFSDIRS = &H1
Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = 1
 
Global StartDir As String
 
Public Function VerzeichnisSuchen(szDialogTitle As String, _
                StartVerzeichnis As String) As String
 
  Dim X         As Long
  Dim bi        As BROWSEINFO
  Dim dwIList   As Long
  Dim szPath    As String
  Dim wPos      As Integer
 
  StartDir = StartVerzeichnis
 
  With bi
        .hOwner = hWndAccessApp
        .lpszTitle = szDialogTitle
        .ulFlags = BIF_RETURNONLYFSDIRS
        .lpfn = DummyFunc(AddrOf("BrowseCallbackProc"))
    End With
 
    dwIList = SHBrowseForFolder(bi)
    szPath = Space$(512)
    X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
 
    If X Then
        wPos = InStr(szPath, Chr(0))
        VerzeichnisSuchen = Left$(szPath, wPos - 1)
    Else
        VerzeichnisSuchen = ""
    End If
End Function
Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, _
                ByVal lParam As Long, ByVal lpData As Long) As Long
 
    Dim pathstring  As String
    Dim retval      As Long
 
    Select Case uMsg
        Case BFFM_INITIALIZED
            pathstring = StartDir '"C:\Temp"
            retval = SendMessage(hWnd, BFFM_SETSELECTION, _
                     ByVal CLng(1), ByVal pathstring)
    End Select
 
    BrowseCallbackProc = 0
 
End Function
Public Function DummyFunc(ByVal param As Long) As Long
 
    DummyFunc = param
 
End Function

Option Compare Database
Option Explicit
 
Private Declare Function GetCurrentVbaProject Lib "vba332.dll" Alias _
"EbGetExecutingProj" (hProject As Long) As Long
 
Private Declare Function GetFuncID Lib "vba332.dll" Alias "TipGetFunctionId" _
(ByVal hProject As Long, ByVal strFunctionName As String, ByRef _
strFunctionId As String) As Long
 
Private Declare Function GetAddr Lib "vba332.dll" Alias _
"TipGetLpfnOfFunctionId" (ByVal hProject As Long, ByVal strFunctionId As _
String, ByRef lpfn As Long) As Long
 
Public Function AddrOf(strFuncName As String) As Long
Dim hProject As Long
Dim lngResult As Long
Dim strID As String
Dim lpfn As Long
Dim strFuncNameUnicode As String
 
Const NO_ERROR = 0
 
' The function name must be in Unicode, so convert it.
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
 
' Get the current VBA project
' The results of GetCurrentVBAProject seemed inconsistent, in our tests,
' so now we just check the project handle when the function returns.
Call GetCurrentVbaProject(hProject)
 
' Make sure we got a project handle... we always should, but you never know!
If hProject <> 0 Then
    ' Get the VBA function ID (whatever that is!)
    lngResult = GetFuncID(hProject, strFuncNameUnicode, strID)
 
    ' We have to check this because we GPF if we try to get a function pointer
    ' of a non-existent function.
    If lngResult = NO_ERROR Then
        ' Get the function pointer.
        lngResult = GetAddr(hProject, strID, lpfn)
 
        If lngResult = NO_ERROR Then
            AddrOf = lpfn
        End If
    End If
End If
 
End Function
 

Private Sub Verzeichnisauswahl_Click()
 
    Dim strVerzeichnisName As String
 
    If IsNull(Me!Verzeichnis) Then
        Me!Verzeichnis = ""
    End If
 
    strVerzeichnisName = VerzeichnisSuchen _
        ("Wählen Sie bitte das Verzeichnis aus!", Me!Verzeichnis)
 
    If ((Not IsNull(strVerzeichnisName)) And (strVerzeichnisName <> "")) Then
        Me!Verzeichnis = strVerzeichnisName
    End If
 
End Sub