023集——批量图纸空间数据（视图）复制到模型空间——vba代码实现

yngsqq

于 2024-08-13 11:50:09 发布

阅读量206

点赞数 8

分类专栏： CAD VBA 文章标签： java 前端服务器

本文链接：https://blog.csdn.net/yongshiqq/article/details/141160300

版权

CAD VBA 专栏收录该内容

45 篇文章 7 订阅

订阅专栏

高版本cad图中含有两个图纸空间（paperspace）,工作中有时把布局1 和布局2中的数据复制到模型空间，如下图所示：

使用下图dvb插件可批量一键完成：

(输入：vbaman加载此插件，vbarun运行此插件即可，海量文件一键完成。详情可私)

如下图:

另附部分源代码：

Public Function papertomodel(Absolute As Boolean)
On Error Resume Next
If Absolute Then
Dim arr() As AcadEntity
   For laynum = 1 To 2
      """""""""""""""""""""""""""""""""""""""""""
     """""""""""""""""""""""""""""""""""""""""""

   """"""""  cad*1代*1码*1代1*写、*定1*1制*1插*1件


 """""""""""""""""""""""""""""""""""""""""""
 """""""""""""""""""""""""""""""""""""""""""
                Set arr(i) = entv
                i = i + 1
            End If
       Next entv
     ThisDrawing.****** arr, ThisDrawing.*****Space
    i = 0
    Next laynum
End If
ThisDrawing.ActiveLayout = ThisDrawing.Layouts.Item(0)
ZoomExtents
End Function

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