实现目录的浏览

[fjend]

VB 6.0 怎么实现,要带新建文件夹的!!

[vansoft]

Option Explicit

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 Type

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 Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
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 Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Const WM_USER = &H400
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Private Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Private Const LPTR = (&H0 Or &H40)

Public Enum BROWSETYPE
NONE = 0
PATHTEXT = 16
NEWFOLDER = 64
End Enum

Private Sub BrowseCallbackProcStr(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long)
If uMsg = 1 Then
Call SendMessage(hwnd, BFFM_SETSELECTIONA, True, ByVal lpData)
End If
End Sub

Private Function FunctionPointer(FunctionAddress As Long) As Long
FunctionPointer = FunctionAddress
End Function

Public Function BrowseForFolder(ByVal hwnd As Long, ByVal strTitle As String, Optional selectedPath As String, Optional ByVal Flag As BROWSETYPE = 0) As String
Dim Browse_for_folder As BROWSEINFOTYPE
Dim itemID As Long
Dim selectedPathPointer As Long
Dim tmpPath As String * 256

If selectedPath = "" Then selectedPath = "" '避免selectedPath未初始化而出错

If Not Right(selectedPath, 1) <> "\" Then
selectedPath = Left(selectedPath, Len(selectedPath) - 1) '如果用户加了 "\" 则删除
End If

With Browse_for_folder
.hOwner = hwnd '所有都窗口之句柄
.lpszTitle = strTitle '对话框的标题
.ulFlags = Flag
.lpfn = FunctionPointer(AddressOf BrowseCallbackProcStr) '用于设置预设文件夹的回调函数
selectedPathPointer = LocalAlloc(LPTR, Len(selectedPath) + 1) '分配一个字符串内存
Call CopyMemory(ByVal selectedPathPointer, ByVal selectedPath, Len(selectedPath) + 1) ' 拷贝那个路径到内存
.lParam = selectedPathPointer ' 预设的文件夹
End With
itemID = SHBrowseForFolder(Browse_for_folder) '执行API函数：BrowseForFolder
If itemID Then
If SHGetPathFromIDList(itemID, tmpPath) Then '取得选定的文件夹
BrowseForFolder = Left(tmpPath, InStr(tmpPath, vbNullChar) - 1) '去掉多余的 null 字符
End If
Call CoTaskMemFree(itemID) '释放内存
End If
Call LocalFree(selectedPathPointer) '释放内存
End Function

[舉杯邀明月]

楼主试一下这个如何：

Sub SelFolder()
    Dim SelFolder$, spShell, spFolder, spFolderItem
    On Error GoTo Err_Proc
    Set spShell = CreateObject("Shell.Application")
    Set spFolder = spShell.BrowseForFolder(0, "请选择文件夹！", 1, "")
    Set spFolderItem = spFolder.Self
    SelFolder = spFolderItem.Path
    Debug.Print SelFolder
    Exit Sub
Err_Proc:
    If Err > 0 Then Exit Sub
End Sub

[fjend]

谢谢两位