CAD-VBA批量打印程序

CAD/VBA批量打印打印图纸，不折不扣的体力活。最多一次打了600多张图，打印机都因“体力不支”中途休息了几次，如果不是用程序批打，估计我也得累个半死。下面贴出打印过程的代码，加个for循环就可以批打了。简单说明一下打印函数PrinterName-打印机名称Styles-样式表名称MediaName-纸张大小Copies-打印份数AutoMedia-自动纸张开关AutoRotate-自动旋转，纵向/横向AutoClose-打印完毕关闭文档AutoFrame-自动判断图框，主要针对图框为块的情形打印过程并没有提供全部的AUTOCAD打印选项，因为我一般用不到，比如"打印偏移"、”打印到文件“我从来不用的，如果需要可以添加进去。程序会根据指定块名查找图框，也可以根据块的纵横比例自动判断是否为图框，然后按块打印，一张图纸中允许有多个图框；对于编组(Group)形式的图框，指定编组名即可如果没有找到任何图框块或编组时，按图纸范围打印另外，打印时会先预览，然后由用户选择是否打印，避免打错。［代码如下］SubQuickPlot()CallPlotFunction("SHARPAR-M256","","A3",1,True,True,False,True)EndSubSubPlot2PDF()CallPlotFunction("pdfFactoryPro","acad.ctb","",1,True,True,False,True)EndSubSubPlotA4()CallPlotFunction("SHARPAR-M256","acad.ctb","A4",1,False,True,False,True)EndSub‘快速打印/批量打印PublicSubPlotFunction(PrinterNameAsString,StylesAsString,MediaNameAsString,CopiesAsInteger,_AutoMediaAsBoolean,AutoRotateAsBoolean,AutoCloseAsBoolean,AutoFrameAsBoolean)OnErrorResumeNextDimptMinAsVariant,ptMaxAsVariantDimEntAsAcadEntityDimPlotCountAsIntegerSetobjDoc=ThisDrawing.Application.ActiveDocumentSetobjLayout=objDoc.Layouts.Item("Model")word可自由复制编辑SetobjPlot=objDoc.PlotThisDrawing.Application.ZoomExtents,设置打印机IfNotTrim(PrinterName)=""ThenobjLayout.ConfigName=PrinterNameElseExitSubEndIf,设置打印样式表IfNotTrim(Styles)=""ThenobjLayout.StyleSheet=StylesElseobjLayout.StyleSheet="acad.ctb"EndIf,设置图纸尺寸IfAutoMediaThenobjLayout.CanonicalMediaName="A3"ElseIfNotTrim(MediaName)=""ThenobjLayout.CanonicalMediaName=MediaNameElseobjLayout.CanonicalMediaName="A3"EndIfEndIf,设置图纸单位objLayout.PaperUnits=acMillimeters'objLayout.PaperUnits=acInches,设置默认图纸打印方向'objLayout.PlotRotation=ac0degrees'纵向'objLayout.PlotRotation=ac180degreesobjLayout.PlotRotation=ac90degrees'横向'objLayout.PlotRotation=ac270degrees,设置图纸打印比例objLayout.StandardScale=acScaleToFitobjLayout.UseStandardScale=True'使用标准打印比例'objLayout.UseStandardScale=False使用自定义打印比例’设置自定义打印比例word可自由复制编辑'objLayout.SetCustomScaletxtNumerator.Value,txtDenominator.Value,设置图纸是否居中打印objLayout.CenterPlot=True’打印时使用图形文件中的线宽objLayout.PlotWithLineweights=True,设置是否应用打印样式objLayout.PlotWithPlotStyles=True’打印时隐藏图纸空间对象objLayout.PlotHidden=False,设置图纸打印份数IfCopies>=1ThenobjPlot.NumberOfCopies=CInt(Copies)ElseobjPlot.NumberOfCopies=1EndIf,将打印错误报告切换为静默错误模式，以便不间断地执行打印任务objPlot.QuietErrorMode=True,重新生成当前图形objDoc.RegenacAllViewports,设置前台打印，使打印任务按打印顺序依次发送到打印机objDoc.SetVariable"BACKGROUNDPLOT",0PlotCount=0'打印计数ForEachEntInobjDoc.ModelSpaceIfTypeOfEntIsAcadBlockReferenceThenIfIsFrame(Ent,AutoFrame)=TrueAndobjDoc.Blocks(Ent.Name).count>0ThenEnt.GetBoundingBoxptMin,ptMaxDebug.PrintEnt.Name&"--"&objDoc.Blocks(Ent.Name).count'将三维点转化为二维点坐标ReDimPreserveptMin(0To1)ReDimPreserveptMax(0To1),设置打印窗口ThisDrawing.ActiveLayout.SetWindowToPlotptMin,ptMaxword可自由复制编辑objLayout.PlotType=acWindowIfAbs(ptMax(0)-ptMin(0))<Abs(ptMax(1)-ptMin(1))ThenIfAutoMediaThenobjLayout.CanonicalMediaName="A4"IfAutoRotateThenobjLayout.PlotRotation=ac0degreesEndIf,完全预览并提示打印objPlot.DisplayPlotPreviewacFullPreviewUserSel=MsgBox("是否打印预览？"&Chr(13)&Chr(13)&"打印到："&objLayout.ConfigName&_"大小："&objLayout.CanonicalMediaName&"方式：acWindow("&objLayout.PlotType&")"&_Chr(13)&Chr(13)&"选择[取消]退出程序！'vbYesNoCancel,"打印选项")IfUserSel=vbYesThenobjPlot.PlotToDeviceobjLayout.ConfigNamePlotCount=PlotCount+1ElseIfUserSel=vbCancelThenExitForEndIfEndIfEndIfNextEnt,图框为编组(Group)对象时DimFrmGrpAsAcadGroupDimTptMin,TptMaxAsVariant,按编组名称查找图框编组对象ForEachFrmGrpInThisDrawing.GroupsIfIsFrame(FrmGrp,False)AndFrmGrp.count>0ThenDebug.PrintFrmGrp.Name&"[Items]:"&FrmGrp.count&"----group",得到图框边界点坐标FrmGrp.Item(0).GetBoundingBoxptMin,ptMaxFori=1ToFrmGrp.count-1FrmGrp.Item(i).GetBoundingBoxTptMin,TptMaxReDimPreserveTptMin(0To1)ReDimPreserveTptMax(0To1)Forj=0To1IfTptMin(j)<ptMin(j)ThenptMin(j)=TptMin(j)EndIfIfTptMax(j)>ptMax(j)ThenptMax(j)=TptMax(j)word可自由复制编辑EndIfNextji=i+1Next,将三维点转化为二维点坐标ReDimPreserveptMin(0To1)ReDimPreserveptMax(0To1),设置打印窗口ThisDrawing.ActiveLayout.SetWindowToPlotptMin,ptMaxobjLayout.PlotType=acWindowIfAbs(ptMax(0)-ptMin(0))<Abs(ptMax(1)-ptMin(1))ThenIfAutoMediaThenobjLayout.CanonicalMediaName="A4"IfAutoRotateThenobjLayout.PlotRotation=ac0degreesEndIf,完全预览并提示打印objPlot.DisplayPlotPreviewacFullPreviewUserSel=MsgBox("是否打印预览？"&Chr(13)&Chr(13)&"打印到："&objLayout.ConfigName&_"大小："&objLayout.CanonicalMediaName&"方式：acWindow("&objLayout.PlotType&")"&_Chr(13)&Chr(13)&"选择［取消］退出程序！",vbYesNoCancel,"打印选项")IfUserSel=vbYesThenPlotCount=PlotCount+1objPlot.PlotToDeviceobjLayout.ConfigNameElseIfUserSel=vbCancelThenExitForEndIfEndIfNextFrmGrp,没有找到图框时按范围打印IfPlotCount=0AndobjDoc.ModelSpace.count>0ThenptMax=ThisDrawing.GetVariable("EXTMAX")ptMin=ThisDrawing.GetVariable("EXTMIN"),图形范围内无实体则退出IfptMax(0)=ptMin(0)OrptMax(1)=ptMin(1)ThenExitSubEndIf,设置范围打印word可自由复制编辑objLayout.PlotType=acExtents,对纵向的图纸设置IfAbs(ptMax(0)-ptMin(0))<Abs(ptMax(1)-ptMin(1))ThenIfAutoMediaThenobjLayout.CanonicalMediaName="A4"IfAutoRotateThenobjLayout.PlotRotation=ac0degreesEndIf,完全预览并提示打印objPlot.DisplayPlotPreviewacFullPreviewUserSel=MsgBox("是否打印预览？"&Chr(13)&Chr(13)&"打印到："&objLayout.ConfigName&_"大小："&objLayout.CanonicalMediaName&"方式：acExtents("&objLayout.PlotType&")"&_Chr(13)&Chr(13)&"选择［取消］退出程序！",vbYesNoCancel,"打印选项")IfUserSel=vbYesThenobjPlot.PlotToDeviceobjLayout.ConfigNameElseIfUserSel=vbCancelThenExitSubEndIfEndIf,关闭文档False为不保存修改IfAutoCloseThenobjDoc.CloseFalse,ThisDrawing.NameEndSubPublicFunctionIsFrame(entobjAsObject,AutoModeAsBoolean)AsBoolean判断是否为图框OnErrorResumeNextIsFrame=FalseDimiAsIntegerDimFrmNameListAsVariantFrmNameList="blkFrame,A1,A2,A3,A4,PC_PAPER_DIC"'图框块、编组名列表FrmNameList=Split(FrmNameList,",")Fori=0ToUBound(FrmNameList)Ifentobj.Name=FrmNameList(i)ThenIsFrame=TrueExitForEndIfNext块名不符时由大小比例判断是否为图框(可能会误判，不过几率不高)IfIsFrame=FalseAndAutoModeAndentobj.ObjectName="AcDbBlockReference"Thenentobj.GetBoundingBoxptMin,ptMaxword可自由复制编辑

