Копирование внедрённых объектов

[who]

Можно ли как-то средствами VBA скопировать внедрённый объект (в моём случае из автокада, и это важно) вместе с областью или отдельно с одного листа на другой?
(подразумевается что листов будет много и с каждого нужно копировать эти объекты)
Во вложении с листа 2 нужно скопировать на лист 1
exsampl_copy.zip

[doober]

Можно.
Алгоритм таков.
Находите внедренный объект,получаете его хендл,через командную строку открываете файл,подключаетесь к нему через GetObject,работаете с объектной моделью Автокада.
Задача сложная.

[who]

Мдя... такое я точно не сделаю. Спасибо.

[doober]

Как оказалось,я вас понял не правильно.
Копирование можно элементарно сделать,да и документ открыть не проблема.С автокада открыть внедренный объект сложнее

Sub PasteAutoCAD()
    Dim Донор As Worksheet, Потребитель As Worksheet
    Set Донор = ThisWorkbook.Worksheets("Изделие 1")
    Set Потребитель = ThisWorkbook.Worksheets("Титульный лист")

    Dim Sh As Shape
    For Each Sh In Донор.Shapes
        If InStr(1, Sh.OLEFormat.progID, "AutoCAD.Drawing", vbTextCompare) > 0 Then
            Sh.Copy
            With Потребитель
                .Activate
                .Range("B10").Select'Ячейка для вставки
                .Paste
            End With
        End If
    Next

End Sub

Sub OpenAutoCAD()
   Dim Донор As Worksheet, Sh As Shape
    Set Донор = ThisWorkbook.Worksheets("Изделие 1")
 
    For Each Sh In Донор.Shapes
        If InStr(1, Sh.OLEFormat.progID, "AutoCAD.Drawing", vbTextCompare) > 0 Then
            Sh.Select
         Selection.Verb Verb:=xlPrimary
        End If
    Next
    Set AppAutoCAD = GetObject(, "AutoCAD.Application.19")
    Set DocAutoCAD = AppAutoCAD.Activedocument
    Set ModelSpace=DocAutoCAD.ModelSpace
End Sub

[who]

честно говоря я нашёл своё решение, включив запись макроса и определив, как "обзывает" эти объекты сам excel. переименовав их при помощи тогоже VBA:

Sheets(3).Shapes("Object 32").Name = "Izdelie_1"

и все остальные 9 листов и изделий
(имена вроде не меняются со временем, если их не удалять и не вставлять новые)
копирую их с проверкой наличия на целевом листе:

On Error Resume Next
Set obj = Sheets(1).Shapes("Izdelie_1")
If obj Is Nothing Then
    Sheets(3).Shapes("Izdelie_1").Copy
    Sheets(1).Range("B13").Select
    Sheets(1).Paste
End If
Set obj = Sheets(1).Shapes("Izdelie_2")
If obj Is Nothing Then
    Sheets(4).Shapes("Izdelie_2").Copy
    Sheets(1).Range("B25").Select
    Sheets(1).Paste
End If
Set obj = Sheets(1).Shapes("Izdelie_3")
If obj Is Nothing Then
    Sheets(5).Shapes("Izdelie_3").Copy
    Sheets(1).Range("B37").Select
    Sheets(1).Paste
End If
    'Stop
Set obj = Sheets(1).Shapes("Izdelie_4")
If obj Is Nothing Then
    Sheets(6).Shapes("Izdelie_4").Copy
    Sheets(1).Range("B49").Select
    Sheets(1).Paste
End If
Set obj = Sheets(1).Shapes("Izdelie_5")
If obj Is Nothing Then
    Sheets(7).Shapes("Izdelie_5").Copy
    Sheets(1).Range("B61").Select
    Sheets(1).Paste
End If
Set obj = Sheets(1).Shapes("Izdelie_6")
If obj Is Nothing Then
    Sheets(8).Shapes("Izdelie_6").Copy
    Sheets(1).Range("B73").Select
    Sheets(1).Paste
End If
Set obj = Sheets(1).Shapes("Izdelie_7")
If obj Is Nothing Then
    Sheets(9).Shapes("Izdelie_7").Copy
    Sheets(1).Range("B85").Select
    Sheets(1).Paste
End If
Set obj = Sheets(1).Shapes("Izdelie_8")
If obj Is Nothing Then
    Sheets(10).Shapes("Izdelie_8").Copy
    Sheets(1).Range("B97").Select
    Sheets(1).Paste
End If
Set obj = Sheets(1).Shapes("Izdelie_9")
If obj Is Nothing Then
    Sheets(11).Shapes("Izdelie_9").Copy
    Sheets(1).Range("B109").Select
    Sheets(1).Paste
End If
Set obj = Sheets(1).Shapes("Izdelie_10")
If obj Is Nothing Then
    Sheets(12).Shapes("Izdelie_10").Copy
    Sheets(1).Range("B121").Select
    Sheets(1).Paste
End If

только что-то с проверкой пока не получается.
без проверки копируется

хотя и с этим разобрался добавив к каждой проверке obj1, obj2 и т.д...
просьба сильно не пинать, я фактически самоучка (только Delpy 5 вроде в универе лет 11-12 назад)