这种选择文件夹窗口该如何实现??

myfreemind

和CAD支持文件搜索路径窗口是一样的!

mccad

http://www.mjtd.com/function/list.asp?id=368&ordertype=byletter

myfreemind

谢谢!

xzd716

http://www.mjtd.com/function/lis ... ;ordertype=byletter 无效
请知道实现楼主贴图的老师请指点，谢谢

18277132841

xzd716 发表于 2025-4-2 22:59
http://www.mjtd.com/function/list.asp?id=368&ordertype=byletter 无效
请知道实现楼主贴图的老师请指点 ...

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" (lpbi As BROWSEINFO) As Long
    Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" (ByVal Pidl As LongPtr, ByVal pszPath As String) As Long

    Private Type BROWSEINFO
        hwndOwner As LongPtr
        pidlRoot As LongPtr
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As LongPtr
        lParam As LongPtr
        iImage As Long
    End Type
#Else
    Private Declare Function SHBrowseForFolder Lib "shell32.dll" (lpbi As BROWSEINFO) As Long
    Private Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal Pidl As Long, ByVal pszPath As String) As Long

    Private Type BROWSEINFO
        hwndOwner 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
#End If


'通过窗口选择文件夹
'返回字符串，如果错误或取消则返回""
Public Function SelectFolder(ByVal dePath As String) As String
    Dim Bi As BROWSEINFO
    Dim Pidl As Long
    Dim DisplayName As String
    Dim Path As String
    Path = VBA.Space(260)
    DisplayName = VBA.Space(260)
    Bi.hwndOwner = 0  ' 可以设置为特定的窗口句柄，0为当前AutoCAD窗口
    Bi.pidlRoot = 0   ' 从桌面开始浏览
    Bi.pszDisplayName = DisplayName
    Bi.lpszTitle = dePath
    Bi.ulFlags = &H8007 ' BIF_RETURNONLYFSDIRS | BIF_NEWDIALOGSTYLE
    Bi.lpfn = 0
    Bi.lParam = 0
    Pidl = SHBrowseForFolder(Bi)
    If Pidl <> 0 Then
        SHGetPathFromIDList Pidl, Path
        SelectFolder = VBA.Left(Path, InStrRev(Path, VBA.Chr(0)) - 1)
    Else
        SelectFolder = ""
    End If
End Function


'使用案例
Sub test1()
    On Error Resume Next
    Dim filepath As String
    filepath = SelectFolder("选择文件夹")
    If filepath <> "" Then
        MsgBox "已选择：" & filepath
    Else
        MsgBox "未选择！"
    End If
End Sub

xzd716

非常感谢！