Debug.PrintptMin(0)&"--"&ptMax(0)IfAbs((ptMax(1)-ptMin(1))/(ptMax(0)-ptMin(0))-1.414)<0.01OrAbs((ptMax(1)-ptMin(1))/(ptMax(0)-ptMin(0))-0.707)<0.01ThenIsFrame=TrueEndIfEndIfEndFunctionword可自由复制编辑FunctionSNA11x17()DimobjPSAsAcadPlotConfigurationSetobjPS=ThisDrawing.PlotConfigurations.Add(''SNA-AZTU-11x17〃,False)objPS.ConfigName=“\\SERVER2\SAVIN4035PCL6”objPS.CanonicalMediaName='Tabloid”objPS.CenterPlot=TrueobjPS.PaperUnits=acInchesobjPS.PlotHidden=FalseobjPS.PlotRotation=ac90degreesobjPS.PlotType=acExtentsobjPS.PlotViewportBorders=FalseobjPS.PlotViewportsFirst=TrueobjPS.PlotWithLineweights=TrueobjPS.PlotWithPlotStyles=TrueobjPS.ScaleLineweights=FalseobjPS.ShowPlotStyles=FalseobjPS.StandardScale=acScaleToFitobjPS.StyleSheet='SNA-11X17.ctb”objPS.UseStandardScale=TruePublicSubSetupAndPlot(ByRefPlotterAsString,CTBAsString,SIZEAsString,PSCALEAsString,ROTAsString)DimLayoutAsAcadLayoutOnErrorGoToErr_ControlSetLayout=ThisDrawing.ActiveLayoutLayout.RefreshPlotDeviceInfoLayout.ConfigName=Plotter'CALLPLOTTERLayout.PLOTTYPE=acExtentsLayout.PlotRotation=ROT'CALLROTATIONLayout.StyleSheet=CTB'CALLCTBFILELayout.PlotWithPlotStyles=TrueLayout.CanonicalMediaName=SIZE'CALLSIZELayout.PaperUnits=acInchesLayout.StandardScale=PSCALE'CALLPSCALELayout.ShowPlotStyles=FalseThisDrawing.Plot.NumberOfCopies=1Layout.CenterPlot=TrueLayout.ScaleLineweights=Falseword可自由复制编辑Layout.RefreshPlotDeviceInfoThisDrawing.RegenacAllViewportsZoomExtentsSetLayout=NothingThisDrawing.SaveExit_Here:ExitSubErr_Control:SelectCaseErr.NumberCase"-2145320861"MsgBox"UnabletoSaveDrawing-"&Err.DescriptionCase"-2145386493"MsgBox"DrawingissetupforNamedPlotStyles."&(Chr(13))&(Chr(13))&"RunCONVERTPSTYLEScommand",vbCritical,"ChangePlotStyle"CaseElseMsgBox"UnknownError"&Err.NumberEndSelectEndSubSubPcsMM()DimpCAsAcadPlotConfigurationDimPCsAsAcadPlotConfigurationsDimoLayoutAsAcadLayoutDimoLayoutsAsAcadLayoutsDimPlotOrig(1)AsDoubleDimOrigSetoLayouts=ThisDrawing.LayoutsSetPCs=ThisDrawing.PlotConfigurationsSetoLayout=ThisDrawing.PaperSpace.LayoutPlotOrig(0)=18.542:PlotOrig(1)=12.192SetpC=PCs.Add("22x34final",False)WithpC.PlotType=acExtents.CanonicalMediaName="User1639".CenterPlot=True.ConfigName="\\DESIGNSERVER\HPDJ"word可自由复制编辑.PlotOrigin=PlotOrig.PlotRotation=ac180degrees.StandardScale=ac1_1EndWithPcTyppCoLayout.CopyFrompCPlotOrig(0)=19.01:PlotOrig(1)=12.68SetpC=PCs.Add("22x34draft",False)WithpC.PlotType=acLayout.CanonicalMediaName="User1639”.ConfigName="\\DESIGNSERVER\HPDRAFT”.PaperUnits=acMillimeters.PlotOrigin=PlotOrig.PlotRotation=ac180degrees.StandardScale=ac1_1EndWithPcTyppCoLayout.CopyFrompCPlotOrig(0)=1.31:PlotOrig(1)=4.48SetpC=PCs.Add("11x17half",False)WithpC.PlotType=acExtents.CenterPlot=True.ConfigName="\\designserver\KONICA”.PaperUnits=acMillimeters.PlotOrigin=PlotOrig.PlotRotation=ac270degrees.StandardScale=ac1_2'.CanonicalMediaName="User288”.CanonicalMediaName="Tabloid"EndWithPcTyppCModelSpaceSetoLayout=ThisDrawing.ModelSpace.Layoutword可自由复制编辑SetpC=PCs.Add("22x34-model”,True)WithpC.ConfigName="\\DESIGNSERVER\HPDJ”.StandardS