Вставка блока с переопределением.

У меня сделано кое-что по этой теме. Посмотрите, что Вам подойдет

Загрузка блока из одного файла в другой
Пользователь определяет файл-донор и блок
см. макрос "C:\ACADadd\ACADmacros\LoadBlock D21\LoadBlock.dvb"

Программист определяет файл-донор и блок
Sub loadBlock4(fileName$, blockName$)
    'Разработал В.Г. Тимаков 26.08.2008
    'Цель: Загрузка блока в активный файл из другого файла
    'Дано:
        'fileName$ - имя файла, содержащего требуемый блок
        'blockName$ - имя требуемого блока
    'Результат: Требуемый блок загружен в активный файл
    'Пример:
        'Sub t()
        '    Dim fileName$, blockName$
        '    fileName = "C:\ACADadd\LibraryRail\Стандарты ЛЖДП.dwg"
        '    blockName = "боковой штамп"
        '    Call loadBlock4(fileName$, blockName$)
        'End Sub
   
    'чтение содержимого текущего файла. Нижеследующую конструкцию сделал, т.к.
        'при каких-то изменениях в меню Window, теряется свойство Active у видимого файла
        Dim targetDoc As AcadDocument 'имя файла, в который надо загрузить блок
        Dim i%, n%: n = Documents.Count 'общее количество файлов в приложении
        For i = 0 To n - 1
            If Documents(i).Active Then Set targetDoc = Documents.Item(i) 'комплект-набор текущего файла
        Next i
    'работа с файлом-донором
        'открытие файла
                On Error GoTo myExit1 'если нет файла в данном компьютере
                ThisDrawing.Application.Documents.Open (fileName)
myExit1:
                If Err <> 0 Then
                    Err.Clear
                    Dim Res1: Res1 = "В этом компьютере нет файла " & fileName & "."
                    Res1 = MsgBox(Res1, vbOKOnly, "MyLibrary4, modACAD, Sub loadBlock")
                    End
                End If
        'чтение содержимого файла
            Dim sourceDoc As AcadDocument
            n = Documents.Count
            For i = 0 To n - 1
                If Documents(i).FullName = fileName Then Set sourceDoc = Documents.Item(i)
            Next i
        'проверка наличия требуемого блока
            Dim oBlocks As AcadBlocks: Set oBlocks = ThisDrawing.Blocks 'коллекция блоков
            n = ThisDrawing.Blocks.Count 'общее количество блоков в файле
            Dim isBlock As Boolean: isBlock = False
            Set oBlocks = sourceDoc.Blocks       'коллекция блоков в файле-доноре
            Dim oBlock As AcadBlock: Set oBlock = oBlocks.Item(blockName)   'искомый блок
            For i = 0 To n - 1
                If oBlocks(i).Name = blockName$ Then isBlock = True
            Next i
            If Not isBlock Then
                Res1 = "В файле " & fileName & Chr(10)
                Res1 = Res1 & "нет блока " & blockName
                Res1 = MsgBox(Res1, vbOKOnly, "MyLibrary4, modACAD, Sub loadBlock")
                End
            End If
    'загрузка блока в текущий файл
        Dim objCopy(0) As AcadObject: Set objCopy(0) = oBlock 'копия блока
        Dim RetVal 'Variant (array of objects). Массив вновь созданных дубликатов объектов.
                    'Only primary objects are returned in this array
        Dim IDPairs 'Variant (array of IDPair objects); input-output; optional
                'Information on what happened during the copy and translation process.
                'Input: an empty variant.
                'Output: an array of IDPair objects
        RetVal = sourceDoc.CopyObjects(objCopy, targetDoc.Blocks, IDPairs)
    'заключительные работы
        sourceDoc.Close False: Set sourceDoc = Nothing 'закрытие файла-донора
End Sub

Вставка блока программно (InsertBlock3)

