CAD-VBA批量打印程序

        打印图纸，不折不扣的体力活。最多一次打了600多张图，打印机都因"体力不支"中途休息了几次，如果不是用程序批打，估计我也得累个半死。

      下面贴出打印过程的代码，加个for循环就可以批打了。简单说明一下打印函数

             PrinterName - 打印机名称

             Styles - 样式表名称

            MediaName - 纸张大小

             Copies - 打印份数

             AutoMedia - 自动纸张开关

             AutoRotate - 自动旋转,纵向/横向

             AutoClose - 打印完毕关闭文档

             AutoFrame - 自动判断图框，主要针对图框为块的情形

       打印过程并没有提供全部的AUTO CAD打印选项，因为我一般用不到，比如"打印偏移"、"打印到文件"我从来不用的，如果需要可以添加进去。

       程序会根据指定块名查找图框，也可以根据块的纵横比例自动判断是否为图框，然后按块打印，一张图纸中允许有多个图框；

       对于编组(Group)形式的图框，指定编组名即可

       如果没有找到任何图框块或编组时，按图纸范围打印

       另外，打印时会先预览，然后由用户选择是否打印，避免打错。

[代码如下] 

Sub QuickPlot() 

    Call PlotFunction("SHARP AR-M256", "", "A3", 1, True, True, False, True) 

End Sub 

