下面的这段代码是版主 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