CAD-VBA批量打印程序

1、CAD/VBA批量打印 打印圖紙，不折不扣的體力活。最多一次打了600多張圖，打印機(jī)都因體力不支中途休息了幾次，如果不是用程序批打，估計(jì)我也得累個(gè)半死。 下面貼出打印過程的代碼，加個(gè)for循環(huán)就可以批打了。簡(jiǎn)單說明一下打印函數(shù) PrinterName - 打印機(jī)名稱 Styles - 樣式表名稱 MediaName - 紙張大小 Copies - 打印份數(shù) AutoMedia - 自動(dòng)紙張開關(guān) AutoRotate - 自動(dòng)旋轉(zhuǎn),縱向/橫向 AutoClose - 打印完畢關(guān)閉文檔 AutoFrame - 自動(dòng)判斷圖框，主要針對(duì)圖框?yàn)閴K的情形 打印過程并沒有提供全部的AUTO CAD打印選項(xiàng)，

2、因?yàn)槲乙话阌貌坏?，比如打印偏移、打印到文件我從來不用的，如果需要可以添加進(jìn)去。 程序會(huì)根據(jù)指定塊名查找圖框，也可以根據(jù)塊的縱橫比例自動(dòng)判斷是否為圖框，然后按塊打印，一張圖紙中允許有多個(gè)圖框； 對(duì)于編組(Group)形式的圖框，指定編組名即可 如果沒有找到任何圖框塊或編組時(shí)，按圖紙范圍打印 另外，打印時(shí)會(huì)先預(yù)覽，然后由用戶選擇是否打印，避免打錯(cuò)。代碼如下 Sub QuickPlot() Call PlotFunction(SHARP AR-M256, , A3, 1, True, True, False, True) End Sub Sub Plot2PDF() Call PlotFunctio

3、n(pdfFactory Pro, acad.ctb, , 1, True, True, False, True) End Sub Sub PlotA4() Call PlotFunction(SHARP AR-M256, acad.ctb, A4, 1, False, True, False, True) End Sub 快速打印/批量打印 Public Sub PlotFunction(PrinterName As String, Styles As String, MediaName As String, Copies As Integer, _ AutoMedia As Boolean

4、, AutoRotate As Boolean, AutoClose As Boolean, AutoFrame As Boolean) On Error Resume Next Dim ptMin As Variant, ptMax As Variant Dim Ent As AcadEntity Dim PlotCount As Integer Set objDoc = ThisDrawing.Application.ActiveDocument Set objLayout = objDoc.Layouts.Item(Model) Set objPlot = objDoc.Plot Thi

5、sDrawing.Application.ZoomExtents 設(shè)置打印機(jī) If Not Trim(PrinterName) = Then objLayout.ConfigName = PrinterName Else Exit Sub End If 設(shè)置打印樣式表 If Not Trim(Styles) = Then objLayout.StyleSheet = Styles Else objLayout.StyleSheet = acad.ctb End If 設(shè)置圖紙尺寸 If AutoMedia Then objLayout.CanonicalMediaName = A3 Else

6、If Not Trim(MediaName) = Then objLayout.CanonicalMediaName = MediaName Else objLayout.CanonicalMediaName = A3 End If End If 設(shè)置圖紙單位 objLayout.PaperUnits = acMillimeters objLayout.PaperUnits = acInches 設(shè)置默認(rèn)圖紙打印方向 objLayout.PlotRotation = ac0degrees 縱向 objLayout.PlotRotation = ac180degrees objLayout.Pl

7、otRotation = ac90degrees 橫向 objLayout.PlotRotation = ac270degrees 設(shè)置圖紙打印比例 objLayout.StandardScale = acScaleToFit objLayout.UseStandardScale = True使用標(biāo)準(zhǔn)打印比例 objLayout.UseStandardScale = False 使用自定義打印比例 設(shè)置自定義打印比例 objLayout.SetCustomScale txtNumerator.Value, txtDenominator.Value 設(shè)置圖紙是否居中打印 objLayout.Ce

8、nterPlot = True 打印時(shí)使用圖形文件中的線寬 objLayout.PlotWithLineweights = True 設(shè)置是否應(yīng)用打印樣式 objLayout.PlotWithPlotStyles = True 打印時(shí)隱藏圖紙空間對(duì)象 objLayout.PlotHidden = False 設(shè)置圖紙打印份數(shù) If Copies = 1 Then objPlot.NumberOfCopies = CInt(Copies) Else objPlot.NumberOfCopies = 1 End If 將打印錯(cuò)誤報(bào)告切換為靜默錯(cuò)誤模式，以便不間斷地執(zhí)行打印任務(wù) objPlot.Qu