Sub Plot2PDF() 

    Call PlotFunction("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, 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 

     ThisDrawing.Application.ZoomExtents 

        ' 设置打印机 

        If Not Trim(PrinterName) = "" Then 

         objLayout.ConfigName = PrinterName 

        Else 

        Exit Sub 

        End If 

        ' 设置打印样式表 

        If Not Trim(Styles) = "" Then 

         objLayout.StyleSheet = Styles 

        Else 

         objLayout.StyleSheet = "acad.ctb" 

        End If 

        ' 设置图纸尺寸 

        If AutoMedia Then 

         objLayout.CanonicalMediaName = "A3" 

        Else 

        If Not Trim(MediaName) = "" Then 

         objLayout.CanonicalMediaName = MediaName 

        Else 

         objLayout.CanonicalMediaName = "A3" 

        End If 

        End If 

        ' 设置图纸单位 

         objLayout.PaperUnits = acMillimeters 

        'objLayout.PaperUnits = acInches 

        ' 设置默认图纸打印方向 

            'objLayout.PlotRotation = ac0degrees     '纵向 

            'objLayout.PlotRotation = ac180degrees 

             objLayout.PlotRotation = ac90degrees   '横向 

            'objLayout.PlotRotation = ac270degrees 

        ' 设置图纸打印比例 

         objLayout.StandardScale = acScaleToFit 

         objLayout.UseStandardScale = True  '使用标准打印比例 

        'objLayout.UseStandardScale = False '使用自定义打印比例 

        ' 设置自定义打印比例 

        'objLayout.SetCustomScale txtNumerator.Value, txtDenominator.Value 

        ' 设置图纸是否居中打印 

         objLayout.CenterPlot = True 

        ' 打印时使用图形文件中的线宽 

         objLayout.PlotWithLineweights = True 

        ' 设置是否应用打印样式 

         objLayout.PlotWithPlotStyles = True 

        ' 打印时隐藏图纸空间对象 

         objLayout.PlotHidden = False 

        ' 设置图纸打印份数 

        If Copies >= 1 Then

         objPlot.NumberOfCopies = CInt(Copies) 

        Else 

         objPlot.NumberOfCopies = 1 

        End If 

        ' 将打印错误报告切换为静默错误模式，以便不间断地执行打印任务 

         objPlot.QuietErrorMode = True 

        ' 重新生成当前图形 

         objDoc.Regen acAllViewports 

        ' 设置前台打印，使打印任务按打印顺序依次发送到打印机 

         objDoc.SetVariable "BACKGROUNDPLOT", 0 

         PlotCount = 0  '打印计数 

        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.GetBoundingBox ptMin, ptMax 

                 Debug.Print Ent.Name & "--" & objDoc.Blocks(Ent.Name).count 

                ' 将三维点转化为二维点坐标 

                ReDim Preserve ptMin(0 To 1) 

                ReDim Preserve ptMax(0 To 1) 

                ' 设置打印窗口 

                 ThisDrawing.ActiveLayout.SetWindowToPlot ptMin, ptMax 

                 objLayout.PlotType = acWindow 

                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 

                ' 完全预览并提示打印 

                 objPlot.DisplayPlotPreview acFullPreview 

                 UserSel = MsgBox("是否打印预览？ " & Chr(13) & Chr(13) & "打印到：" & objLayout.ConfigName & _ 

                "   大小：" & objLayout.CanonicalMediaName & "   方式：acWindow(" & objLayout.PlotType & ") " & _ 

                Chr(13) & Chr(13) & "选择[取消]退出程序！", vbYesNoCancel, "打印选项") 

                    If UserSel = vbYes Then 

                 objPlot.PlotToDevice objLayout.ConfigName 

                 PlotCount = PlotCount + 1 

                    ElseIf UserSel = vbCancel Then 

                    Exit For 

                    End If 

            End If 

        End If 

        Next Ent 

        ' 图框为编组(Group)对象时 

        Dim FrmGrp As AcadGroup 

        Dim TptMin, TptMax As Variant 

        ' 按编组名称查找图框编组对象 

        For Each FrmGrp In ThisDrawing.Groups 

        If IsFrame(FrmGrp, False) And FrmGrp.count > 0 Then

         Debug.Print FrmGrp.Name & "   [Items]:" & FrmGrp.count & "----group" 

        ' 得到图框边界点坐标 

         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) < ptMin(j) Then

         ptMin(j) = TptMin(j) 

        End If 

        If TptMax(j) > ptMax(j) Then

         ptMax(j) = TptMax(j) 

        End If 

        Next j 

         i = i + 1 

        Next 

        ' 将三维点转化为二维点坐标 

        ReDim Preserve ptMin(0 To 1) 

        ReDim Preserve ptMax(0 To 1) 

        ' 设置打印窗口 

         ThisDrawing.ActiveLayout.SetWindowToPlot ptMin, ptMax 

         objLayout.PlotType = acWindow 

        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 

        ' 完全预览并提示打印 

         objPlot.DisplayPlotPreview acFullPreview 

         UserSel = MsgBox("是否打印预览？ " & Chr(13) & Chr(13) & "打印到：" & objLayout.ConfigName & _ 

        "   大小：" & objLayout.CanonicalMediaName & "   方式：acWindow(" & objLayout.PlotType & ") " & _ 

        Chr(13) & Chr(13) & "选择[取消]退出程序！", vbYesNoCancel, "打印选项") 

           If UserSel = vbYes Then 

         PlotCount = PlotCount + 1 

         objPlot.PlotToDevice objLayout.ConfigName 

           ElseIf UserSel = vbCancel Then 

        Exit For 

        End If 

        End If 

        Next FrmGrp 

        ' 没有找到图框时按范围打印 

        If PlotCount = 0 And objDoc.ModelSpace.count > 0 Then

         ptMax = ThisDrawing.GetVariable("EXTMAX") 

         ptMin = ThisDrawing.GetVariable("EXTMIN") 

        ' 图形范围内无实体则退出 

        If ptMax(0) = ptMin(0) Or ptMax(1) = ptMin(1) Then 

        Exit Sub 

        End If 

        ' 设置范围打印 

         objLayout.PlotType = acExtents 

        ' 对纵向的图纸设置 

        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 

        ' 完全预览并提示打印 

         objPlot.DisplayPlotPreview acFullPreview 

         UserSel = MsgBox("是否打印预览？ " & Chr(13) & Chr(13) & "打印到：" & objLayout.ConfigName & _ 

        "   大小：" & objLayout.CanonicalMediaName & "   方式：acExtents(" & objLayout.PlotType & ") " & _ 

        Chr(13) & Chr(13) & "选择[取消]退出程序！", vbYesNoCancel, "打印选项") 

          If UserSel = vbYes Then 

         objPlot.PlotToDevice objLayout.ConfigName 

        ElseIf UserSel = vbCancel Then 

        Exit Sub 

          End If 

        End If 

        ' 关闭文档 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 Variant 

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 

