在使用AUTOCAD时我们经常需要设置布局这样方便我们的打印和管理。但是对于有多个图纸的情况下布局的调整相对来讲比较繁琐。所以我通过AI的帮助结合自己的创新式修改为大家带来的自动生成布局的代码。此代码完全公开望大家支持BOOKEASY!一. 窗体代码Option Explicit 声明一个私有变量用于存储返回值Private m_ReturnValue As Long 这是一个只读属性供外部调用者获取返回值Public Property Get ReturnValue() As LongReturnValue m_ReturnValueEnd PropertyPrivate Sub Label1_Click()End SubPrivate Sub 布局总名称_Change()End Sub 确定按钮的点击事件Private Sub 确定按钮_Click()m_ReturnValue 2 设定返回值为2Me.Hide 注意这里是Hide不是UnloadEnd Sub 取消按钮的点击事件或者关闭按钮XPrivate Sub 取消按钮_Click()m_ReturnValue 3 设定返回值为3Me.HideEnd Sub 当用户点击右上角X关闭时默认为取消返回3Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)If CloseMode vbFormControlMenu Thenm_ReturnValue 3Me.HideCancel 0 允许关闭End IfEnd SubPrivate Sub UserForm_Click()End SubPrivate Sub UserForm_Initialize() 设置 ComboBox1 的下拉选项With 打印机下拉菜单.AddItem Microsoft Print to PDF.AddItem iR-ADV 4545 III 默认选中第一个可选.ListIndex 0End With线宽单选.Value False布局总名称.Value Left(ThisDrawing.Name, Len(ThisDrawing.Name) - 4)End SubPrivate Sub 线宽单选_Click()End Sub二. 模块代码Option ExplicitPrivate CountA1 As IntegerPrivate CountA2 As IntegerPrivate CountA3 As IntegerPrivate CountA4 As IntegerPrivate TransferringComB1Value As StringPrivate TransferringCheckValue As BooleanPrivate TransferringTexValue As StringSub BuildLayoutWithSelectedBlocks()TransferringComB1Value TransferringCheckValue FalseTransferringTexValue 布局设置窗口.showIf 布局设置窗口.ReturnValue 2 ThenTransferringComB1Value 布局设置窗口.打印机下拉菜单.ValueTransferringCheckValue 布局设置窗口.线宽单选.ValueTransferringTexValue 布局设置窗口.布局总名称.ValueUnload 布局设置窗口ElseIf 布局设置窗口.ReturnValue 3 ThenUnload 布局设置窗口Exit SubEnd IfDim i As Long, j As Long 由于我们是从后往前删除直接循环遍历集合并判断即可 这里采用从后往前遍历的方式可以避免因删除导致集合索引变化的问题For i ThisDrawing.Layouts.Count - 1 To 0 Step -1 检查布局名称是否包含 BOOK不区分大小写If InStr(1, UCase(ThisDrawing.Layouts.Item(i).Name), TransferringTexValue) 0 Then 删除该布局ThisDrawing.Layouts.Item(i).DeleteEnd IfNext iDim ss As AcadSelectionSetDim ent As AcadEntityDim blockRef As AcadBlockReference 1. 创建临时选择集处理名称冲突On Error Resume NextThisDrawing.SelectionSets(TempSelectionSet).DeleteOn Error GoTo 0Set ss ThisDrawing.SelectionSets.Add(TempSelectionSet) 2. 提示用户在屏幕上选择对象ThisDrawing.ActiveSpace acModelSpacess.SelectOnScreen 3. 检查是否有选择对象If ss.Count 0 ThenMsgBox 未选择任何对象, vbExclamationss.DeleteExit SubEnd If 4. 遍历选中的对象CountA1 0: CountA2 0: CountA3 0: CountA4 0Dim sortedBlocksA1() As AcadBlockReferenceDim sortedBlocksA2() As AcadBlockReferenceDim sortedBlocksA3() As AcadBlockReferenceDim sortedBlocksA4() As AcadBlockReferenceReDim sortedBlocksA1(1 To 100) As AcadBlockReferenceReDim sortedBlocksA2(1 To 100) As AcadBlockReferenceReDim sortedBlocksA3(1 To 100) As AcadBlockReferenceReDim sortedBlocksA4(1 To 100) As AcadBlockReferenceDim TotalA1Num, TotalA2Num, TotalA3Num, TotalA4Num As Integer 5.1 遍历选择集只收集块引用For Each ent In ssIf TypeOf ent Is AcadBlockReference ThenSet blockRef entSelect Case blockRef.NameCase A1打印定位弧TotalA1Num TotalA1Num 1Set sortedBlocksA1(TotalA1Num) blockRefCase A2打印定位弧TotalA2Num TotalA2Num 1Set sortedBlocksA2(TotalA2Num) blockRefCase A3打印定位弧TotalA3Num TotalA3Num 1Set sortedBlocksA3(TotalA3Num) blockRefCase A4打印定位弧TotalA4Num TotalA4Num 1Set sortedBlocksA4(TotalA4Num) blockRefEnd SelectEnd IfNext ent 6.检查是否有块引用If TotalA1Num TotalA2Num TotalA3Num TotalA4Num 0 ThenMsgBox 选中的对象中没有【打印定位弧】块, vbExclamationss.DeleteExit SubEnd IfOn Error Resume NextReDim Preserve sortedBlocksA1(1 To TotalA1Num) As AcadBlockReferenceReDim Preserve sortedBlocksA2(1 To TotalA2Num) As AcadBlockReferenceReDim Preserve sortedBlocksA3(1 To TotalA3Num) As AcadBlockReferenceReDim Preserve sortedBlocksA4(1 To TotalA4Num) As AcadBlockReferenceOn Error GoTo 0//******* 7.分别对A1,A2,A3,A4的图纸按位置排序先从左到右 X再从上到下 Y*******//【开始】Dim tempBlk As AcadBlockReference 7(1)(1) 对A1图纸排序 冒泡排序按 X 坐标升序X相同则按 Y 降序Dim pos1 As Variant, pos2 As VariantIf TotalA1Num 1 ThenFor i 1 To UBound(sortedBlocksA1) - 1For j i 1 To UBound(sortedBlocksA1)pos1 sortedBlocksA1(i).InsertionPointpos2 sortedBlocksA1(j).InsertionPoint 比较规则先 X从左到右X相同再 Y从上到下即Y值大的在前If (pos1(1) pos2(1)) Or (pos1(1) pos2(1) And pos1(0) pos2(0)) Then 交换位置Set tempBlk sortedBlocksA1(i)Set sortedBlocksA1(i) sortedBlocksA1(j)Set sortedBlocksA1(j) tempBlkEnd IfNext jNext i 7(1)(2) 对A1图纸建立布局For i UBound(sortedBlocksA1) To 1 Step -1Set blockRef sortedBlocksA1(i) 调用你的处理函数CountA1 CountA1 1CreateLayoutWithMargins blockRefNextElseIf TotalA1Num 1 ThenSet blockRef sortedBlocksA1(1) 调用你的处理函数CountA1 CountA1 1CreateLayoutWithMargins blockRefEnd If 7(2)(1) 对A2图纸排序 冒泡排序按 X 坐标升序X相同则按 Y 降序If TotalA2Num 1 ThenFor i 1 To UBound(sortedBlocksA2) - 1For j i 1 To UBound(sortedBlocksA2)pos1 sortedBlocksA2(i).InsertionPointpos2 sortedBlocksA2(j).InsertionPoint 比较规则先 X从左到右X相同再 Y从上到下即Y值大的在前If (pos1(1) pos2(1)) Or (pos1(1) pos2(1) And pos1(0) pos2(0)) Then 交换位置Set tempBlk sortedBlocksA2(i)Set sortedBlocksA2(i) sortedBlocksA2(j)Set sortedBlocksA2(j) tempBlkEnd IfNext jNext i 7(2)(2) 对A2图纸建立布局For i UBound(sortedBlocksA2) To 1 Step -1Set blockRef sortedBlocksA2(i) 调用你的处理函数CountA2 CountA2 1CreateLayoutWithMargins blockRefNextElseIf TotalA2Num 1 ThenSet blockRef sortedBlocksA2(1) 调用你的处理函数CountA2 CountA2 1CreateLayoutWithMargins blockRefEnd If 7(3)(1) 对A3图纸排序 冒泡排序按 X 坐标升序X相同则按 Y 降序If TotalA3Num 1 ThenFor i 1 To UBound(sortedBlocksA3) - 1For j i 1 To UBound(sortedBlocksA3)pos1 sortedBlocksA3(i).InsertionPointpos2 sortedBlocksA3(j).InsertionPoint 比较规则先 X从左到右X相同再 Y从上到下即Y值大的在前If (pos1(1) pos2(1)) Or (pos1(1) pos2(1) And pos1(0) pos2(0)) Then 交换位置Set tempBlk sortedBlocksA3(i)Set sortedBlocksA3(i) sortedBlocksA3(j)Set sortedBlocksA3(j) tempBlkEnd IfNext jNext i 7(3)(2) 对A3图纸建立布局For i UBound(sortedBlocksA3) To 1 Step -1Set blockRef sortedBlocksA3(i) 调用你的处理函数CountA3 CountA3 1CreateLayoutWithMargins blockRefNextElseIf TotalA3Num 1 ThenSet blockRef sortedBlocksA3(1) 调用你的处理函数CountA3 CountA3 1CreateLayoutWithMargins blockRefEnd If 7(4)(1) 对A4图纸排序 冒泡排序按 X 坐标升序X相同则按 Y 降序If TotalA4Num 1 ThenFor i 1 To UBound(sortedBlocksA4) - 1For j i 1 To UBound(sortedBlocksA4)pos1 sortedBlocksA4(i).InsertionPointpos2 sortedBlocksA4(j).InsertionPoint 比较规则先 X从左到右X相同再 Y从上到下即Y值大的在前If (pos1(1) pos2(1)) Or (pos1(1) pos2(1) And pos1(0) pos2(0)) Then 交换位置Set tempBlk sortedBlocksA4(i)Set sortedBlocksA4(i) sortedBlocksA4(j)Set sortedBlocksA4(j) tempBlkEnd IfNext jNext i 7(4)(2) 对A4图纸建立布局For i UBound(sortedBlocksA4) To 1 Step -1Set blockRef sortedBlocksA4(i) 调用你的处理函数CountA4 CountA4 1CreateLayoutWithMargins blockRefNextElseIf TotalA4Num 1 ThenSet blockRef sortedBlocksA4(1) 调用你的处理函数CountA4 CountA4 1CreateLayoutWithMargins blockRefEnd If//******* 7.分别对A1,A2,A3,A4的图纸按位置排序先从左到右 X再从上到下 Y*******//【结束】 5. 删除临时选择集ss.DeleteOn Error Resume NextThisDrawing.Layouts(布局1).DeleteThisDrawing.Layouts(Layout1).DeleteThisDrawing.Layouts(布局2).DeleteThisDrawing.Layouts(Layout2).DeleteOn Error GoTo 0If CountA3 CountA4 0 ThenMsgBox 选中的对象中没有【打印定位弧】块ElseMsgBox 共找到并处理了 CountA1 CountA2 CountA3 CountA4 个块。End If Application.DisplayAlerts TrueEnd SubPrivate Sub CreateLayoutWithMargins(blockRef As AcadBlockReference)Dim blockDef As AcadBlockDim ent As AcadEntityDim insertPt As VariantDim a As Double, b As DoubleDim R As DoubleDim rotAngle As DoubleDim rotDeg As DoubleDim isLandscape As BooleanDim NewLayout As AcadLayoutDim NewViewport As AcadPViewportDim paperWidth As Double, paperHeight As DoubleDim margin As DoubleDim vpWidth As Double, vpHeight As DoubleDim vpCenter(0 To 2) As DoubleDim delEnt As AcadEntityDim pViewport As AcadPViewportDim deleteCount As IntegerDim layoutName As StringDim scaleRatio As DoubleDim viewCenter(0 To 2) As DoubleDim viewHeight As Double 1. 获取块参数insertPt blockRef.InsertionPointa insertPt(0)b insertPt(1)rotAngle blockRef.RotationrotDeg rotAngle * 180 / 3.14159265358979rotDeg Round(rotDeg, 0)Debug.Print rotDeg 判断布局方向0°或180°为横向否则为纵向If Abs(rotDeg - 0) 45 Or Abs(rotDeg - 180) 45 Or Abs(rotDeg 180) 45 ThenblockRef.Rotation 0isLandscape True ElseIf Abs(rotDeg - 90) 45 Or Abs(rotDeg 90) 45 Or Abs(rotDeg - 270) 45 ThenblockRef.Rotation Atn(1) * 2isLandscape False End If 获取半径Set blockDef ThisDrawing.Blocks(blockRef.Name)For Each ent In blockDefIf TypeOf ent Is AcadArc ThenDebug.Assert blockRef.XScaleFactor 1R ent.Radius * blockRef.XScaleFactorDebug.Print ent.Radius RExit ForEnd IfNext entIf R 0 ThenMsgBox 块【 blockRef.Name 】中未找到圆弧GoTo line1End If 2. 创建新布局以块名位置命名便于识别Select Case blockRef.NameCase A1打印定位弧layoutName CountA1 - A1 TransferringTexValueCase A2打印定位弧layoutName CountA2 - A2 TransferringTexValueCase A3打印定位弧layoutName CountA3 - A3 TransferringTexValueCase A4打印定位弧layoutName CountA4 - A4 TransferringTexValueEnd SelectOn Error Resume NextThisDrawing.Layouts(layoutName).DeleteOn Error GoTo 0Set NewLayout ThisDrawing.Layouts.Add(layoutName) 3. 设置布局方向先设置方向再获取纸张尺寸ThisDrawing.ActiveLayout NewLayoutThisDrawing.ActiveSpace acPaperSpace 设置打印机NewLayout.ConfigName TransferringComB1ValueDim XSheet As Single 设置半个纸张的横向长度Dim YSheet As Single 设置半个纸张的纵向长度 根据块旋转角度设置布局方向和打印纸张Dim ratio1 As SingleDim ratio2 As Singleratio1 0.81651046586ratio2 0.57733063243真实打印机都会设置页边距我们总体设置一个大约值5Dim MarginVal1 As SingleDim MarginVal2 As SingleIf TransferringComB1Value Microsoft Print to PDF Then 声明接收边距的变量Dim MarginLowerLeft As Variant, MarginUpperRight As Variant 调用方法获取当前活动布局的页边距ThisDrawing.ActiveLayout.GetPaperMargins MarginLowerLeft, MarginUpperRightMarginVal1 0 - MarginLowerLeft(0) - MarginLowerLeft(1)MarginVal2 0 - MarginUpperRight(0) - MarginUpperRight(1)End IfIf isLandscape ThenNewLayout.PlotRotation ac90degrees 横向If blockRef.Name A4打印定位弧 ThenpaperWidth 297 MarginVal1paperHeight 210 MarginVal2On Error Resume NextNewLayout.CanonicalMediaName A4If Err.Number 0 Then MsgBox 此打印机无法打印A4图纸!, vbExclamation: ThisDrawing.Layouts(layoutName).Delete: EndOn Error GoTo 0ElseIf blockRef.Name A3打印定位弧 ThenpaperWidth 420 MarginVal1paperHeight 297 MarginVal2On Error Resume NextNewLayout.CanonicalMediaName A3If Err.Number 0 Then MsgBox 此打印机无法打印A3图纸!, vbExclamation: ThisDrawing.Layouts(layoutName).Delete: EndOn Error GoTo 0ElseIf blockRef.Name A2打印定位弧 ThenpaperWidth 594 MarginVal1paperHeight 420 MarginVal2On Error Resume NextNewLayout.CanonicalMediaName A2If Err.Number 0 Then MsgBox 此打印机无法打印A2图纸!, vbExclamation: ThisDrawing.Layouts(layoutName).Delete: EndOn Error GoTo 0ElseIf blockRef.Name A1打印定位弧 ThenpaperWidth 841 MarginVal1paperHeight 594 MarginVal2On Error Resume NextNewLayout.CanonicalMediaName A1If Err.Number 0 Then MsgBox 此打印机无法打印A1图纸!, vbExclamation: ThisDrawing.Layouts(layoutName).Delete: EndOn Error GoTo 0End IfXSheet ratio1 * R 0.08YSheet ratio2 * R 0.08ElseNewLayout.PlotRotation ac0degrees 纵向If blockRef.Name A4打印定位弧 ThenpaperWidth 210 MarginVal1paperHeight 297 MarginVal2NewLayout.CanonicalMediaName A4ElseIf blockRef.Name A3打印定位弧 ThenpaperWidth 297 MarginVal1paperHeight 420 MarginVal2NewLayout.CanonicalMediaName A3ElseIf blockRef.Name A2打印定位弧 ThenpaperWidth 420 MarginVal1paperHeight 595NewLayout.CanonicalMediaName A2ElseIf blockRef.Name A1打印定位弧 ThenpaperWidth 595 MarginVal1paperHeight 841 MarginVal2NewLayout.CanonicalMediaName A1End IfXSheet ratio1 * R 0.06YSheet ratio2 * R 0.06End If 10. 刷新显示 ThisDrawing.Regen acActiveViewportNewLayout.RefreshPlotDeviceInfo 4. 删除布局中所有现有的视口deleteCount 0For Each delEnt In ThisDrawing.PaperSpaceIf TypeOf delEnt Is AcadPViewport ThenSet pViewport delEntpViewport.DeletedeleteCount deleteCount 1End IfNext delEnt 5. 获取可打印区域的尺寸 6. 计算视口尺寸四边各缩进 2mmmargin 1vpWidth paperWidth - 2 * margin * 1.4143vpHeight paperHeight - 2 * margin 7. 计算视口中心点vpCenter(0) paperWidth / 2vpCenter(1) paperHeight / 2vpCenter(2) 0 8. 创建浮动视口Set NewViewport ThisDrawing.PaperSpace.AddPViewport(vpCenter, vpWidth, vpHeight)NewViewport.Display True 10. 刷新显示ThisDrawing.Regen acActiveViewport 9. 【核心】设置视口显示内容定位到块的窗口范围 计算视图中心点在模型空间中的坐标 中心点: (a, b)viewCenter(0) aviewCenter(1) bviewCenter(2) 0 切换到模型空间设置视口视图ThisDrawing.MSpace TrueThisDrawing.ActivePViewport NewViewport 设置视口中心点和缩放比例Dim extMin(0 To 2) As DoubleDim extMax(0 To 2) As DoubleIf isLandscape ThenextMin(0) a - XSheetextMin(1) b - YSheetextMin(2) 0extMax(0) a XSheetextMax(1) b YSheetextMax(2) 0ElseextMin(0) a - YSheetextMin(1) b - XSheetextMin(2) 0extMax(0) a YSheetextMax(1) b XSheetextMax(2) 0End If 使用 ZoomWindow 定位到窗口范围ThisDrawing.Application.ZoomWindow extMin, extMax 切回图纸空间ThisDrawing.MSpace False锁定视口放置误操作NewViewport.DisplayLocked TrueNewLayout.PlotWithLineweights TransferringCheckValue 10. 刷新显示ThisDrawing.Regen acActiveViewport 11. 输出结果Dim directionMsg As StringIf isLandscape ThendirectionMsg 横向块旋转 rotDeg °ElsedirectionMsg 纵向块旋转 rotDeg °End Ifline1:End Sub注代码中可以通过修改添加其它类型的图纸这儿只包含四种图纸A1,A2,A3,A4三. 建立需要读取的块比如如下图建立名为“A3打印定位弧”的块其它的类似。四.自动加载AUTOCAD 的VBA工程的方法CAD启动时自动加载dll、dvb文件方法_dvb文件怎么用cad打开-CSDN博客