vb 调用系统API生成一个目录选择对话框,如何控制对话框的位置

Question

Private Const BIF_STATUSTEXT = &H4&
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260
Private Const DESKTOP = &H0&
Private Const MAX_LEN = 2000Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)
Private Declare Function SHBrowseForFolder Lib "Shell32" (lpbi As BrowseInfo) 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 String) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "KERNEL32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Declare Function SHGetSpecialFolderLocation Lib "Shell32" (ByVal hwndOwner As Long, ByVal nFolder As Integer, ppidl As Long) As LongPrivate Type BrowseInfo
    hwndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type
Private m_CurrentDirectory As String
Public Function BrowseForFolder(hWnd As Long, Title As String, StartDir As String) As String
    Dim lpIDList As Long
    Dim szTitle As String
    Dim sBuffer As String
    Dim tBrowseInfo As BrowseInfo
    Dim pidl As Long
    Dim s As String * MAX_LEN
    
    m_CurrentDirectory = StartDir & vbNullChar
        'SHGetSpecialFolderLocation 0, DESKTOP, pidl
        'SHGetPathFromIDList pidl, s
        'm_CurrentDirectory = Left(s, InStr(s, Chr(0)) - 1)
        szTitle = Title
    With tBrowseInfo
        .hwndOwner = hWnd
        .lpszTitle = lstrcat(szTitle, "")
        .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
        .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)
    End With
    lpIDList = SHBrowseForFolder(tBrowseInfo)
    If (lpIDList) Then
        sBuffer = Space(MAX_PATH)
        SHGetPathFromIDList lpIDList, sBuffer
        sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
        BrowseForFolder = sBuffer
    Else
        BrowseForFolder = ""
    End IfEnd FunctionPrivate Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
    Dim lpIDList As Long
    Dim ret As Long
    Dim sBuffer As String    On Error Resume Next    Select Case uMsg
    
        Case BFFM_INITIALIZED
            Call SendMessage(hWnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)
    
        Case BFFM_SELCHANGED
            sBuffer = Space(MAX_PATH)
            ret = SHGetPathFromIDList(lp, sBuffer)
            If ret = 1 Then Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
    End Select    BrowseCallbackProc = 0End Function
Private Function GetAddressofFunction(add As Long) As Long
    GetAddressofFunction = add
End Function

Answer 1

Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBROWSEINFOTYPE As BROWSEINFOTYPE) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As LongPrivate Const WM_USER = &H400Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Private Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Private Const LPTR = (&H0 Or &H40)Private Type BROWSEINFOTYPE
    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 TypePrivate Function BrowseCallbackProcStr(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
    If uMsg = 1 Then
        Call SendMessage(hWnd, BFFM_SETSELECTIONA, True, ByVal lpData)
    End If
End FunctionPrivate Function FunctionPointer(FunctionAddress As Long) As Long
    FunctionPointer = FunctionAddress
End FunctionPublic Function BrowseDirectory(hWnd As Long, strTitle As String, strInitPath As String) As String
    '******************************************************************
    ' 名    称: 目录选择浏览函数
    ' 作    用: 打开一个目录选择浏览窗口
    ' 参 数 表: hWnd            As Long     父窗口的句柄
    '           strTitle        As String   所给的提示
    '           strInitPath     As String   初始文件夹
    ' 返 回 值: BrowseDirectory As String   所选择的目录路径
    '******************************************************************
    Dim Browse_for_folder As BROWSEINFOTYPE
    Dim itemID As Long
    Dim strInitPathPointer As Long
    Dim tmpPath As String * 256
    
    If strInitPath = "" Then
      strInitPath = "C:\"
    End If
    If Not Right$(strInitPath, 1) <> "\" Then
        strInitPath = Left$(strInitPath, Len(strInitPath) - 1) ' 如果用户加了 "\" 则删除
    End If
    'LenB(StrConv(CapText, vbFromUnicode))
    With Browse_for_folder
        .hOwner = hWnd ' 所有都窗口之句柄
        .lpszTitle = strTitle ' 对话框的标题
        .lpfn = FunctionPointer(AddressOf BrowseCallbackProcStr) '用于设置预设文件夹的回调函数
        strInitPathPointer = LocalAlloc(LPTR, LenB(StrConv(strInitPath, vbFromUnicode)) + 1) ' 分配一个字符串内存
        CopyMemory ByVal strInitPathPointer, ByVal strInitPath, LenB(StrConv(strInitPath, vbFromUnicode)) + 1 ' 拷贝那个路径到内存
        .lParam = strInitPathPointer                      ' 预设的文件夹
    End With
    itemID = SHBrowseForFolder(Browse_for_folder)         ' 执行API函数： BrowseForFolder
    If itemID Then
        If SHGetPathFromIDList(itemID, tmpPath) Then      '取得选定的文件夹
            BrowseDirectory = Left$(tmpPath, InStr(tmpPath, vbNullChar) - 1) '去掉多余的 null 字符
        End If
        Call CoTaskMemFree(itemID)     '释放内存
    End If
    Call LocalFree(strInitPathPointer) '释放内存
End Function