2024年3月7日发(作者：)
CAD VBA中一个模型空间不同图样的批量打印（VBA程序）
说明：
1、本VBA程序在CAD2008/2009运行成功；电脑系统64位。
2、本程序仅对略有VBA基础知识同志共同学习、共勉；还请编程高手对不妥之处给予指正。谢谢大家！
3、本VBA程序用于解决如下问题：如下图所示，当一个Model有12张图形是如何使用VBA代码实现一键打印或发布。
一般情况下，VBA有三种解决思路：
a）在每个图形上进行矩形框标识，然后用VBA代码识别矩形框进行批量打印。
b）使用VBA代码进行批量布局，然后使用CAD的发布功能进行批量打印。
c）使用VBA代码进行图样位置识别，然后进行批量打印。
4、本文仅对第二种和第三种方法进行程序演示。
b）使用VBA代码进行批量布局，然后使用CAD的发布功能进行批量打印。
应用步骤：
第一步，将图形等列、等行排放
第二步，新建一个标题为“layout1”布局， “页面布局管理器”的参数修改为自己想要的参数
第三步，打开VBA编辑器（工具→宏→Visual Basic编辑器），插入一个模块，将下面的过程代码复制进去
第四步，修改参数
第五步，运行
过程 参数说明 参数式说明 备注
'本过程用于同一个模型内，多张图纸一键布局的应用。
'要求：多张图纸的最大轮廓必须为同一大小，并且必须等行、等列排放。
'变量表：
'TZQDyi、TZZDer记录精确取点的值
'TZxx、TZy 、TZx大列循环（X方向）、行循环、小列循环（X方向）
'TZxxjs大列的图纸个数
'TZxjs小列的图纸个数
'XBJjs布局个数
'Mzx(0 To 2)、Mys(0 To 2)数组，记录选择的范围。
'Mxuanze选择集对象
'PDif选择的对象个数
'newlayout布局对象
'BJzx(0 To 1)、BJys(0 To 1)数组，记录窗选布局的范围
'-----------------------------------------------------------------
Sub piliangbuju() '批量布局
Dim TZQDyi As Variant
Dim TZZDer As Variant
TZQDyi = nt( "左下") '精确取左下点
TZZDer = nt( "右上") '精确取右上点
ZoomAll '将所有图形显示
Dim TZxx As Integer
Dim TZxxjs As Integer
Dim TZxjs As Integer
Dim XBJjs As Integer
XBJjs = 0 '布局名称计数
TZxxjs = 0 '大列计数
'获取正确打印纸名称
Dim BZiio As String
Dim BZnla As AcadLayout
Dim layouts As AcadLayouts
Set layouts = s
For Each BZnla In layouts
If = "Layout1" Then
TZQDyi、TZZDer不需要设置
过程开始时，cad必须模型活动。
精确取点，必须用鼠标在模型空间里获取。
必须显示所有图纸，否则后面程序无法执行。
BZiio = calMediaName
End If
Next
For TZxx = 0 To 2
TZxjs = 0
Dim TZy As Integer
For TZy = 0 To 3
Dim TZx As Integer
TZx = 0 '单列X方向计数
Do
Space = acModelSpace '返回模型空间
'指定图纸位置
Dim Mzx(0 To 2) As Double
Dim Mys(0 To 2) As Double
Mzx(0) = TZQDyi(0) + 1200 * TZx + 1200 *
TZxxjs: Mzx(1) = TZQDyi(1) - 800 * TZy:
Mzx(2) = 0
Mys(0) = TZZDer(0) + 1200 * TZx + 1200 *
TZxxjs: Mys(1) = TZZDer(1) - 800 * TZy:
Mys(2) = 0
Dim Mxuanze As AcadSelectionSet
Dim PDif As Integer
Set Mxuanze =
("XZ") '增加选择集
acSelectionSetWindow Mzx
Mys '窗选模式下选择集的范围
PDif = '输出选择集内部的对象数目
If PDif <> 0 Then
Dim newlayout As AcadLayout
Set newlayout =
("XBJ" & XBJjs) '增加新的布局
Layout = newlayout '新增布局为活动布局
Name = "DWF6
3" '新增布局的打印机
calMediaName = BZiio '新增布局的纸张
'窗选模式下新增布局的范围
Dim BJzx(0 To 1) As Double
TZxx需要修改
TZy 需要修改
For TZxx = 0 To 2中的“2”根据自己在模型空间所建立的大列数修改。3大列为2，4大列为3依次类推。
For TZy = 0 To 3中的“3”指的是行数，有几行就写几。
Mzx(0) =
TZQDyi(0) +
1200 * TZx +
1200 * TZxxjs:
Mzx(1) =
TZQDyi(1) - 800
新建标准布局“layout1”
Dim BJys(0 To 1) As Double
BJzx(0) = 53 + 21 * TZx + 21 * TZxxjs:
BJzx(1) = 103 + 15 * TZy
BJys(0) = 74 + 21 * TZx + 21 * TZxxjs:
BJys(1) = 117 + 15 * TZy
dowToPlot BJzx BJys '指定窗选模式下新增布局的范围
pe = acWindow '指定新增布局为窗选模式
Plot = True '指定新增布局居中
rdScale = acScaleToFit '指定新增布局铺满纸张
tation = ac90degrees '指定新增布局横向打印
heet = "" '指定新增布局打印样式
XBJjs = XBJjs + 1
End If
'删除选择集对象
TZx = TZx + 1
'记录单列最大的图纸数
If TZx > TZxjs Then
TZxjs = TZx
End If
Loop Until PDif = 0
Next
TZxxjs = TZxjs + TZxxjs
Next
End Sub
Mxuanze
、PDif不需要设置
newlayout不需要设置
* TZy: Mzx(2) =
0
Mys(0) =
TZZDer(0) +
1200 * TZx +
1200 * TZxxjs:
Mys(1) =
TZZDer(1) - 800
* TZy: Mys(2) = 0中的“1200”为小列间距，直接测量出来；“800”为行间距，直接测量出来。
BJzx(0) = 53 + 21
* TZx + 21 *
TZxxjs: BJzx(1) =
103 + 15 * TZy
BJys(0) = 74 + 21
* TZx + 21 *
TZxxjs: BJys(1) =
117 + 15 * TZy
中的“53”“103”“74”“117”为布局里第一
先返回模型空间
选择集建立，如果过程在此失败，重新运行时修改“XZ”。
新布局建立；新布局进行给定属性值时，必须有先后顺
张图纸的左下和右上坐标值，可在标准布局测得。“21”“15”为布局里列距和行距，计算可得。
序，否则过程不认。如果过程在此失败，重新运行时删除新建的布局。
将选择集删除，避免影响循环
c）使用VBA代码进行图样位置识别，然后进行批量打印。
应用步骤：
第一步，将图形等列、等行排放
第二步，打开VBA编辑器（工具→宏→Visual Basic编辑器），插入一个模块，将下面的过程代码复制进去
第三步，修改参数
第四步，运行
过程
'本过程用于同一个模型内，多张图纸一键打印的应用。
'要求：多张图纸的最大轮廓必须为同一大小，并且必须等行、等列排放。
'变量表：
'TZQDyi、TZZDer记录精确取点的值
'TZxx、TZy 、TZx大列循环（X方向）、行循环、小列循环（X方向）
'TZxxjs大列的图纸个数
'TZxjs小列的图纸个数
'Mzx(0 To 2)、Mys(0 To 2)数组，记录选择的范围。
'Mxuanze选择集对象
'newplot打印对象
'PDif选择的对象个数
'-----------------------------------------------------------------
Sub piliangdaying() '批量布局
Dim TZQDyi As Variant
Dim TZZDer As Variant
TZQDyi = nt( "左下") '精确取左下点
TZZDer = nt( "右上") '精确取右上点
ZoomAll '将所有图形显示
Dim TZxx As Integer
Dim TZxxjs As Integer
Dim TZxjs As Integer
TZxxjs = 0 '大列计数
'获取正确打印纸名称
参数说明
参数式说明
备注
TZQDyi、TZZDer不需要设置
过程运行时必须在模型空间
精确取点，必须用鼠标在模型空间里获取。
必须显示所有图纸，否则后面程序
Dim BZiio As String
Dim BZnla As AcadLayout
Dim layouts As AcadLayouts
Set layouts = s
For Each BZnla In layouts
If = "Layout1" Then
BZiio = calMediaName
End If
Next
For TZxx = 0 To 2
TZxjs = 0
Dim TZy As Integer
For TZy = 0 To 3
Dim TZx As Integer
TZx = 0 '单列X方向计数
Do
'指定图纸位置
Dim Mzx(0 To 2) As Double
Dim Mys(0 To 2) As Double
Mzx(0) = TZQDyi(0) + 1200 * TZx + 1200 *
TZxxjs: Mzx(1) = TZQDyi(1) - 800 * TZy: Mzx(2)
= 0
Mys(0) = TZZDer(0) + 1200 * TZx + 1200 *
TZxxjs: Mys(1) = TZZDer(1) - 800 * TZy: Mys(2) =
0
Dim Mxuanze As AcadSelectionSet
Dim PDif As Integer
Set Mxuanze =
("XZ") '增加选择集
acSelectionSetWindow Mzx Mys '窗选模式下选择集的范围
PDif = '输出选择集内部的对象数目
If PDif <> 0 Then
Dim newlayout As AcadLayout
Set newlayout =
'增加模型布局
Name = "DWF6 3" '模型布局的打印机
calMediaName = BZiio '模型布局的纸张
TZxx需要设置
TZy需要设置
For TZxx
= 0 To 2中的“2”根据自己在模型空间所建立的大列数修改。3大列为2，4大列为3依次类推。
For TZy =
0 To 3中的“3”指的无法执行。
'窗选模式下模型布局的范围
dowToPlot Mzx Mys '指定窗选模式下模型布局的范围
pe = acWindow '指定模型布局为窗选模式
Plot = True '指定模型布局居中
rdScale = acScaleToFit '指定模型布局铺满纸张
tation = ac90degrees '指定模型布局横向打印
heet = "" '指定模型布局打印样式
Dim newplot As AcadPlot
Set newplot =
Device
End If
'删除选择集对象
TZx = TZx + 1
'记录单列最大的图纸数
If TZx > TZxjs Then
TZxjs = TZx
End If
Loop Until PDif = 0
Next
TZxxjs = TZxjs + TZxxjs
Next
End Sub
注意此处的参数设置
是行数，有几行就写几。
Mzx(0) =
TZQDyi(0) + 1200 *
TZx +
1200 *
TZxxjs:
Mzx(1) =
TZQDyi(1) - 800 *
TZy:
Mzx(2) =
0
Mys(0) =
TZZDer(0) + 1200 *
TZx +
1200 *
TZxxjs:
Mys(1) =
TZZDer(1) - 800 *
TZy:
Mys(2) =
0中的“1200”为小列间距，直接测量出来；“800”为行间距，直接测量出来。
建立在模型空间中的布局，用于打印参数的获取
打印参数
如果想打印到PDF文件，请更改configname属性值。
建立新的打印对象，执行打印任务
将选择集删除，避免影响循环
发布评论