Полный код из книги Joe Stuphin'a :
Это не полный код, там ещё должен быть либо класс либо ActiveX.
Вот, это замена для dlgOpenFile. Создай класс с именем clsCommonDlg и следующим кодом
Option Explicit
'модернезирован мной
' From Access 2002 Desktop Developer's Handbook
' by Litwin, Getz, and Gunderloy. (Sybex)
' Copyright 2001. All rights reserved.
' =================
' API Constants
' =================
Private Const FNERR_BUFFERTOOSMALL = &H3003
' =================
' API Enums
' =================
Public Enum adhErrorConstants
cdlAlloc = 32752
cdlBufferTooSmall = 20476
cdlCancel = 32755
cdlCreateICFailure = 28661
cdlDialogFailure = -32768
cdlDndmMismatch = 28662
cdlFindResFailure = 32761
cdlGetDevModeFail = 28666
cdlGetNotSupported = 394
cdlHelp = 32751
cdlInitFailure = 28665
cdlInitialization = 32765
cdlInvalidFileName = 20477
cdlInvalidPropertyValue = 380
cdlInvalidSafeModeProcCall = 680
cdlLoadDrvFailure = 28667
cdlLoadResFailure = 32760
cdlLoadStrFailure = 32762
cdlLockResFailure = 32759
cdlMemAllocFailure = 32758
cdlMemLockFailure = 32757
cdlNoDefaultPrn = 28663
cdlNoDevices = 28664
cdlNoFonts = 24574
cdlNoInstance = 32763
cdlNoTemplate = 32764
cdlParseFailure = 28669
cdlPrinterCodes = 28671
cdlPrinterNotFound = 28660
cdlRetDefFailure = 28668
cdlSetNotSupported = 383
cdlSetupFailure = 28670
cdlSubclassFailure = 20478
End Enum
Public Enum adhFileOpenConstants
cdlOFNAllowMultiselect = 512
cdlOFNCreatePrompt = 8192
cdlOFNEnableHook = 32
cdlOFNEnableSizing = 8388608
cdlOFNExplorer = 524288
cdlOFNExtensionDifferent = 1024
cdlOFNFileMustExist = 4096
cdlOFNHelpButton = 16
cdlOFNHideReadOnly = 4
cdlOFNLongNames = 2097152
cdlOFNNoChangeDir = 8
cdlOFNNoDereferenceLinks = 1048576
cdlOFNNoLongNames = 262144
cdlOFNNoNetworkButton = 131072
cdlOFNNoReadOnlyReturn = 32768
cdlOFNNoValidate = 256
cdlOFNOverwritePrompt = 2
cdlOFNPathMustExist = 2048
cdlOFNReadOnly = 1
cdlOFNShareAware = 16384
End Enum
Public Enum adhFileOpenSaveControls
fosCurrentFolder = &H471
fosCurrentFolderLabel = &H443
fosContentsList = &H460
fosContentsListLabel = &H440
fosSelectedFile = &H480
fosSelectedFileLabel = &H442
fosFilterList = &H470
fosFilterListLabel = &H441
fosReadOnly = &H410
fosOKButton = 1
fosCancelButton = 2
fosHelpButton = &H40E
End Enum
' =================
' API Declarations
' =================
#If Win64 Then 'This block of code compiles for 64-bit AutoCAD
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 adhFileOpenConstants
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As LongPtr
lpfnHook As LongPtr
lpTemplateName As String
End Type
Declare PtrSafe Function CommDlgExtendedError Lib "comdlg32.dll" Alias "CommDlgExtendedError" () As Long
Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
#ElseIf Win32 Then ' This block of code compiles for any version of 32-bit AutoCAD
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
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 adhFileOpenConstants
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
#End If
' =================
' Storage for property values.
' =================
#If Win64 Then 'This block of code compiles for 64-bit AutoCAD
Public FileNameBufferSize As LongPtr
Public FilterIndex As LongPtr
Public hwndOwner As LongPtr
Public flags As LongPtr
Public callback As LongPtr
Private mlngFileOffset As LongPtr
Private mlngFileExtOffset As LongPtr
#ElseIf Win32 Then ' This block of code compiles for any version of 32-bit AutoCAD
' Returns/sets the size of the file name
' buffer to use for the FileOpen dialog box.
' The default size is 1000.
Public FileNameBufferSize As Long
' Returns/sets a default filter for an Open or Save As dialog box.
Public FilterIndex As Long
' Sets the hWnd of the dialog owner.
Public hwndOwner As Long
' Flag settings (for backwards compatability only)
Public flags As Long
' Address of the callback function.
Public callback As Long
' Retrieve the offset within the full file name
' to the file portion, or the extension portion.
Private mlngFileOffset As Long
Private mlngFileExtOffset As Long
#End If
' Returns/sets the custom file open/save filter.
' Public CustomFilter As String
' Returns/sets the default filename extension for the dialog box.
Public DefaultExt As String
' Sets the string displayed in the title bar of the dialog box.
Public DialogTitle As String
' Returns/sets the path and filename of a selected file.
Public FileName As String
' Returns/sets the name (without the path) of the file to open or save at run time.
Public FileTitle As String
' Returns/sets the filters that are displayed in the Type list box of a dialog box.
Public Filter As String
' Returns/sets the initial file directory.
Public InitDir As String
' Indicates whether an error is generated when the user chooses the Cancel button.
Public CancelError As Boolean
' Flags specific to the specific dialog box.
Public OpenFlags As adhFileOpenConstants
Private mastrFileList() As String
Public Property Get FileList() As String()
FileList = mastrFileList
End Property
Public Property Get FileOffset() As Long
FileOffset = mlngFileOffset
End Property
Public Property Get FileExtOffset() As Long
FileExtOffset = mlngFileExtOffset
End Property
Public Sub ShowOpen()
Dim ofn As OPENFILENAME
Dim lngErr As Long
Call SetOpenProperties(ofn)
If GetOpenFileName(ofn) <> 0 Then
Call GetOpenProperties(ofn)
Else
lngErr = CommDlgExtendedError()
Select Case lngErr
Case FNERR_BUFFERTOOSMALL
Err.Raise cdlBufferTooSmall, , _
"Filename buffer is too small for the selected files."
Case 0
' If the user wants to raise an error for the Escape
' do it now.
If CancelError Then
Err.Raise cdlCancel, , "Cancel was selected."
End If
Case Else
Err.Raise lngErr, , "Unexpected error."
End Select
End If
End Sub
Public Sub ShowSave()
Dim ofn As OPENFILENAME
Dim lngErr As Long
Call SetOpenProperties(ofn)
If GetSaveFileName(ofn) <> 0 Then
Call GetOpenProperties(ofn)
Else
lngErr = CommDlgExtendedError()
Select Case lngErr
Case FNERR_BUFFERTOOSMALL
Err.Raise cdlBufferTooSmall, , "Filename buffer is too small for the selected files."
Case 0
' If the user wants to raise an error for the Escape
' do it now.
If CancelError Then
Err.Raise cdlCancel, , "Cancel was selected."
End If
Case Else
Err.Raise lngErr, , "Unexpected error."
End Select
End If
End Sub
Private Sub SetOpenProperties(ofn As OPENFILENAME)
Dim strFileName As String
Dim strFileTitle As String
strFileName = String(FileNameBufferSize, vbNullChar)
LSet strFileName = FileName & vbNullChar
strFileTitle = String$(1024, vbNullChar)
With ofn
.lStructSize = Len(ofn)
.hwndOwner = hwndOwner
.lpstrFilter = Replace(Trim$(Filter), "|", vbNullChar) & vbNullChar
.nFilterIndex = FilterIndex
.lpstrFile = strFileName
.nMaxFile = Len(strFileName)
.lpstrFileTitle = strFileTitle
.nMaxFileTitle = Len(strFileTitle)
.lpstrTitle = DialogTitle
.flags = OpenFlags Or flags Or cdlOFNExplorer
.lpstrDefExt = DefaultExt
.lpstrInitialDir = InitDir
.lpstrCustomFilter = String(40, vbNullChar)
.nMaxCustFilter = Len(.lpstrCustomFilter)
If .flags And cdlOFNEnableHook Then
.lpfnHook = callback
End If
End With
End Sub
Private Sub GetOpenProperties(ofn As OPENFILENAME)
Dim astrFileInfo() As String
Dim intPos As Integer
Dim strFileName As String
With ofn
FileName = .lpstrFile
OpenFlags = .flags
flags = .flags
FileTitle = .lpstrFileTitle
FilterIndex = .nFilterIndex
mlngFileExtOffset = .nFileExtension
mlngFileOffset = .nFileOffset
' CustomFilter = .lpstrCustomFilter
If .nFileOffset > 0 Then
strFileName = .lpstrFile
If Mid$(strFileName, mlngFileOffset, 1) = vbNullChar Then
' Look for trailing double null chars, and trim
' the string there.
intPos = InStr(1, strFileName, vbNullChar & vbNullChar)
If intPos > 0 Then
strFileName = Left$(strFileName, intPos - 1)
End If
astrFileInfo = Split(strFileName, vbNullChar)
mastrFileList = astrFileInfo
Else
ReDim mastrFileList(0 To 1)
mastrFileList(0) = Left$(strFileName, mlngFileOffset - 1)
mastrFileList(1) = adhTrimNull(Mid$(strFileName, mlngFileOffset + 1))
FileName = adhTrimNull(FileName)
End If
End If
End With
End Sub
Private Sub Class_Initialize()
FileNameBufferSize = 20000
End Sub
Private Function adhTrimNull(strVal As String) As String
Dim intPos As Integer
intPos = InStr(1, strVal, vbNullChar)
Select Case intPos
Case Is > 1
adhTrimNull = Left$(strVal, intPos - 1)
Case 0
adhTrimNull = strVal
Case 1
adhTrimNull = vbNullString
End Select
End Function
Рядом с кодом представленным тобой выше вставь функцию
Private Function OpenFile() As String
Dim cdl As clsCommonDlg
Dim strFileName As String
On Error GoTo ErrorHandler
Set cdl = New clsCommonDlg
With cdl
#If Win64 Then
.hwndOwner = Application.HWND32
#Else
.hwndOwner = Application.HWND
#End If
.CancelError = True
.DialogTitle = "Выберите файл чертежа"
.Filter = "AutoCAD Blocks (*.DWG) | *.dwg"
.OpenFlags = cdlOFNNoChangeDir Or cdlOFNFileMustExist
.InitDir = Application.ActiveDocument.Path
.ShowOpen
strFileName = .FileName
End With
If Len(Dir$(strFileName)) > 0 Then
OpenFile = strFileName
End If
ExitHere:
Set cdl = Nothing
Exit Function
ErrorHandler:
Select Case Err.Number
Case cdlCancel
' Пользователь нажал кнопку Cancel, игнорируем эту ошибку
Resume ExitHere
Case Else
MsgBox "Ошибка: " & Err.Description & _
"(" & Err.Number & ")", vbCritical + vbOKOnly
End Select
Resume ExitHere
End Function
Свой код измени в следующем фрагменте
''' get input from user
'dlgOpenFile.Filter = "AutoCAD Blocks (*.DWG) | *.dwg"
'dlgOpenFile.InitDir = Application.Path
'dlgOpenFile.ShowOpen
'If dlgOpenFile.FileName = "" Then Exit Sub'заремленное вообще можно убрать
Dim strFileName As String
strFileName=OpenFile
If Len(strFileName) = 0 Then Exit Sub
Me.Hide
...
Set objBlockRef = ThisDrawing.ModelSpace.InsertBlock _
(varInsertionPoint, strFileName, dblX, _
dblY, dblZ, dblRotation)
...
Вообщем как-то так...