Тема: VBA. Вставить блок из другого файла.

Доброго времени суток. Уважаемые форумчане, подскажите пожалуйста, реализуема ли средствами VBA такая задача... "Если в чертеже нет блока с именем "Блок1", то вставить его в чертеж из другого файла, путь к которому известен".
Порывшись в литературе нашел вот это:
Но у меня этот код не работает выдает error 424 Object required.
Ругается вот на эти строки:

dlgOpenFile.Filter = "AutoCAD Blocks (*.DWG) | *.dwg"
dlgOpenFile.InitDir = Application.Path
dlgOpenFile.ShowOpen]

Подскажите пожалуйста, как быть, куда копать? Система w7x64 (на всякий случай)
Заранее спасибо!

Полный код из книги Joe Stuphin'a :

Private Sub CommandButton1_Click()
Dim objBlockRef As AcadBlockReference
Dim varInsertionPoint As Variant
Dim dblX As Double
Dim dblY As Double
Dim dblZ As Double
Dim dblRotation As Double
'' get input from user
dlgOpenFile.Filter = "AutoCAD Blocks (*.DWG) | *.dwg"
dlgOpenFile.InitDir = Application.Path
dlgOpenFile.ShowOpen
If dlgOpenFile.FileName = "" Then Exit Sub
Me.Hide
With ThisDrawing.Utility
.InitializeUserInput 1
varInsertionPoint = .GetPoint(, vbCr & "Pick the insert point: ")
.InitializeUserInput 1 + 2
dblX = .GetDistance(varInsertionPoint, vbCr & "X scale: ")
.InitializeUserInput 1 + 2
dblY = .GetDistance(varInsertionPoint, vbCr & "Y scale: ")
.InitializeUserInput 1 + 2
dblZ = .GetDistance(varInsertionPoint, vbCr & "Z scale: ")
.InitializeUserInput 1
dblRotation = .GetAngle(varInsertionPoint, vbCr & "Rotation angle: ")
End With
'' create the object
On Error Resume Next
Set objBlockRef = ThisDrawing.ModelSpace.InsertBlock _
(varInsertionPoint, dlgOpenFile.FileName, dblX, _
dblY, dblZ, dblRotation)
If Err Then
MsgBox "Unable to insert this block"
Exit Sub
End If
objBlockRef.Update
Me.Show
End Sub

Re: VBA. Вставить блок из другого файла.

Полный код из книги 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)
...

Вообщем как-то так...

Re: VBA. Вставить блок из другого файла.

Забыл сказать, что я очень начинающий программист. Так что я в небольшом шоке от вышепрочитанного... Во время почтения у меня было примерно такое лицо..  :o . 
Невероятно.. В любом случае огромное спасибо! Буду разбираться! Вы мне очень помогли!

(изменено: Ingwar, 18 марта 2014г. 11:33:41)

Re: VBA. Вставить блок из другого файла.

Не переживай! Всё ещё будет. ;)
Код несколько разросся из-за потребности работать в каде разной битности. Сильно не тестировалось (открытие диалога выбора файлов), но работает в AutoCAD 2010 32 и 2012 64.

Удачи!