你是否在納悶,在VB公用對話框中怎么沒有目錄選擇對話框呢,事實上在API查看器中也未聲明這個API.本例用到的兩個API如下

SHBrowseForFolder

    用于瀏覽文件夾、打印機和網絡

SHGetPathFromIDList

    用于將項標識符列表轉換為文件系統路徑

有了這兩個API函數,你就可以構造一個目錄選擇對話框類以代替VB中的目錄控件.類clsGetPath的完整代碼如下:

Option Explicit
'API聲明部分
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
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 Const BIF_RETURNONLYFSDIRS = 0
Private Const BIF_DONTGOBELOWDOMAIN = 1
Private Const BIF_STATUSTEXT = 2
Private Const BIF_RETURNFSANCESTORS = 3
Private Const BIF_BROWSEFORCOMPUTER = 4
Private Const BIF_BROWSEFORPRINTER = 5

'變量聲明
Private mvarCaption As String
Private mvarhWnd As Long
Private mvarFlags As Integer
Private mvarFolder As Variant

'類的屬性
Public Property Let Folder(ByVal vData As Variant)
    mvarFolder = vData
End Property

Public Property Set Folder(ByVal vData As Variant)
    Set mvarFolder = vData
End Property

Public Property Get Folder() As Variant
    If IsObject(mvarFolder) Then
        Set Folder = mvarFolder
    Else
        Folder = mvarFolder
    End If
End Property

Public Property Let Flags(ByVal vData As Integer)
    mvarFlags = vData
End Property

Public Property Get Flags() As Integer
    Flags = mvarFlags
End Property

Public Property Let hwnd(ByVal vData As Long)
    mvarhWnd = vData
End Property

Public Property Get hwnd() As Long
    hwnd = mvarhWnd
End Property

Public Property Let Caption(ByVal vData As String)
    mvarCaption = vData
End Property

Public Property Get Caption() As String
    Caption = mvarCaption
End Property

'類的方法
Public Sub GetFolder()
    Dim bi As BROWSEINFO
    Dim pidl As Long
    Dim ret As String

    ret = String$(255, Chr$(0))

    With bi
        .hOwner = hwnd
        .ulFlags = Flags
        If Caption <> "" Then
            .lpszTitle = Caption & Chr$(0)
        Else
            .lpszTitle = "Select a Folder..." & Chr$(0)
        End If
    End With

    pidl = SHBrowseForFolder(bi)

    If SHGetPathFromIDList(ByVal pidl, ByVal ret) Then
        Folder = Left$(ret, InStr(ret, Chr$(0)) - 1)
    Else
        Folder = ""
    End If
End Sub

在程序中使用類的代碼:

Private Sub cmdBrowse_Click()
    Dim c As clsGetPath      '聲明對象變量
    Set c = New clsGetPath
    With c
        .Caption = "請選擇一個文件夾"
        .Flags = 0
        .hwnd = Me.hwnd
    End With
    c.GetFolder
    txtPath.Text = c.Folder
End Sub