Nested Copy

[Anonymous]

I wanted to write my own nested copy command in VBA that is like the NCOPY Express Tool except does not prompt for base and displacement points. (I also find NCOPY to be slow) I thought it would be quite simple but it doesn't seem to be simple enough for me. I can get a subentity a tell if it is nested one level down from a Block or XREF but can't work out how to copy it into modelspace. Any help will be greatly appreciated. This code is as far as I got:
----------
Option Explicit

Public Sub test()
Dim objEnt As AcadEntity
Dim varPickedPoint As Variant
Dim varTransMatrix As Variant
Dim varContextData As Variant
Dim objEntParent As AcadEntity
On Error GoTo ErrorHandler
ThisDrawing.Utility.GetSubEntity objEnt, varPickedPoint, varTransMatrix, varContextData
On Error GoTo 0
If IsEmpty(varContextData) = False Then
If UBound(varContextData) = 0 Then
Set objEntParent = ThisDrawing.ObjectIdToObject(varContextData(0))
If TypeOf objEntParent Is AcadBlockReference Then


End If
End If
End If
Exit Sub
ErrorHandler:
Resume
End Sub
----------
Regards - Nathan

[Anonymous]

Refreshed after the weekend I worked out how to copy an object in a XREF in to modelspace. So if anyone was interested here is the code.
----------
Option Explicit

Public Sub test()
Dim objEnt As AcadEntity
Dim varPickedPoint As Variant
Dim varTransMatrix As Variant
Dim varContextData As Variant
Dim objEntParent As AcadEntity
Dim objEnts(0) As AcadEntity
Dim varReturned As Variant
On Error GoTo ErrorHandler
ThisDrawing.Utility.GetSubEntity objEnt, varPickedPoint, varTransMatrix, varContextData
On Error GoTo 0
If IsEmpty(varContextData) = False Then
If UBound(varContextData) = 0 Then
Set objEntParent = ThisDrawing.ObjectIdToObject(varContextData(0))
If TypeOf objEntParent Is AcadExternalReference Then
Set objEnts(0) = objEnt
varReturned = ThisDrawing.Blocks(objEntParent.Name).XRefDatabase.CopyObjects(objEnts, ThisDrawing.ModelSpace)
End If
End If
End If
Exit Sub
ErrorHandler:
Resume
End Sub
----------
Regards - Nathan

[Anonymous]

I spoke too soon. The CopyObjects method returns "Invalid owner object" when text is selected.
Regards - Nathan

[Anonymous]

Just in case anyone is interested here is what I ended up with. I find it quicker and easier than NCOPY but it does not copy multiply nested objects or objects containing nested objects.
--------------------
Option Explicit
Private Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Integer

Public Sub XCopy()
Dim objSSet As AcadSelectionSet
Dim blnError As Boolean
Dim objEnt As AcadEntity
Dim varPickedPoint As Variant
Dim varTransMatrix As Variant
Dim varContextData As Variant
Dim objEntParent As AcadEntity
Dim objEnts(0) As AcadEntity
Dim varReturned As Variant
Dim intIndex As Integer
Dim strLType As String
Dim strTStyle As String
GetAsyncKeyState (&H2)
GetAsyncKeyState (&H1B)
GetAsyncKeyState (&HD)
If ThisDrawing.Layers("0").Freeze = True Then ThisDrawing.Layers("0").Freeze = False
Set objSSet = CreateSSet.CreateEmptySSet
Do
blnError = False
On Error GoTo ErrorHandler
ThisDrawing.Utility.GetSubEntity objEnt, varPickedPoint, varTransMatrix, varContextData
On Error GoTo 0
If blnError = True Then
If GetAsyncKeyState(&H2) Then Exit Do 'Right Button Click
If GetAsyncKeyState(&HD) Then Exit Do 'Enter Key Press
If GetAsyncKeyState(&H1B) Then 'Esc Key Press
objSSet.Erase
objSSet.Delete
Exit Sub
End If
Else
If IsEmpty(varContextData) = False Then
If UBound(varContextData) = 0 Then
Set objEntParent = ThisDrawing.ObjectIdToObject(varContextData(0))
If TypeOf objEntParent Is AcadExternalReference Then
Set objEnts(0) = objEnt
strLType = objEnt.Linetype
objEnt.Linetype = "ByLayer"
If TypeOf objEnt Is AcadText Then
strTStyle = objEnt.StyleName
objEnt.StyleName = "State|Standard"
End If
varReturned = ThisDrawing.Blocks(objEntParent.Name).XRefDatabase.CopyObjects(objEnts, ThisDrawing.ModelSpace)
If TypeOf objEnt Is AcadText Then
objEnt.StyleName = strTStyle
End If
objEnt.Linetype = strLType
varReturned(0).Layer = "0"
varReturned(0).Highlight (True)
Set objEnts(0) = varReturned(0)
objSSet.AddItems (objEnts)
End If
End If
End If
End If
Loop
For Each objEnt In objSSet
objEnt.Highlight (False)
Next objEnt
objSSet.Delete
Exit Sub
ErrorHandler:
blnError = True
Resume Next
End Sub
--------------------
Regards - Nathan