vba cad布局复制

vba cad布局复制 Dim CADapp As Object Public Function IVersion() As String 'È??æ??ºÅ On Error Resume Next Set CADapp = GetObject(, "AutoCAD.Application") If Err.Number <> 0 Then Set CADapp = CreateObject("AutoCAD.Application") End If CADapp.Visible = True IVersion = Left(CADapp.Version, 2) End Function Public Function IobjDbx() As Object '?ñÈ??Ó?Ú?æ?? Version = IVersion If CInt(Version) < 16 Then Set IobjDbx = CADapp.GetInterfaceObject("ObjectDBX.AxDbDocument") Else Set IobjDbx = CADapp.GetInterfaceObject("ObjectDBX.AxDbDocument." & Version) End If End Function Public Function layoutcopy(Documentobj As Object, SourcelayoutName As String, TargetlayoutName As String) As Object '??ÖÆ???Ö Dim mylayout As Object Dim objArray() As Object Dim ent() As Object Dim lngCount As Long, i As Long lngCount = Documentobj.Layouts(SourcelayoutName).Block.Count Set mylayout = CADapp.Application.activeDocument.Layouts.Add(TargetlayoutName) If lngCount > 0 Then ReDim objArray(0 To lngCount - 1) For i = 0 To lngCount - 1 Set objArray(i) = Documentobj.Layouts(SourcelayoutName).Block.Item(i) Next mylayout.CopyFrom Documentobj.Layouts(SourcelayoutName) Documentobj.Database.CopyObjects objArray, mylayout.Block Set layoutcopy = mylayout End If End Function Sub Test() Dim Documentobj As Object Set Documentobj = IobjDbx Documentobj.Open "c:\xxx.dwt" layoutcopy Documentobj, "xxx.dwtÖÐ???ÖÃû?Æ", "Ö???ÐÂ???ÖÃû?Æ" Set Documentobj = Nothing Set CADapp = Nothing End Sub