Sub 复制CAD()
Dim AutoCadApp As Object
Dim ThisDrawing As Object
Dim AutoCadDoc As Object
Dim DOC1 As AcadDocument
Dim DOC2 As AcadDocument
Dim ENT As AcadEntity
Dim SSet As AcadSelectionSet
Dim retObject() As Variant
CadDwgFileName = "d:\111\1.DWG"
Set AutoCadApp = GetObject(, "AutoCAD.Application")
AA1 = AutoCadApp.Documents.Count
Set DOC1 = AutoCadApp.Documents.Add
Set DOC2 = AutoCadApp.Documents.Open(CadDwgFileName)
AA1 = DOC2.ModelSpace.Count
ReDim retObject(0 To AA1 - 1)
Dim PISET() As Object
ReDim PISET(0 To AA1 - 1)
For I = 0 To AA1 - 1
Set PISET(I) = DOC2.ModelSpace.Item(I)
Next
'Set ThisDrawing = DOC2
DOC2.CopyObjects PISET, DOC1.ModelSpace, retObject
DOC1.Activate
ZoomExtents
End Sub