[молод и перспективен]

Как скопировать коллекцию блоков из одного файла (зная его местонахождения на жестком) в активный документ. С помощью ВБА

[Кулик Алексей aka kpblc]

См.справку по методу InsertBlock. Ну или ObejctDBX в руки и вперед...

[Roman3R]

DesignCenter

[Кулик Алексей aka kpblc]

Roman3R, ты раздел-то смотрел?

[Олег (jr.)]

Сообщение от молод и перспективен Как скопировать коллекцию блоков из одного файла (зная его местонахождения на жестком) в активный документ. С помощью ВБА

Мона так

Код:

[Выделить все]

Option Explicit

'' Copy block definitions from other drawing
'' written by Fatty T.O.H. (c) 2006
'' All rights removed, feel free to change to your suit
'' ShowOpen dialog written by Sccaddmember, see this thread:
'' http://discussion.autodesk.com/thread.jspa?threadID=489202

'' require reference to AutoCAD/ObjectDBX Common XX.0 Type Library

Dim oDbx As New AxDbDocument
Dim fname As String
Dim sBlkName As String
Dim OutputStr As String
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
                                         "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
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 Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type


Private Function ShowOpen(Filter As String, _
                         InitialDir As String, _
                         DialogTitle As String) As String
    Dim OFName As OPENFILENAME
    'Set the structure size
    OFName.lStructSize = Len(OFName)
    'Set the owner window
    OFName.hwndOwner = 0
    'Set the filter
    OFName.lpstrFilter = Filter
    'Set the maximum number of chars
    OFName.nMaxFile = 255
    'Create a buffer
    OFName.lpstrFile = Space(254)

    'Create a buffer
    OFName.lpstrFileTitle = Space$(254)
    'Set the maximum number of chars
    OFName.nMaxFileTitle = 255
    'Set the initial directory
    OFName.lpstrInitialDir = InitialDir
    'Set the dialog title
    OFName.lpstrTitle = DialogTitle
    'no extra flags
    OFName.flags = 0
    'Show the 'Open File' dialog
    If GetOpenFileName(OFName) Then
        ShowOpen = Trim(OFName.lpstrFile)
    Else
        ShowOpen = ""
    End If
End Function


Public Sub CopyBlocksFormOutside()

    Dim Filter As String

    Dim InitialDir As String

    Dim DialogTitle As String

    Filter = "Drawing Files (*.dwg)" + Chr$(0) + "*.dwg" + Chr$(0) + _
             "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)

    InitialDir = ThisDrawing.Path

    DialogTitle = "Open a DWG file"

    OutputStr = ShowOpen(Filter, InitialDir, DialogTitle)

    fname = OutputStr

    CopyBlocks (fname)

End Sub



Private Sub CopyBlocks(fname As String)

    Set oDbx = GetInterfaceObject("ObjectDBX.AxDbDocument." & Left(ThisDrawing.GetVariable("acadver"), 2))

    oDbx.Open fname

    Dim oBlocks As AcadBlocks

    Dim oBlock As AcadBlock

    Dim copyVar() As AcadBlock

    Set oBlocks = oDbx.Blocks

    Dim i As Integer

    i = -1

    On Error GoTo HoustonWeHaveAProblem

    For Each oBlock In oBlocks

        If Not oBlock.IsXRef And Not oBlock.IsLayout And Not oBlock.Name Like "*,*|*" Then

            i = i + 1

            ReDim Preserve copyVar(i) As AcadBlock

            Set copyVar(i) = oBlock

        End If

    Next

    Dim idPairs As Variant

    Dim copyObj As Variant

    On Error Resume Next

    copyObj = oDbx.CopyObjects(copyVar, ThisDrawing.Blocks, idPairs)

    If Err Then

        Err.Clear

    End If

    On Error GoTo 0

    Set oDbx = Nothing

HoustonWeHaveAProblem:

    If Err.Number <> 0 Then

        MsgBox "ObjectDBX CopyObjects method objects failed." & vbCr & Err.Number & " " & Err.Description, vbCritical

    End If

End Sub

~'J'~