Function InsertBlock3(blName$, pBase() As Double, _
        Optional Sc# = 1, Optional xs# = 1, Optional ys# = 1, Optional zs# = 1, _
        Optional Layer$ = "активный", Optional blExplode As Boolean = False)
    'Разработал В.Г. Тимаков 24.06.2007
    'Цель: Вставка  блока
    'пример обращения к процедуре:
        'Call InsertBlock3(blName, pBase()) ' без свойств
    'given:
        'blName - имя вставляемого блока
        'pBase() - координаты вставки и угол поворота блокав радианах или формулой: градусы / 180 * Pi.
                    'Если угол > 0, блок поворачивается против часовой стрелки
        'Sc# = 1 - масштаб  для координат точки вставки блока
        'xs# = 1 - масштаб блока по оси X. При xs < 0 блок отображается зеркально относительно оси X
        'ys# = 1 - масштаб блока по оси Y. При ys < 0 блок отображается зеркально относительно оси Y
        'zs# = 1 - масштаб блока по оси Z. При zs < 0 блок отображается зеркально относительно оси Z
        'Layer$ = "активный". AcadBlockReference вставляется в текущий слой
        'blEx - признак необходимости разрушить блок
     
     'установка слоя текущим
        If Layer$ <> "активный" Then Call ChangeLayerCur3(Layer$)
    'определение координат точки вставки с учетом масштаба
        Dim BlockRotation#, insertionPnt(0 To 2) As Double
        insertionPnt(0) = pBase(0) * Sc: insertionPnt(1) = pBase(1) * Sc: insertionPnt(2) = pBase(2) * Sc
     'чтение угла поворота блока
        BlockRotation = pBase(3)
    'вставка блока
        Dim CurBlockRefObj As AcadBlockReference
        Set CurBlockRefObj = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, blName, xs, ys, zs, BlockRotation)
    'разрушение блока
        If blExplode Then CurBlockRefObj.Explode
  End Function

Примечание:
К блокам NUS (non-uniform scaled — не одинаковый
по масштабу) нельзя применить метод Explode
Где-то видел в справке

Вставка блока из другого файла (без загрузки?)
[Re:] Vildar (2008-10-28 10:19:54)

Привет.
В файле заготовок хранится набор нужных блоков, путь к нему в строке strDwgFileFullPath допустим. Вставляю его в текущий чертеж:
'вставка блока из файла
ThisDrawing.ModelSpace.InsertBlock(InsertPoint, strDwgFileFullPath, 1, 1, 1, 0)
Потом удаляю. Остаются только определения блоков которые были в файле заготовок.
Вроде все нормуль. Но если это новый созданный чертеж, то выскакивает ошибка файлера. А немного погодя может и сработать.
Не пойму в чем причины этой ошибки, почему и когда она появляется и вдруг потом пропадает куда-то.
Спасибо.
[Re:] AlexV (2008-10-28 11:10:28)

Я обычно использую для аналогичных целей процедуру типа такой:
Private Sub Perenos_opisaniy_Bl(strDwgFileFullPath)
Dim I_Point(0 To 2) As Double
Dim Block_R As AcadExternalReference
I_Point(0) = 0: I_Point(1) = 0: I_Point(2) = 0
If Dir(strDwgFileFullPath) = "" Then Exit Sub
If ThisDrawing.FullName <> strDwgFileFullPath Then
    Set Block_R = ThisDrawing.ModelSpace.AttachExternalReference(strDwgFileFullPath, "Name_", I_Point, 1, 1, 1, 0, False)
    ThisDrawing.Blocks.Item(Block_R.Name).Bind True
    Block_P.Delete
    ThisDrawing.Blocks.Item("Name_").Delete
End If
End Sub
Вроде работает и в только созданных чертежах. Только имя "Name_" должно быть таким, что бы блоков с ним не попадалось в базе данных чертежей (или предварительно надо организовать проверку)

[Re:] AlexV (2008-10-28 11:12:29)

