下面的这段代码是版主 lzh741206前不久提供的，测试表明线条没有丢失。
Sub t7()
Dim Doc1 As AcadDocument, Doc2 As Object
Dim ssetObj As AcadSelectionSet
Dim objCollection() As AcadEntity
Set Doc1 = Application.ActiveDocument Set ssetObj = Doc1.ActiveSelectionSet
ssetObj.Select acSelectionSetAll
If ssetObj.Count > 0 Then
ReDim objCollection(ssetObj.Count - 1) As AcadEntity
For k = 0 To ssetObj.Count - 1
Set objCollection(k) = ssetObj(k)
Next k
Set Doc2 = Documents.Add
Doc1.CopyObjects objCollection, Doc2.ModelSpace
End If
End Sub
置顶卡
