Copy Objects
Well, since you did not show all code (how the selectionset is collected), it is hard to say what went wrong there. Did you step through the code and examine the variables in "Locals Window" to make sure you do not have an empty entity array? No error at all (assume you do not have "On Error Resume Next" that would hide any exception)?
Following complete code, which is only different from yours by how to gathering the entity array, works well:
Option Explicit
Public Sub CopyToNewDwg()
Dim ents As Variant
Dim sourceDwg As AcadDocument
Dim destDwg As AcadDocument
Dim returned As Variant
Set sourceDwg = AcadApplication.ActiveDocument
ents = CollectEnts(sourceDwg)
If UBound(ents) < 0 Then
MsgBox "No source entity found!"
Exit Sub
End If
Set destDwg = AcadApplication.Documents.Add()
returned = sourceDwg.CopyObjects(ents, destDwg.ModelSpace)
AcadApplication.ZoomExtents
MsgBox UBound(returned) + 1 & " entities were copied!"
End Sub
Private Function CollectEnts(doc As AcadDocument) As Variant
Dim ents() As AcadEntity
Dim ent As AcadEntity
Dim i As Integer
For Each ent In doc.ModelSpace
ReDim Preserve ents(i)
Set ents(i) = ent
i = i + 1
Next
CollectEnts = ents
End Function
See the short video that proves its execution succeeds:
Well, as I mentioned in my reply (as I guessed), it is the very common code error (out of habit of many VBA coders) that makes us blind to the obvious: using "On Error Resume Next" without cancel its effect when it is not needed any more.
Here is your code (by the way, here you somehow call the DestinationDwg.CopyObjects(), which really should have been called from SourceDwg, as the code shown in your original post. I assume it was just an error in rush):
Sub test_pl()
'Dim ssetObj As AcadSelectionSet
Dim oEnt As AcadEntity
Dim Pt(0 To 2) As Double
Dim oLWP As AcadLWPolyline
Dim oP As AcadPolyline
Dim dblNewCords As Variant
Dim ssetObj As AcadSelectionSet
On Error Resume Next
ThisDrawing.SelectionSets.Item("TEST_SSET2").Delete
ThisDrawing.Utility.GetEntity oEnt, Pt, "Select a polyline"
Set oLWP = oEnt
dblCurCords = oLWP.Coordinates
iMaxCurArr = UBound(dblCurCords)
iMaxNewArr = ((iMaxCurArr + 1) * 1.5) - 1
ReDim dblNewCords(iMaxNewArr) As Double
iCurArrIdx = 0: iCnt = 1
For iNewArrIdx = 0 To iMaxNewArr
If iCnt = 3 Then
dblNewCords(iNewArrIdx) = 0
iCnt = 1
Else
dblNewCords(iNewArrIdx) = dblCurCords(iCurArrIdx)
iCurArrIdx = iCurArrIdx + 1
iCnt = iCnt + 1
End If
Next
Set ssetObj = ThisDrawing.SelectionSets.Add("TEST_SSET2")
ssetObj.SelectByPolygon acSelectionSetCrossingPolygon, dblNewCords
Dim sourceEnts()
ReDim sourceEnts(ssetObj.Count - 1)
For i = 0 To ssetObj.Count - 1
Set sourceEnts(i) = ssetObj(i)
Next
Dim SourceDwg As AcadDocument
Set SourceDwg = ThisDrawing.Application.ActiveDocument
Dim DestinationDwg As AcadDocument
Set DestinationDwg = Documents.Add
DestinationDwg.CopyObjects sourceEnts, SourceDwg.ModelSpace
Done:
'' clean up selection set
ssetObj.Delete
End Sub
Below is my modified code with highlight/comment on what happens:
Option Explicit '' I added this. I am sure you agree and only missed it because of rushing for test code
Sub test_pl()
Dim oEnt As AcadEntity
Dim Pt(0 To 2) As Double
Dim oLWP As AcadLWPolyline
Dim oP As AcadPolyline
Dim dblCurCords As Variant
Dim dblNewCords As Variant
Dim iMaxCurArr As Integer
Dim iMaxNewArr As Integer
Dim iCurArrIdx As Integer
Dim iNewArrIdx As Integer
Dim iCnt As Integer
Dim ssetObj As AcadSelectionSet
On Error Resume Next '' This is the devil caused trouble. See later comment
ThisDrawing.SelectionSets.Item("TEST_SSET2").Delete
On Error GoTo 0 '' Remove the "On Error Resume Next" effect after its intention
ThisDrawing.Utility.GetEntity oEnt, Pt, "Select a polyline"
Set oLWP = oEnt
dblCurCords = oLWP.Coordinates
iMaxCurArr = UBound(dblCurCords)
iMaxNewArr = ((iMaxCurArr + 1) * 1.5) - 1
ReDim dblNewCords(iMaxNewArr) As Double
iCurArrIdx = 0: iCnt = 1
For iNewArrIdx = 0 To iMaxNewArr
If iCnt = 3 Then
dblNewCords(iNewArrIdx) = 0
iCnt = 1
Else
dblNewCords(iNewArrIdx) = dblCurCords(iCurArrIdx)
iCurArrIdx = iCurArrIdx + 1
iCnt = iCnt + 1
End If
Next
Set ssetObj = ThisDrawing.SelectionSets.Add("TEST_SSET2")
ssetObj.SelectByPolygon acSelectionSetCrossingPolygon, dblNewCords
'' This is source of the error: the CopyObjects requires arry of AcadEntity, not array of Varaint
'' this causes CopyObjects() method failed, but because of "On Error Resume Next", you did not notice the error
'' Dim sourceEnts()
Dim sourceEnts() As AcadEntity '' As long as I made this change, the code worked
Dim i As Integer
ReDim sourceEnts(ssetObj.Count - 1)
For i = 0 To ssetObj.Count - 1
Set sourceEnts(i) = ssetObj(i)
Next
'' clean up selection set
ssetObj.Delete
Dim SourceDwg As AcadDocument
Set SourceDwg = ThisDrawing.Application.ActiveDocument
Dim DestinationDwg As AcadDocument
Set DestinationDwg = Documents.Add
'' I assume you made this line wrong because of rushing test code
'' DestinationDwg.CopyObjects sourceEnts, SourceDwg.ModelSpace
SourceDwg.CopyObjects sourceEnts, DestinationDwg.ModelSpace
AcadApplication.ZoomExtents
End Sub
It is very common that a programmer, no matter how experienced one could be, may totally blind to see the obvious from his/her own code, but has sharper eyes to scan others' 😪