Block_P.Delete
=
Block_R.Delete

[Re:] Vildar (2008-10-28 13:18:28)

Благодарствую, то что нужно.
Тока Bind непойму что такое. Превращает Xref в блок?
[Re:] AlexV (2008-10-28 13:47:26)

> Vildar
«    Тока Bind непойму что такое. Превращает Xref в блок?     »

Типа того. Внедряет в.с. в чертеж. В противном случае в чертеже будут присутствовать слои, размерные и т.д. стили внешних ссылок (с именами типа "Name_|0"). Если же ссылку внедрить (причем именно "....Bind True", что соответствует внедрению в.с. способом вставки стандартными средствами), то префиксы все "отпадут". Конечно, слои,стили вставляемого чертежа перенесутся в чертеж текущий, но если в нем только блоки (с примитивами на "0" слое), а все лишнее вычищено, то ничего страшного.

[Re:] Vildar (2008-10-28 14:08:51)

Слов нет.
Thank you very much!

Вставка блока с атрибутами, пропустить ввод атрибутов

[Re:] Mbus (2008-10-28 13:00:50)

Здравствуйте!
я вот так вставляю блок
str_act = "(command ""_insert"" """ & Name & "=" & Path & """ """ & strPt & """ ""1"" ""1"" ""0"" ) "
ThisDrawing.SendCommand (str_act)
где Name — имя блока
Path — путь к файлу
strPT — т. вставки
все вставляется, но сразу в командной строке далее появляется запрос для ввода значения каждого атрибута данного блока, а мне надо чтобы либо вылезло окно сразу как по команде АТРЕД или просто пропустился ввод атрибутов всех махом.
Как это сделать?
[Re:] fixo (2008-10-28 13:09:31)

> Mbus
Вставь вначале
Thisdrawing.setvariable "ATTREQ", 0
Точно не помню, но вроде эта переменная
~'J'~
[Re:] Mbus (2008-10-28 13:18:03)

СПАСИБО БОЛЬШОЕ!!!!
ATTREQ и ATTDIA то что нужно

Имя блока = имени файла
Узнал из Интернета.
Dim insPnt(0 To 2) As Double
insPnt(0) = 0
insPnt(1) = 0
insPnt(2) = 0

Вот так не работает:  Call ThisDrawing.ModelSpace.InsertBlock(insPnt, "D:\test.dwg", 1, 1, 1, 0) после purge
А вот так работает: Dim mStr As String
mStr = "D:\test.dwg"
Call ThisDrawing.ModelSpace.InsertBlock(insPnt, mStr, 1, 1, 1, 0)

При вставки блока в чертеж:
Код
Dim insPnt(0 To 2) As Double
insPnt(0) = 0
insPnt(1) = 0
insPnt(2) = 0
Call ThisDrawing.ModelSpace.InsertBlock(insPnt, "D:\test.dwg", 1, 1, 1, 0)
Call ThisDrawing.ModelSpace.InsertBlock(insPnt, mStr, 1, 1, 1, 0)

получаю следующее сообщение:

Run-time error '-2145386445 (80200033)'
Ошибка файлера

(В англ. автокаде - Filer error)

Причем в новом файле этот код успешно выполняется (хоть несколько раз). Но если выполнить _purge - после этого этот Filer error и появляется

Содержимое test.dwg - несколько простых примитивов (пробовал различные файлы вместо test.dwg)
(Используется AutoCAD 2010)
Изменено: vlalexey - 09-11-2010 10:10:10

        
vlalexey
Заглянувший
Сообщений: 2 Баллов: 1 Регистрация: 23-07-2010
#2
09-11-2010 12:14:30
Проблема решилась.
Описание решения:
http://forum.dwg.ru/showthread.php?p=...post650887
Код
Dim mStr As String
mStr = "D:\test.dwg"
Call ThisDrawing.ModelSpace.InsertBlock(insPnt, mStr, 1, 1, 1, 0)