vB调用系统打开文件夹对话框？

Question

Private Type BrowseInfo
    lngHwnd        As Long
    pIDLRoot       As Long
    pszDisplayName As Long
    lpszTitle      As Long
    ulFlags        As Long
    lpfnCallback   As Long
    lParam         As Long
    iImage         As Long
End TypePrivate Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260Private Declare Sub CoTaskMemFree Lib "ole32.dll" _
    (ByVal hMem As Long)Private Declare Function lstrcat Lib "Kernel32" _
   Alias "lstrcatA" (ByVal lpString1 As String, _
   ByVal lpString2 As String) As Long
   
Private Declare Function SHBrowseForFolder Lib "shell32" _
   (lpbi As BrowseInfo) As Long
   
Private Declare Function SHGetPathFromIDList Lib "shell32" _
   (ByVal pidList As Long, ByVal lpBuffer As String) As LongPrivate Function BrowseForFolder(ByVal lngHwnd As Long, ByVal strPrompt As String) As String    On Error GoTo ehBrowseForFolder 'Trap for errors    Dim intNull As Integer
    Dim lngIDList As Long, lngResult As Long
    Dim strPath As String
    Dim udtBI As BrowseInfo    'Set API properties (housed in a UDT)
    With udtBI
        .lngHwnd = lngHwnd
        .lpszTitle = lstrcat(strPrompt, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With    'Display the browse folder...
    lngIDList = SHBrowseForFolder(udtBI)    If lngIDList <> 0 Then
        'Create string of nulls so it will fill in with the path
        strPath = String(MAX_PATH, 0)        'Retrieves the path selected, places in the null
         'character filled string
        lngResult = SHGetPathFromIDList(lngIDList, strPath)        'Frees memory
        Call CoTaskMemFree(lngIDList)        'Find the first instance of a null character,
         'so we can get just the path
        intNull = InStr(strPath, vbNullChar)
        'Greater than 0 means the path exists...
        If intNull > 0 Then
            'Set the value
            strPath = Left(strPath, intNull - 1)
        End If
    End If    'Return the path name
    BrowseForFolder = strPath
    Exit Function 'AbortehBrowseForFolder:    'Return no value
    BrowseForFolder = EmptyEnd FunctionPrivate Sub Command1_Click()
aa = BrowseForFolder(Me.hWnd, "")
MsgBox aa
End Sub

Answer 1

这是我写的：
'写在窗体中
Private Sub Cmd1_Click()
    Dim TempStr As string
    
    If ShowDir(me.hWnd, TempStr, 提示文字) Then
        '成功！路径在TempStr
    Else
        '不成功
    End If
    
End Sub'写在模块中
Public Declare Function SHBrowseForFolder _
        Lib "shell32.dll" Alias "SHBrowseForFolderA" _
        (lpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList _
        Lib "shell32.dll" _
        (ByVal pidl As Long, _
        pszPath As String) As Long
Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlage As Long
    lpfn As Long
    lparam As Long
    iImage As Long
End TypePublic Function ShowDir(MehWnd As Long, _
        DirPath As String, _
        Optional Title As String = "请选择文件夹：", _
        Optional flage As Long = &H1, _
        Optional DirID As Long) As Long
    Dim BI As BROWSEINFO
    Dim TempID As Long
    Dim TempStr As String
    
    TempStr = String$(255, Chr$(0))
    With BI
        .hOwner = MehWnd
        .pidlRoot = 0
        .lpszTitle = Title + Chr$(0)
        .ulFlage = flage
        
    End With
    
    TempID = SHBrowseForFolder(BI)
    DirID = TempID
    
    If SHGetPathFromIDList(ByVal TempID, ByVal TempStr) Then
        DirPath = Left$(TempStr, InStr(TempStr, Chr$(0)) - 1)
        ShowDir = -1
        
    Else
        ShowDir = 0
        
    End If
    
End Function

Answer 2

顺便说一句（回答20分的问题的习惯）：
If 你不知道怎样给分 Then 去看：http://www.csdn.net/expert/faq.shtm

Answer 3

http://ygyuan.go.163.com/
http://ygyuan.3322.net/有源程序,可以预认默认目录.