• masha
  • Восстановленный участник
  • На форуме с 18 мая 2006г.
  • Сообщений: 175
  • Спасибо: 0

Тема: Не получается скопировать объекты из Layout-a в Model

Здравствуйте, все!
Помогите, кто сможет, буду очень благодарна... Проблема такая. Есть в Layout-e объекты, которые надо покопировать в Model, чтобы они легли на определённое место. Руками пробовала (Copy with base point) - получилось, но при попытке вставки появляется ругательство про какие-то АЕС-объекты, на него я жала ОК.
Как сделать программно - не могу пока придумать, пыталась использовать SendCommand (частично списав из сего замечательного форума) - тоже не получилось:

command_str = "_copybase" & vbCr & "0,0" & vbCr & "si" & vbCr & "p" & vbCr & vbCr
ThisDrawing.SendCommand (command_str)
ThisDrawing.ActiveSpace = acModelSpace
command_str = "_pasteclip" & vbCr & CStr(ins_pt_model_x) & "," & CStr(ins_pt_model_y) & vbCr
ThisDrawing.SendCommand (command_str)

При этом в пространсве модели ничего не появляется, а в командной строке выписывается следующее:

Command: _copybase
Specify base point: 0,0
Select objects: si
Select objects: p
639 found
449 were not in current space.
1 was the paper space viewport.
Command:
COPYBASE Specify base point: Restoring cached viewports.
Regenerating 184 modified entities.
Command: _pasteclip
Invalid point.
Command: 13584834.0392854,7510205.16400748
Select objects: Restoring cached viewports - Regenerating layout.
Command:
Command: Regenerating layout.
Regenerating model.

Чувствую, что хожу где-то вокруг да около, но добиться нужного эффекта пока не могу...

  • masha
  • Восстановленный участник
  • На форуме с 18 мая 2006г.
  • Сообщений: 175
  • Спасибо: 0

Re: Не получается скопировать объекты из Layout-a в Model

В дополнение к вышесказанному...
Копирования объектов (полилинии, тексты, 1 viewport и 1 блок) удалось-такие добиться, НО при вставке объектов в модель вылетает ругательное сообщение про AEC-объекты следующего содержания:
The application has detected a mixed version of AEC objects participating in this operation. Newer AEC objects will be disallowed from participating in this operation.
Никакое 

SendKeys "{ENTER}"

не помогает, оно срабатывает только после того, как руками нажмёшь ОК в этом окошке. Насколько плохо подобное сообщение? Чем мне могут помешать или помочь AEC-объекты?
Мой код:

    command_str = "_copybase" & vbCr & CStr(ins_pt_lay_x) & "," & CStr(ins_pt_lay_y) & vbCr & "ss_kuku" _
                & vbCr & "p" & vbCr & vbCr
    ThisDrawing.SendCommand (command_str)
    ThisDrawing.SendCommand ("*Cancel*" & vbCr)
    ThisDrawing.SendCommand ("*Cancel*" & vbCr)
    ThisDrawing.ActiveSpace = acModelSpace
    command_str = "_pasteclip" & vbCr & CStr(ins_pt_model_x) & "," & CStr(ins_pt_model_y) & vbCr
    ThisDrawing.SendCommand (command_str)

  • masha
  • Восстановленный участник
  • На форуме с 18 мая 2006г.
  • Сообщений: 175
  • Спасибо: 0

Re: Не получается скопировать объекты из Layout-a в Model

Забыла сказать:  по ходу выполнения SendCommad-а вставки  в командной строке прописывается такое:

Command: _pasteclip
Duplicate definition of block Block_kvadratik_25000  ignored.
ARX_ERROR: eNotThatKindOfClassSubstituting [P131.ttf] for [P131].
Substituting [P152.ttf] for [P152].
Substituting [t132.ttf] for [T132].
Substituting [D432.ttf] for [D432].
Specify insertion point: 13584834.0392854,7510205.16400748
Command: Restoring cached viewports - Regenerating layout.
Regenerating 190 modified entities.

P131, T132 - это, вроде, шрифты такие... не понимаю, почему при переносе в модель происходит такое безобразие. Что мне сделать, чтобы это окошко не появлялось?  Что я делаю не так?

  • LeonidSN
  • Активный участник
  • На форуме с 30 мая 2005г.
  • Сообщений: 1,480
  • Спасибо: 5

Re: Не получается скопировать объекты из Layout-a в Model

Вот пример действительно программного решения.
Очень схематичный, но работающий.
Переносит и вставляет объекты по их оригинальный координатам.

Sub objCopy()
    Dim ss As AcadSelectionSet
    Set ss = ThisDrawing.ActiveSelectionSet
    ss.SelectOnScreen
    Dim objCollection(0) As Object
    Dim retObjects As Variant
    Set objCollection(0) = ss(0)
    retObjects = ThisDrawing.CopyObjects(objCollection, ThisDrawing.ModelSpace)
End Sub

  • masha
  • Восстановленный участник
  • На форуме с 18 мая 2006г.
  • Сообщений: 175
  • Спасибо: 0

Re: Не получается скопировать объекты из Layout-a в Model

Леонид, вы меня спасли! Спасибо огромное!!! Только в моём слуачае надо было сдвигать оригинальные координаты. Благодаря https://www.caduser.ru/forum/topic27358.html мне удалось этого добиться, но там написано, что могут быть косяки с точками вставки и выраниваниями, а это не есть хорошо... У меня ПОКА всё работает, но полного морального удовлетворения нету. Окончательный вариант такой:

        'copy need objects to block
    Dim retObjects As Variant, blkNewBlock As AcadBlock, blkNewBlockInsPoint(0 To 2) As Double
    Dim blockRefObj As AcadBlockReference, ins_pt(0 To 2) As Double
    blkNewBlockInsPoint(0) = ins_pt_lay_x: blkNewBlockInsPoint(1) = ins_pt_lay_y: blkNewBlockInsPoint(2) = 0
    Set blkNewBlock = ThisDrawing.Blocks.Add(blkNewBlockInsPoint, "block_for_copy_to_model")
    retObjects = ThisDrawing.CopyObjects(ssobjs, blkNewBlock)
        'show block, and explode it after that
    ins_pt(0) = ins_pt_model_x: ins_pt(1) = ins_pt_model_y: ins_pt(2) = 0
    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(CVar(ins_pt), blkNewBlock.Name, 1#, 1#, 1#, 0)
    blockRefObj.color = acByLayer
    blockRefObj.Update
    blockRefObj.Explode
    blockRefObj.Delete 'delete what needn't more
    blkNewBlock.Delete

И ещё раз большое спасибо!!! Никаких ругательных сообщений больше не вылетает - ура!

  • LeonidSN
  • Активный участник
  • На форуме с 30 мая 2005г.
  • Сообщений: 1,480
  • Спасибо: 5

Re: Не получается скопировать объекты из Layout-a в Model

> masha
А с блоками еще проще, вот код почти по Help:

Sub Insert_Block()
    Dim ss As AcadSelectionSet
    Set ss = ThisDrawing.ActiveSelectionSet
    ss.Clear
    ss.SelectOnScreen
    Dim blkName As String
    Dim insertionPnt(0 To 2) As Double
    insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0#
On Error Resume Next
    Dim blk As AcadBlockReference
    Set blk = ss(0)
    blkName = blk.Name
    Set blk = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, blkName, 1#, 1#, 1#, 0)
End Sub

Метод, который вы применяете, кажется мне слишком "хитрым", может отсюда полного морального удовлетворения нету?