'AutoCAD VBA
选择文件夹的代码
'
流沙之泉编写于
2018
年
11
月
30
日，于
AutoCAD2017 64
位上测试通过。
'
将此份文档另存为纯文本格式文件
MdFileBrw.bas
，
'
并导入至
vba
的模块中即可在其他模块调用当中的函数。
'
其中
GetFolder
函数可以选择文件夹并返回选择的路径(按取消则返回空字符串)
，
'ListFilesFSO
过程可以根据传入的文件夹路径在调试输出窗口输出文件名，
不含子文件夹。
Attribute VB_Name = "MdFileBrw"
Option Explicit
'*************
系统类型与函数声明开始
***************
Public Type BROWSEINFO
hOwner As LongPtr
pidlRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As LongPtr
lpfn As LongPtr
lParam As LongPtr
iImage As LongPtr
End Type
Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000
Public Const BIF_NEWDIALOGSTYLE = &H40
Declare
PtrSafe
Function
SHGetPathFromIDList
Lib
"shell32.dll"
Alias
"SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr
Declare
PtrSafe
Function
SHBrowseForFolder
Lib
"shell32.dll"
Alias
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr
'*************
系统类型与函数声明结束
***************
'
此函数返回确保后面带反斜杠的文件路径
Public Function EnsurePath(ByVal sPath As String) As String
If Right(sPath, 1) <> "\" Then
EnsurePath = sPath & "\"
Else
EnsurePath = sPath
End If
End Function
| 
转播
