У меня есть пользовательская программа VBA, которая просматривает кучу файлов AutoCAD и извлекает из них данные.На данный момент я использую отдельный файл Excel для выбора нескольких файлов .dwg через Excel FileDialog, и я хотел бы, чтобы вместо этого выбор файла был сделан в AutoCAD.
Я нашел функцию APIна справочном форуме AutoCAD, но не могу заставить его работать.Он называется «FileDialogs».
Первый блок кода - это мой основной модуль, второй блок - модуль класса FileDialogs, который мне дали.
Я прошел модуль класса FileDialogs, которыйссылается на Windows API и добавил «PtrSafe» к функциям и изменил все «Long» на «LongPtr».
-EDIT- Я обновил код до своего полуработающего кода.Он запускает окно файла, но не возвращает список выбранных чертежей, поэтому idk.Хорошо, нуфф?
'THIS IS MY PRIMARY MODULE
Public Sub OpenFile()
Set objFile = New FileDialogs
Dim initpath As String
Dim initfilter As String
Dim inittitle As String
initpath = ThisDrawing.Path & "\"
'initfilter = "Drawing Files (*.dwg)|*.dwg"
inittitle = "Select Files"
'objFile.OwnerHwnd = ThisDrawing.Hwnd
'objFile.title = "Select Drawings"
objFile.MultiSelect = True
'objFile.Filter = initfilter
'objFile.StartInDir = initpath
strFileName = objFile.ShowOpen(initpath, initfilter, inittitle)
If Not strFileName = vbNullString Then
MsgBox strFileName
End If
Set objFile = Nothing
End Sub
'THIS IS THE CLASS MODULE I WAS GIVEN ON THE AUTOCAD FORUM
Option Explicit
'//The Win32 API Functions///
Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (OFN As OPENFILENAME) As Boolean
Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (OFN As OPENFILENAME) As Boolean
Private Declare PtrSafe Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
'//A few of the available Flags///
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_ALLOWMULTISELECT = &H200
'This one keeps your dialog from turning into
'A browse by folder dialog if multiselect is true!
'Not sure what I mean? Remove it from the flags
'In the "ShowOpen Open" & "ShowOpen Save" methods.
Private Const OFN_EXPLORER As Long = &H80000
'//The Structure
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As LongPtr
hInstance As LongPtr
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As LongPtr
lpTemplateName As String
End Type
Private lngHwnd As LongPtr
Public strFilter As String
Public strTitle As String
Public strDir As String
Private blnHideReadOnly As Boolean
Private blnAllowMulti As Boolean
Private blnMustExist As Boolean
Private Sub Class_Initialize()
'Set default values when
'class is first created
strDir = Application.ActiveDocument.Path & "\"
strTitle = "Select Files"
'strFilter = "Drawing Files" & Chr$(0) & "*.dwg" & Chr$(0)
lngHwnd = FindWindow(vbNullString, Application.Caption)
'None of the flags are set here!
End Sub
Public Function FindUserForm(objForm As UserForm) As LongPtr
Dim lngTemp As LongPtr
Dim strCaption As String
strCaption = objForm.Caption
lngTemp = FindWindow(vbNullString, strCaption)
If lngTemp <> 0 Then
FindUserForm = lngTemp
End If
End Function
Public Property Let OwnerHwnd(ByVal WindowHandle As LongPtr)
'//FOR YOU TODO//
'Use the API to validate this handle
lngHwnd = WindowHandle
'This value is set at startup to the handle of the
'AutoCAD Application window, if you want the owner
'to be a user form you will need to obtain its
'Handle by using the "FindUserForm" function in
'This class.
End Property
Public Property Get OwnerHwnd() As LongPtr
OwnerHwnd = lngHwnd
End Property
Public Property Let title(ByVal Caption As String)
'strTitle = "Select Files"
End Property
Public Property Get title() As String
'title = strTitle
End Property
Public Property Let Filter(ByVal FilterString As String)
'Filters change the type of files that are
'displayed in the dialog. I have designed this
'validation to use the same filter format the
'Common dialog OCX uses:
'"All Files (*.*)|*.*"
Dim intPos As Integer
Do While InStr(FilterString, "|") > 0
intPos = InStr(FilterString, "|")
If intPos > 0 Then
FilterString = Left$(FilterString, intPos - 1) _
& Chr$(0) & Right$(FilterString, _
Len(FilterString) - intPos)
End If
Loop
If Right$(FilterString, 2) <> Chr$(0) & Chr$(0) Then
FilterString = FilterString & Chr$(0)
End If
'strFilter = FilterString
End Property
Public Property Get Filter() As String
'Here we reverse the process and return
'the Filter in the same format the it was
'entered
Dim intPos As Integer
Dim strTemp As String
strTemp = strFilter
Do While InStr(strTemp, Chr$(0)) > 0
intPos = InStr(strTemp, Chr$(0))
If intPos > 0 Then
strTemp = Left$(strTemp, intPos - 1) & "|" & Right$(strTemp, _
Len(strTemp) - intPos)
End If
Loop
If Right$(strTemp, 1) = "|" Then
strTemp = Left$(strTemp, Len(strTemp) - 1)
End If
Filter = strTemp
End Property
Public Property Let StartInDir(ByVal strFolder As String)
'Sets the directory the dialog displays when called
If Len(Dir(strFolder)) > 0 Then
strDir = strFolder
Else
Err.Raise 514, "FileDialog", "Invalid Initial Directory"
End If
End Property
Public Property Let HideReadOnly(ByVal blnVal As Boolean)
blnHideReadOnly = blnVal
End Property
Public Property Let MultiSelect(ByVal blnVal As Boolean)
'allow users to select more than one file using
'The Shift or CTRL keys during selection
blnAllowMulti = True
End Property
Public Property Let FileMustExist(ByVal blnVal As Boolean)
blnMustExist = blnVal
End Property
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' Display and use the File open dialog
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Function thAddFilterItem(ByVal strFilter As String, ByVal strDescription As String, Optional ByVal varItem As Variant) As String
If IsMissing(varItem) Then varItem = "*.*"
thAddFilterItem = strFilter & strDescription & vbNullChar & varItem & vbNullChar
End Function
Public Function ShowOpen(ByVal strDir As String, ByVal strFilter As String, ByVal strTitle As String) As String
Dim strTemp As String
'strFilter = thAddFilterItem(strFilter, "Drawing Files (*.dwg)", "*.dwg")
Dim udtStruct As OPENFILENAME
With udtStruct
.lStructSize = LenB(udtStruct)
'Use our private variable
.hwndOwner = lngHwnd
'Use our private variable
.lpstrFilter = strFilter
.lpstrFile = Space$(254)
.nMaxFile = 255
.lpstrFileTitle = Space$(254)
.nMaxFileTitle = 255
'Use our private variable
.lpstrInitialDir = strDir
'Use our private variable
.lpstrTitle = strTitle
' udtStruct.lpstrCustomFilter = "*.*"
'Ok, here we test our booleans to
'set the flag
End With
If blnHideReadOnly And blnAllowMulti And blnMustExist Then
udtStruct.flags = OFN_HIDEREADONLY Or _
OFN_ALLOWMULTISELECT Or OFN_EXPLORER Or OFN_FILEMUSTEXIST
ElseIf blnHideReadOnly And blnAllowMulti Then
udtStruct.flags = OFN_ALLOWMULTISELECT _
Or OFN_EXPLORER Or OFN_HIDEREADONLY
ElseIf blnHideReadOnly And blnMustExist Then
udtStruct.flags = OFN_HIDEREADONLY Or OFN_FILEMUSTEXIST
ElseIf blnAllowMulti And blnMustExist Then
udtStruct.flags = OFN_ALLOWMULTISELECT Or _
OFN_EXPLORER Or OFN_FILEMUSTEXIST
ElseIf blnHideReadOnly Then
udtStruct.flags = OFN_HIDEREADONLY
ElseIf blnAllowMulti Then
udtStruct.flags = OFN_ALLOWMULTISELECT _
Or OFN_EXPLORER
ElseIf blnMustExist Then
udtStruct.flags = OFN_FILEMUSTEXIST
End If
If GetOpenFileName(udtStruct) Then
strTemp = (Trim(udtStruct.lpstrFile))
ShowOpen = Mid(strTemp, 1, Len(strTemp) - 1)
End If
End Function
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' Display and use the File Save dialog
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function ShowSave(ByVal strDir As String, ByVal strFilter, ByVal strTitle) As String
Dim strTemp As String
Dim udtStruct As OPENFILENAME
udtStruct.lStructSize = LenB(udtStruct)
'Use our private variable
udtStruct.hwndOwner = lngHwnd
'Use our private variable
udtStruct.lpstrFilter = strFilter
udtStruct.lpstrFile = Space$(254)
udtStruct.nMaxFile = 255
udtStruct.lpstrFileTitle = Space$(254)
udtStruct.nMaxFileTitle = 255
'Use our private variable
udtStruct.lpstrInitialDir = strDir
'Use our private variable
udtStruct.lpstrTitle = strTitle
If blnMustExist Then
udtStruct.flags = OFN_FILEMUSTEXIST
End If
If GetSaveFileName(udtStruct) Then
strTemp = (Trim(udtStruct.lpstrFile))
ShowSave = Mid(strTemp, 1, Len(strTemp) - 1)
End If
End Function
Function GetXLSFile(ByVal strDir As String, ByVal strTitle As String)
' strTitle = "Select Excel File"
Dim strFilter As String ' , strTitle As String
Dim lngFlags As LongPtr, filestring
strFilter = thAddFilterItem(strFilter, "Excel File (*.xls)", "*.xls")
GetXLSFile = ShowOpen(strDir, strFilter, strTitle)
End Function
Function GetDWGFile(ByVal strDir As String, ByVal strTitle As String)
' strTitle = "Select Drawing File"
Dim strFilter As String ' , strTitle As String
Dim lngFlags As LongPtr, filestring
strFilter = thAddFilterItem(strFilter, "DWG File (*.dwg)", "*.dwg")
GetDWGFile = ShowOpen(strDir, strFilter, strTitle)
End Function
Function SaveFile() '
Dim strTitle As String
Dim strDir As String
Dim strFilter As String ' , strTitle As String
Dim lngFlags As LongPtr, filestring
strDir = "c:\"
strTitle = "Save File"
strFilter = thAddFilterItem(strFilter, "txt File (*.txt)", "*.txt")
'SaveFile = ShowSave(strDir, strFilter, strTitle)
End Function