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 = ThisDrawing.Utility.GetPoint(, \左下\精确取左下点 TZZDer = ThisDrawing.Utility.GetPoint(, \右上\精确取右上点 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 = ThisDrawing.layouts 参数说明 参数式说明 备注 TZQDyi、TZZDer不需要设置 过程开始时，cad必须模型活动。 精确取点，必须用鼠标在模型空间里获取。 必须显示所有图纸，否则后面程序无法执行。 For Each BZnla In layouts
If BZnla.Name = \ BZiio = BZnla.CanonicalMediaName 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
ThisDrawing.ActiveSpace = 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 = ThisDrawing.SelectionSets.Add(\增加选择集
Mxuanze.Select acSelectionSetWindow, Mzx, Mys '窗选模式下选择集的范围 PDif = Mxuanze.Count '输出选择集内部的对象数目
If PDif <> 0 Then
Dim newlayout As AcadLayout
Set newlayout = ThisDrawing.layouts.Add(\增加新的布局 ThisDrawing.ActiveLayout = newlayout '新增布局为活动布局 newlayout.ConfigName = \新增布局的打印机 newlayout.CanonicalMediaName = BZiio '新增布局的纸张 '窗选模式下新增布局的范围 Dim BJzx(0 To 1) As Double
TZxx需要修改
TZy 需要修改
Mxuanze 、PDif不需要设置
newlayout不需要设置
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 * TZy: Mzx(2) = 0
Mys(0) = TZZDer(0) + 1200 * TZx + 1200 * TZxxjs: Mys(1) = TZZDer(1) - 800 * TZy: Mys(2) = 0中的“1200”为小列间距，直接测量出来；“800”为行间距，直接测量出来。
新建标准布局“layout1”
先返回模型空间
选择集建立，如果过程在此失败，重新运行时修改“XZ”。
新布局建立；新布局进行给定属性值时，必须有先后顺序，否则过程不认。如果过程在此失败，重新运行时删除新建的布局。
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 newlayout.SetWindowToPlot BJzx, BJys '指定窗选模式下新增布局的范围 newlayout.PlotType = acWindow '指定新增布局为窗选模式 newlayout.CenterPlot = True '指定新增布局居中 newlayout.StandardScale = acScaleToFit '指定新增布局铺满纸张 newlayout.PlotRotation = ac90degrees '指定新增布局横向打印 newlayout.StyleSheet = \指定新增布局打印样式 XBJjs = XBJjs + 1 End If Mxuanze.Delete '删除选择集对象 TZx = TZx + 1 '记录单列最大的图纸数 If TZx > TZxjs Then TZxjs = TZx End If Loop Until PDif = 0 Next TZxxjs = TZxjs + TZxxjs Next End Sub 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” 为布局里第一张图纸的左下和 右上坐标值，可在标准布局测 得。“21”“15”为布局里列距 和行距，计算可得。 将选择集删除，避免影响循环
a）在每个图形上进行矩形框标识，然后用VBA代码识别矩形框进行批量打印。 '本过程用于同一个模型内， 利用矩形框，一键打印的应用。 '要求：必须有可以识别的矩形框 '变量表：
'ptmin、ptmax记录矩形对角的点值 'strlayername矩形图所在的图层 'objplot打印对象 'ent模型中的对象
'-----------------------------------------------------------------
Sub piliangdayinger() '批量打印
ThisDrawing.ActiveLayout = ThisDrawing.layouts.Item(\确定在模型空间里 ThisDrawing.ActiveLayout.ConfigName = \打印的设备 ThisDrawing.ActiveLayout.StandardScale = acScaleToFit '铺满图纸 ThisDrawing.SetVariable \前台打印 Dim objplot As AcadPlot
Set objplot = ThisDrawing.Plot
Dim ptmin As Variant, ptmax As Variant Dim ent As AcadEntity
Dim strlayername As String '矩形所在图层的名称 strlayername = \
For Each ent In ThisDrawing.ModelSpace
If StrComp(ent.Layer, strlayername, vbTextCompare) = 0 Then '确定对象的图层 If TypeOf ent Is AcadLWPolyline Then '确定对象时矩形 ent.GetBoundingBox ptmin, ptmax ReDim Preserve ptmin(0 To 1) ReDim Preserve prmax(0 To 1)
ThisDrawing.ActiveLayout.SetWindowToPlot ptmin, ptmax ThisDrawing.ActiveLayout.CenterPlot = True
ThisDrawing.ActiveLayout.PlotRotation = ac90degrees ThisDrawing.ActiveLayout.StyleSheet = \objplot.PlotToDevice '打印 End If End If Next ent
ThisDrawing.SetVariable \End Sub
c）使用VBA代码进行图样位置识别，然后进行批量打印。 应用步骤：
第一步，将图形等列、等行排放
第二步，打开VBA编辑器（工具→宏→Visual Basic编辑器），插入一个模块，将下面的过程代码复制进去 第三步，修改参数 第四步，运行