'块名不符时由大小比例判断是否为图框(可能会误判,不过几率不高) 

If IsFrame = False And AutoMode And entobj.ObjectName = "AcDbBlockReference" 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

为了您的安全，请只打开来源可靠的网址 

打开网站    取消

一

Function SNA11x17()

Dim objPS As AcadPlotConfiguration

  Set objPS = ThisDrawing.PlotConfigurations.Add(“SNA-AZTU-11x17”, False)

  objPS.ConfigName = “\\\\SERVER2\\SAVIN 4035 PCL 6”

  objPS.CanonicalMediaName = “Tabloid”

  objPS.CenterPlot = True

  objPS.PaperUnits = acInches

  objPS.PlotHidden = False

  objPS.PlotRotation = ac90degrees

  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”

  objPS.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

    Layout.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.NumberOfCopies = 1

    Layout.CenterPlot = True

    Layout.ScaleLineweights = False

    Layout.RefreshPlotDeviceInfo

    ThisDrawing.Regen acAllViewports

    ZoomExtents

    Set Layout = Nothing

    ThisDrawing.Save

Exit_Here:

    Exit Sub

Err_Control:

    Select Case Err.Number

    Case "-2145320861"

        MsgBox "Unable to Save Drawing- " & Err.Description

    Case "-214533"

        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 Select

End Sub

三

Sub PcsMM()

    Dim pC As AcadPlotConfiguration

    Dim PCs As AcadPlotConfigurations

    Dim oLayout As AcadLayout

    Dim 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

        .CanonicalMediaName = "User1639"

        .CenterPlot = True

        .ConfigName = "\\\\DESIGNSERVER\\HPDJ"

        .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

        .CanonicalMediaName = "User1639"

        .ConfigName = "\\\\DESIGNSERVER\\HPDRAFT"

        .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

        .CenterPlot = True

        .ConfigName = "\\\\designserver\\KONICA"

        .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 = "\\\\DESIGNSERVER\\HPDJ"

        .StandardScale = ac1_1

        .CanonicalMediaName = "User1639"

        .PlotType = acExtents

        .PlotRotation = ac180degrees

    End With

    PCAdds pC

    Set pC = PCs.Add("22x34draft-model", True)

    With pC

        .ConfigName = "\\\\DESIGNSERVER\\HPDRAFT"

        .StandardScale = ac1_1

        .CanonicalMediaName = "User1639"

        .PlotType = acExtents

        .PlotRotation = ac180degrees

    End With

    PcTyp pC

    Set pC = PCs.Add("11x17-model", True)

    Orig = ThisDrawing.GetVariable("Viewctr")

    PlotOrig(0) = Orig(0): PlotOrig(1) = Orig(1)

    With pC

        .ConfigName = "\\\\designserver\\KONICA"

        .StandardScale = acScaleToFit

        '.SetCustomScale 1, 1

        .CanonicalMediaName = "Tabloid"

        '.PlotType = acExtents

        .CenterPlot = True

        .PlotOrigin = PlotOrig

        .PlotRotation = ac270degrees

    End With

    PcTyp pC

    oLayout.CopyFrom pC

'Pc.RefreshPlotDeviceInfo

ThisDrawing.Regen 0

End Sub

Function PcTyp(pC As AcadPlotConfiguration)

    With pC

        .PaperUnits = acMillimeters

        .PlotHidden = False

        .PlotViewportBorders = False

        .PlotViewportsFirst = True

        .PlotWithLineweights = True

        .PlotWithPlotStyles = True

        .StyleSheet = "Lexington Standard.ctb"

        .UseStandardScale = True

    End With

End Function