9、ietErrorMode = True 重新生成當(dāng)前圖形 objDoc.Regen acAllViewports 設(shè)置前臺(tái)打印，使打印任務(wù)按打印順序依次發(fā)送到打印機(jī) objDoc.SetVariable BACKGROUNDPLOT, 0 PlotCount = 0打印計(jì)數(shù) For Each Ent In objDoc.ModelSpace If TypeOf Ent Is AcadBlockReference Then If IsFrame(Ent, AutoFrame) = True And objDoc.Blocks(Ent.Name).count 0 Then Ent.GetBound

10、ingBox ptMin, ptMax Debug.Print Ent.Name & - & objDoc.Blocks(Ent.Name).count 將三維點(diǎn)轉(zhuǎn)化為二維點(diǎn)坐標(biāo) ReDim Preserve ptMin(0 To 1) ReDim Preserve ptMax(0 To 1) 設(shè)置打印窗口 ThisDrawing.ActiveLayout.SetWindowToPlot ptMin, ptMax objLayout.PlotType = acWindow If Abs(ptMax(0) - ptMin(0) 0 Then Debug.Print FrmGrp.Name & I

11、tems: & FrmGrp.count & -group 得到圖框邊界點(diǎn)坐標(biāo) FrmGrp.Item(0).GetBoundingBox ptMin, ptMax For i = 1 To FrmGrp.count - 1 FrmGrp.Item(i).GetBoundingBox TptMin, TptMax ReDim Preserve TptMin(0 To 1) ReDim Preserve TptMax(0 To 1) For j = 0 To 1 If TptMin(j) ptMax(j) Then ptMax(j) = TptMax(j) End If Next j i = i

12、 + 1 Next 將三維點(diǎn)轉(zhuǎn)化為二維點(diǎn)坐標(biāo) ReDim Preserve ptMin(0 To 1) ReDim Preserve ptMax(0 To 1) 設(shè)置打印窗口 ThisDrawing.ActiveLayout.SetWindowToPlot ptMin, ptMax objLayout.PlotType = acWindow If Abs(ptMax(0) - ptMin(0) 0 Then ptMax = ThisDrawing.GetVariable(EXTMAX) ptMin = ThisDrawing.GetVariable(EXTMIN) 圖形范圍內(nèi)無實(shí)體則退出 If

13、 ptMax(0) = ptMin(0) Or ptMax(1) = ptMin(1) Then Exit Sub End If 設(shè)置范圍打印 objLayout.PlotType = acExtents 對(duì)縱向的圖紙?jiān)O(shè)置 If Abs(ptMax(0) - ptMin(0) Abs(ptMax(1) - ptMin(1) Then If AutoMedia Then objLayout.CanonicalMediaName = A4 If AutoRotate Then objLayout.PlotRotation = ac0degrees End If 完全預(yù)覽并提示打印 objPlot.

14、DisplayPlotPreview acFullPreview UserSel = MsgBox(是否打印預(yù)覽？ & Chr(13) & Chr(13) & 打印到： & objLayout.ConfigName & _ 大?。?& objLayout.CanonicalMediaName & 方式：acExtents( & objLayout.PlotType & ) & _ Chr(13) & Chr(13) & 選擇取消退出程序！, vbYesNoCancel, 打印選項(xiàng)) If UserSel = vbYes Then objPlot.PlotToDevice objLayout.C

15、onfigName ElseIf UserSel = vbCancel Then Exit Sub End If End If 關(guān)閉文檔 False 為不保存修改 If AutoClose Then objDoc.Close False, ThisDrawing.Name End Sub Public Function IsFrame(entobj As Object, AutoMode As Boolean) As Boolean判斷是否為圖框 On Error Resume Next IsFrame = False Dim i As Integer Dim FrmNameList As V

16、ariant FrmNameList = blkFrame,A1,A2,A3,A4,PC_PAPER_DIC 圖框塊、編組名列表 FrmNameList = Split(FrmNameList, ,) For i = 0 To UBound(FrmNameList) If entobj.Name = FrmNameList(i) Then IsFrame = True Exit For End If Next 塊名不符時(shí)由大小比例判斷是否為圖框(可能會(huì)誤判,不過幾率不高) If IsFrame = False And AutoMode And entobj.ObjectName = AcDbB

17、lockReference Then entobj.GetBoundingBox ptMin, ptMax Debug.Print ptMin(0) & - & ptMax(0) If Abs(ptMax(1) - ptMin(1) / (ptMax(0) - ptMin(0) - 1.414) 0.01 Or Abs(ptMax(1) - ptMin(1) / (ptMax(0) - ptMin(0) - 0.707) 0.01 Then IsFrame = True End If End If End Function為了您的安全，請(qǐng)只打開來源可靠的網(wǎng)址 打開網(wǎng)站取消一Function S

18、NA11x17()Dim objPS As AcadPlotConfiguration Set objPS = ThisDrawing.PlotConfigurations.Add(“SNA-AZTU-11x17”, False) objPS.ConfigName = “SERVER2SAVIN 4035 PCL 6” objPS.CanonicalMediaName = “Tabloid” objPS.CenterPlot = True objPS.PaperUnits = acInches objPS.PlotHidden = False objPS.PlotRotation = ac90

19、degrees objPS.PlotType = acExtents objPS.PlotViewportBorders = False objPS.PlotViewportsFirst = True objPS.PlotWithLineweights = True objPS.PlotWithPlotStyles = True objPS.ScaleLineweights = False objPS.ShowPlotStyles = False objPS.StandardScale = acScaleToFit objPS.StyleSheet = “SNA-11X17.ctb” objP

20、S.UseStandardScale = True二Public Sub SetupAndPlot(ByRef Plotter As String, CTB As String, SIZE As String, PSCALE As String, ROT As String) Dim Layout As AcadLayout On Error GoTo Err_Control Set Layout = ThisDrawing.ActiveLayout Layout.RefreshPlotDeviceInfo Layout.ConfigName = Plotter CALL PLOTTER La

21、yout.PLOTTYPE = acExtents Layout.PlotRotation = ROT CALL ROTATION Layout.StyleSheet = CTB CALL CTB FILE Layout.PlotWithPlotStyles = True Layout.CanonicalMediaName = SIZE CALL SIZE Layout.PaperUnits = acInches Layout.StandardScale = PSCALE CALL PSCALE Layout.ShowPlotStyles = False ThisDrawing.Plot.Nu

22、mberOfCopies = 1 Layout.CenterPlot = True Layout.ScaleLineweights = False Layout.RefreshPlotDeviceInfo ThisDrawing.Regen acAllViewports ZoomExtents Set Layout = Nothing ThisDrawing.SaveExit_Here: Exit SubErr_Control: Select Case Err.Number Case - MsgBox Unable to Save Drawing- & Err.Description Case

23、 - MsgBox Drawing is setup for Named Plot Styles. & (Chr(13) & (Chr(13) & Run CONVERTPSTYLES command, vbCritical, Change Plot Style Case Else MsgBox Unknown Error & Err.Number End SelectEnd Sub三Sub PcsMM() Dim pC As AcadPlotConfiguration Dim PCs As AcadPlotConfigurations Dim oLayout As AcadLayout Di

24、m oLayouts As AcadLayouts Dim PlotOrig(1) As Double Dim Orig Set oLayouts = ThisDrawing.Layouts Set PCs = ThisDrawing.PlotConfigurations Set oLayout = ThisDrawing.PaperSpace.Layout PlotOrig(0) = 18.542: PlotOrig(1) = 12.192 Set pC = PCs.Add(22x34final, False) With pC .PlotType = acExtents .Canonical

25、MediaName = User1639 .CenterPlot = True .ConfigName = DESIGNSERVERHPDJ .PlotOrigin = PlotOrig .PlotRotation = ac180degrees .StandardScale = ac1_1 End With PcTyp pC oLayout.CopyFrom pC PlotOrig(0) = 19.01: PlotOrig(1) = 12.68 Set pC = PCs.Add(22x34draft, False) With pC .PlotType = acLayout .Canonical

26、MediaName = User1639 .ConfigName = DESIGNSERVERHPDRAFT .PaperUnits = acMillimeters .PlotOrigin = PlotOrig .PlotRotation = ac180degrees .StandardScale = ac1_1 End With PcTyp pC oLayout.CopyFrom pC PlotOrig(0) = 1.31: PlotOrig(1) = 4.48 Set pC = PCs.Add(11x17half, False) With pC .PlotType = acExtents

27、.CenterPlot = True .ConfigName = designserverKONICA .PaperUnits = acMillimeters .PlotOrigin = PlotOrig .PlotRotation = ac270degrees .StandardScale = ac1_2 .CanonicalMediaName = User288 .CanonicalMediaName = Tabloid End With PcTyp pC ModelSpace Set oLayout = ThisDrawing.ModelSpace.Layout Set pC = PCs.Add(22x34-model, True) With pC .ConfigName = DESIGNSERVERHPDJ .StandardScale = ac1_1 .CanonicalMediaName = User1639 .PlotType = acExtents .PlotRotation = ac180degrees End With PCAdds pC Se