CAD vba实现 图纸空间复制到模型空间

 

Public Function papertomodel(Optional Absolute As Boolean = True, Optional ByVal dis As Double = 1000)
'qq443440204@2024年8月13日15:45:30 第一个参数为是否是绝对坐标，第二个参数是粘贴相对距离
'On Error Resume Next
Dim laynum As Integer
Dim arr() As AcadEntity
Dim mylayout As AcadLayout
If Absolute Then
   For Each mylayout In ThisDrawing.Layouts
           Set qbb = ThisDrawing.Layouts
           ThisDrawing.ActiveLayout = mylayout
           If InStr(1, mylayout.Name, "Model", 1) < 1 Then
                  Set mypaperspace = ThisDrawing.PaperSpace
                 'MsgBox mylayout.Name
                  If InStr(1, mypaperspace.Name, "Paper", 1) >= 1 Then
                         ZoomExtents
                           For Each entv In mypaperspace
                               ReDim Preserve arr(i)
                               If Not (entv.ObjectName = "AcDbViewport" Or entv.ObjectName = "AcDbLayout" Or IsEmpty(entv)) Then
                                   'MsgBox entv.ObjectName
                                   Set arr(i) = entv
                                   i = i + 1
                               End If
                          Next entv
                          On Error Resume Next
                     ThisDrawing.CopyObjects arr, ThisDrawing.ModelSpace
                     On Error GoTo 0
                       i = 0
                 End If
          End If
    Next mylayout
Else
        Dim pt_one As Variant
        '定义角2 pt_two(0to1) x=角1y=角3y, move 函数的两个点。0#意思是把这个0转成双精度赋值。0!为单精度
        Dim pt_two(0 To 2) As Double: pt_two(2) = 0#
        '定义角3 pt_three(0to1) 系统获取，不能设置为数组格式,设置双精度会提示
        Dim pt_three As Variant
        '定义角4 pt_four_arr(0to1) x=角3y=角1,设置为数组格式变体变量，否则提示错误
        Dim pt_four_arr(0 To 1) As Double
        Dim paste_point(0 To 2) As Double
        Dim copynum As Integer
           For Each mylayout In ThisDrawing.Layouts
           Set qbb = ThisDrawing.Layouts
           ThisDrawing.ActiveLayout = mylayout
           'MsgBox InStr(1, mylayout.Name, "Model", 1)
           If InStr(1, mylayout.Name, "Model", 1) < 1 Then '含有则大于1，小于1则说明不含有
                 'MsgBox mylayout.Name
               
                            ZoomExtents
                            Set mypaperspace = ThisDrawing.PaperSpace
                           ' MsgBox mypaperspace.Name
                            'MsgBox InStr(1, mypaperspace.Name, "Paper", 1)
                            
                    If InStr(1, mypaperspace.Name, "Paper", 1) >= 1 Then
                        If copynum > 0 Then
                            pt_one = ThisDrawing.GetVariable("extmin")
                            pt_three = ThisDrawing.GetVariable("extmax")
                            pt_two(0) = pt_one(0): pt_two(1) = pt_three(1)
                            pt_four_arr(0) = pt_three(0): pt_four_arr(1) = pt_one(1)
                            For Each entv In mypaperspace
                               entv.Move pt_one, paste_point
                            Next entv
                            ZoomExtents
                         End If
                           For Each entv In mypaperspace
                               ReDim Preserve arr(i)
                               If Not (entv.ObjectName = "AcDbViewport" Or entv.ObjectName = "AcDbLayout" Or IsEmpty(entv)) Then
                                   'MsgBox entv.ObjectName
                                   Set arr(i) = entv
                                   i = i + 1
                               End If
                          Next entv
                    ThisDrawing.CopyObjects arr, ThisDrawing.ModelSpace
                    pt_one = ThisDrawing.GetVariable("extmin")
                    pt_three = ThisDrawing.GetVariable("extmax")
                    pt_two(0) = pt_one(0): pt_two(1) = pt_three(1)
                    pt_four_arr(0) = pt_three(0): pt_four_arr(1) = pt_one(1)
                    paste_point(0) = pt_four_arr(0) + dis '间距
                    paste_point(1) = pt_four_arr(1)
                    copynum = copynum + 1
                    i = 0
                 End If
          End If
    Next mylayout
End If
ThisDrawing.ActiveLayout = ThisDrawing.Layouts.Item(0)
ZoomExtents
End Function

Sub test()
Call papertomodel(False, 200)
' true则原坐标粘贴，false,则相对坐标粘贴，即：true或 false,1000
MsgBox "OK" & Space(50) & vbCr & _
 "vba代码二次开发qq:443440204", vbInformation, "版权所有qq:443440204"
End Sub

 

Public Function papertomodel(Absolute As Boolean)
'qq443440204@2024年8月13日11:37:45
On Error Resume Next
If Absolute Then
Dim laynum As Integer
Dim arr() As AcadEntity
Dim mylayout As AcadLayout
   For Each mylayout In ThisDrawing.Layouts
  Set qbb = ThisDrawing.Layouts
          
           ThisDrawing.ActiveLayout = mylayout
          
           If InStr(1, mylayout.Name, "Model", 1) <> 1 Then
                  Set mypaperspace = ThisDrawing.PaperSpace
                 'MsgBox mylayout.Name
                  If InStr(1, mypaperspace.Name, "Paper", 1) Then
                        
                         ZoomExtents
                           For Each entv In mypaperspace
                               ReDim Preserve arr(i)
                               If Not (entv.ObjectName = "AcDbViewport" Or entv.ObjectName = "AcDbLayout" Or IsEmpty(entv)) Then
                                   'MsgBox entv.ObjectName
                                   Set arr(i) = entv
                                   i = i + 1
                               End If
                          Next entv
                          On Error Resume Next
                     ThisDrawing.CopyObjects arr, ThisDrawing.ModelSpace
                     On Error GoTo 0
                       i = 0
                 End If
          End If
    Next mylayout
End If
ThisDrawing.ActiveLayout = ThisDrawing.Layouts.Item(0)
ZoomExtents
End Function

Sub test()
Call papertomodel(True)
MsgBox "OK" & Space(50) & vbCr & _
 "vba代码二次开发qq:443440204", vbInformation, "版权所有qq:443440204"
End Sub

 

 

Public Function papertomodel(Absolute As Boolean)
If Absolute Then
Dim laynum As Integer
Dim arr() As AcadEntity
   For laynum = 1 To 2
      Set qaa = ThisDrawing.Layouts.Item(laynum)
      ThisDrawing.ActiveLayout = qaa
      Set qbb = ThisDrawing.PaperSpace
        For Each entv In qbb
            ReDim Preserve arr(i)
            If entv.ObjectName <> "AcDbViewport" Then
    
                Set arr(i) = entv
                i = i + 1
            End If
       Next entv
      Stop
      
     ThisDrawing.CopyObjects arr, ThisDrawing.ModelSpace
    i = 0
    
    Next laynum
End If
ThisDrawing.ActiveLayout = ThisDrawing.Layouts.Item(0)
ZoomExtents
End Function

Sub test()
Call papertomodel(True)
End Sub