沙漠骆驼工具箱源码-6批量打印

woxing1987

工具条：批量打印，界面和代码如下：
1 界面：



2 代码如下：

Dim dayinkuang As AcadLWPolyline '定义打印框
Dim layout As AcadLayout '定义打印设置，布局，模型空间或图纸空间图块的出图设置和可视化属性。
Dim objplot As AcadPlot '定义出图设置，用于出图布局的方法和属性集。
Dim plotdevices As Variant '获取打印机配置名
Dim medianames As Variant '获取纸张大小
Dim dayinstylenames As Variant '获取打印样式表
Dim dayinjiname As String
Dim zhizhangdaxiao As String
Dim dayinyangshi As String
Dim sset1 As AcadSelectionSet '打印框选择集



Private Sub CommandButton1_Click() '打印预览
    Me.Hide
    On Error Resume Next
    dayinjiname = ComboBox1.Text
    zhizhangdaxiao = ComboBox2.Text
    dayinyangshi = ComboBox3.Text
    ThisDrawing.ModelSpace.layout.ConfigName = dayinjiname
    ThisDrawing.ModelSpace.layout.CanonicalMediaName = zhizhangdaxiao
    ThisDrawing.ModelSpace.layout.StyleSheet = dayinyangshi
    'MsgBox ThisDrawing.ModelSpace.layout.CanonicalMediaName
    'Set layout = ThisDrawing.ModelSpace.layout

    'backgroundplot 确保AutoCAD在前台进行打印，
    '这样后一次打印会在前一次打印完成之后才开始，避免出现错误
    ThisDrawing.SetVariable "BACKGROUNDPLOT", 0
    Set layout = ThisDrawing.ModelSpace.layout '设置当前打印设置
    layout.StandardScale = acScaleToFit ' 设置打印比例为“布满图纸”
            layout.CenterPlot = True '剧中打印
            layout.PlotWithLineweights = True 'false->对象按图形文件中的线宽打印,true->对象按在打印文件中分配的线宽打印
            layout.PlotWithPlotStyles = True '对象按在打印样式文件中分配的配置打印
            layout.PlotHidden = False '打印期间不隐藏对象。
'            layout.PaperUnits = acMillimeters
'            ThisDrawing.Regen acActiveViewport

    Set objplot = ThisDrawing.Plot

    ' 对所有的打印区域进行打印预览
    Dim box1 As Variant, box2 As Variant
    Dim dyck1(0 To 1) As Double
    Dim dyck2(0 To 1) As Double
    Dim i As Integer
    Dim linshi As Integer
    Dim adadad As AcadLine
    layout.SetWindowToPlot dyck1, dyck2
    layout.PlotType = acWindow  '设置打印类型 为窗口打印
    If CheckBox1.value = False Then
        For i = sset1.count - 1 To 0 Step -1
            sset1.Item(i).GetBoundingBox box1, box2
            dyck1(0) = box1(0): dyck1(1) = box1(1)
            dyck2(0) = box2(0): dyck2(1) = box2(1)
'            Set adadad = ThisDrawing.ModelSpace.AddLine(box1, box2)
'            adadad.color = acRed
            'MsgBox dyck1(0) & "    " & dyck1(1)

            '自动旋转
            If box2(0) - box1(0) > box2(1) - box1(1) Then
                layout.PlotRotation = ac90degrees '横向打印
            Else
                layout.PlotRotation = ac0degrees '纵向打印
            End If
          ' 设置打印窗口角点
            layout.SetWindowToPlot dyck1, dyck2
            layout.PlotType = acWindow ''设置打印类型 为窗口打印,在SetWindowToPlot方法中指定的窗口中的所有对象。

            objplot.DisplayPlotPreview acFullPreview ' 打印预览当前的区域
            'ThisDrawing.ActiveSpace = acModelSpace
            ThisDrawing.SendCommand "wh-lkx" & vbCr
            ThisDrawing.Utility.prompt "按空格键预览下一个 "
            linshi = ThisDrawing.Utility.GetInteger("(按1结束预览)：")
            If linshi = 1 Then
                Me.show
                Exit Sub
            End If
        Next
    Else
        For i = 0 To sset1.count - 1 '逆序打印
            sset1.Item(i).GetBoundingBox box1, box2
            dyck1(0) = box1(0): dyck1(1) = box1(1)
            dyck2(0) = box2(0): dyck2(1) = box2(1)

            '自动旋转
            If box2(0) - box1(0) > box2(1) - box1(1) Then
                layout.PlotRotation = ac90degrees '横向打印
            Else
                layout.PlotRotation = ac0degrees '纵向打印
            End If
            'ThisDrawing.Regen acActiveViewport
             ' 设置打印窗口角点
            layout.SetWindowToPlot dyck1, dyck2
            layout.PlotType = acWindow  '设置打印类型 为窗口打印

            objplot.DisplayPlotPreview acFullPreview ' 打印预览当前的区域
            ThisDrawing.SendCommand "wh-lkx" & vbCr
            ThisDrawing.Utility.prompt "按空格键预览下一个 "
            linshi = ThisDrawing.Utility.GetInteger("(按1结束预览)：")
            If linshi = 1 Then
                Me.show
                Exit Sub
            End If
        Next
    End If
    ThisDrawing.SetVariable "BACKGROUNDPLOT", 2
    Me.show
End Sub

Private Sub CommandButton2_Click() ' 框选打印出图
    Me.Hide
    On Error Resume Next
    dayinjiname = ComboBox1.Text
    zhizhangdaxiao = ComboBox2.Text
    dayinyangshi = ComboBox3.Text
    ThisDrawing.ModelSpace.layout.ConfigName = dayinjiname
    ThisDrawing.ModelSpace.layout.CanonicalMediaName = zhizhangdaxiao
    ThisDrawing.ModelSpace.layout.StyleSheet = dayinyangshi

    ' 确保AutoCAD在前台进行打印，这样后一次打印会在前一次打印完成之后才开始，避免出现错误
    ThisDrawing.SetVariable "BACKGROUNDPLOT", 0
    Set layout = ThisDrawing.ModelSpace.layout '设置当前打印设置

    Set objplot = ThisDrawing.Plot

    ' 对所有的打印区域进行窗口打印
    Dim box1 As Variant, box2 As Variant
    Dim dyck1(0 To 1) As Double
    Dim dyck2(0 To 1) As Double
    Dim i As Integer
    'dayincishu = sset1.count - 1
    If CheckBox1.value = False Then  '是否逆序打印
        For i = sset1.count - 1 To 0 Step -1
            sset1.Item(i).GetBoundingBox box1, box2
            dyck1(0) = box1(0): dyck1(1) = box1(1)
            dyck2(0) = box2(0): dyck2(1) = box2(1)
            layout.SetWindowToPlot dyck1, dyck2  ' 设置打印窗口
            '自动旋转
            If box2(0) - box1(0) > box2(1) - box1(1) Then
                layout.PlotRotation = ac90degrees '横向打印
            Else
                layout.PlotRotation = ac0degrees '纵向打印
            End If
            ' 设置打印类型 为窗口打印
            'ThisDrawing.Regen acActiveViewport
            layout.PlotType = acWindow
            layout.StandardScale = acScaleToFit '设置打印比例为“布满图纸”
            layout.CenterPlot = True '剧中打印
            layout.PlotWithLineweights = True 'false->对象按图形文件中的线宽打印,true->对象按在打印文件中分配的线宽打印
            layout.PlotHidden = False '打印期间不隐藏对象。
            layout.PlotWithPlotStyles = True '对象按在打印样式文件中分配的配置打印

            objplot.QuietErrorMode = True '启用静默错误模式,以便不间断的执行打印任务。
            objplot.PlotToDevice ' 打印当前的区域
        Next
    Else            '是否逆序打印
        For i = 0 To sset1.count - 1
            sset1.Item(i).GetBoundingBox box1, box2
            dyck1(0) = box1(0): dyck1(1) = box1(1)
            dyck2(0) = box2(0): dyck2(1) = box2(1)
            layout.SetWindowToPlot dyck1, dyck2  ' 设置打印窗口
            '自动旋转
            If box2(0) - box1(0) > box2(1) - box1(1) Then
                layout.PlotRotation = ac90degrees '横向打印
            Else
                layout.PlotRotation = ac0degrees '纵向打印
            End If
            ' 设置打印类型 为窗口打印
            'ThisDrawing.Regen acActiveViewport
            layout.PlotType = acWindow
            layout.StandardScale = acScaleToFit '设置打印比例为“布满图纸”
            layout.CenterPlot = True '剧中打印
            layout.PlotWithLineweights = True 'false->对象按图形文件中的线宽打印,true->对象按在打印文件中分配的线宽打印
            layout.PlotHidden = False '打印期间不隐藏对象。
            layout.PlotWithPlotStyles = True '对象按在打印样式文件中分配的配置打印

            objplot.QuietErrorMode = True '启用静默错误模式,以便不间断的执行打印任务。
            objplot.PlotToDevice ' 打印当前的区域
        Next
    End If
    ThisDrawing.ActiveSpace = acModelSpace
    ThisDrawing.SetVariable "BACKGROUNDPLOT", 2
    Me.show
    MsgBox "数据传输完成！共需打印 " & sset1.count & " 张。"
End Sub

Private Sub CommandButton3_Click()
    Me.Hide
End Sub

Private Sub CommandButton4_Click() '帮助
    MsgBox "说明：" & vbCr & _
           "1选择打印设备、纸张大小等；" & vbCr & _
           "2拾取打印图框，如A4、A3等，打印框(图框)为多段线闭合矩形" & vbCr & _
              "，必须在同一图层，且设置为不打印，以方便进行框选打印；" & vbCr & _
           "3直接框选要打印的图形，程序会自动过滤图框。" & vbCr & _
           "qq  ：549738552    " & vbCr & "当前时间：" & Now, vbInformation, "批量打印--by沙漠骆驼"
End Sub

Private Sub Label10_Click() '亮显打印框
    Me.Hide
    On Error Resume Next
    If Label9.Caption = 0 Or sset1.count = 0 Then
        MsgBox "没有可显示的图框"
        Label9.Caption = 0
        Me.show
        Exit Sub
    End If
    Dim i As Integer
    For i = 0 To sset1.count - 1
        sset1.Item(i).color = acGreen
    Next
    Dim boundary1(0 To 2) As Double
    Dim boundary2(0 To 2) As Double
    Dim xuanzefanwei As biankuangzuobiao
    xuanzefanwei = huoqukuang(sset1)
    boundary1(0) = xuanzefanwei.x1
    boundary1(1) = xuanzefanwei.y1
    boundary1(2) = 0
    boundary2(0) = xuanzefanwei.x2
    boundary2(1) = xuanzefanwei.y2
    boundary2(2) = 0
    ThisDrawing.Application.ZoomWindow boundary1, boundary2
    Dim aa As Integer

    For i = 0 To sset1.count - 1
        sset1.Item(i).Highlight True
    Next
    aa = ThisDrawing.Utility.GetInteger("打印框显示为绿色！(按空格结束亮显模式)")
    For i = 0 To sset1.count - 1
        sset1.Item(i).color = acByLayer
    Next
    ThisDrawing.Application.ZoomPrevious '返回上一个屏幕
    Me.show
End Sub

Private Sub Label4_Click() '点击获取打印框图层
    Me.Hide
    Dim base As Variant
    On Error Resume Next
    Dim pickbox1 As Integer
    pickbox1 = ThisDrawing.GetVariable("pickbox")
    ThisDrawing.SetVariable "pickbox", 5

    ThisDrawing.Utility.GetEntity dayinkuang, base, "请选取打印框，以获取打印框所在的图层名称:" & vbCrLf
    If Err.Number <> 0 Or dayinkuang.ConstantWidth <> 0 Then  'Or dayinkuang.Closed = False
        ThisDrawing.Utility.prompt "-----打印框图层获取失败------" & vbCrLf
        Me.show
        ThisDrawing.SetVariable "pickbox", pickbox1
        Exit Sub
    End If
    ThisDrawing.Utility.prompt "-----打印框图层获取成功，请继续下一步操作 -----" & vbCrLf
    Label5.Caption = dayinkuang.Layer
    ThisDrawing.SetVariable "pickbox", pickbox1
    Me.show
End Sub

Private Sub Label7_Click() '框选要打印的图框
    Me.Hide
    If Label5.Caption = "" Then
        MsgBox "请先选择打印框，以获取打印框图层!", vbCritical
        Me.show
        Exit Sub
    End If
    On Error Resume Next
    Dim dykwidth As Double   '确定选择宽度
    Dim dykcolor As String    '系统变量 当前颜色值 0～256
    Dim dyklayer As String
    dykwidth = dayinkuang.ConstantWidth
    dykcolor = dayinkuang.color
    dyklayer = dayinkuang.Layer
    Dim filtertype(3) As Integer '定义选择过滤器类型的dsf组码
    Dim filterdata(3) As Variant '定义过滤器的值
    filtertype(0) = 0
    filterdata(0) = "LWPOLYLINE"
    filtertype(1) = 8
    filterdata(1) = dyklayer
    filtertype(2) = 43
    filterdata(2) = dykwidth
    filtertype(3) = 62
    filterdata(3) = dykcolor
    'createssetfilter filtertype, filterdata, 0, "lwpolyline", 43, 0, 8, dayinkuang.Layer
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请框选对象:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Label9.Caption = 0
        Me.show
        Exit Sub
    End If
    Label9.Caption = sset1.count
    Me.show
    CommandButton1.Enabled = True
    CommandButton2.Enabled = True
End Sub

Private Sub UserForm_Initialize()
    '打印设置
    'On Error GoTo next1
    Set layout = ThisDrawing.ModelSpace.layout
    layout.RefreshPlotDeviceInfo '刷新打印设备
    'ThisDrawing.Regen acActiveViewport
    plotdevices = layout.GetPlotDeviceNames() '打印机名称
    Dim i As Integer
    For i = LBound(plotdevices) To UBound(plotdevices)
        ComboBox1.AddItem plotdevices(i)
    Next
    ComboBox1.Text = plotdevices(1)
    '寻找pdf打印机
'    For i = LBound(plotdevices) To UBound(plotdevices)
'        If UCase(Left(plotdevices(i), 3)) = "PDF" Then
'            ComboBox1.Text = plotdevices(i)
'            Exit For
'        End If
'    Next
    medianames = layout.GetCanonicalMediaNames() '纸张大小
'    For i = LBound(medianames) To UBound(medianames)
'        ComboBox2.AddItem medianames(i)
'    Next
    ComboBox2.AddItem "A0"
    ComboBox2.AddItem "A1"
    ComboBox2.AddItem "A2"
    ComboBox2.AddItem "A3"
    ComboBox2.AddItem "A4"
    ComboBox2.Text = "A3"

    dayinstylenames = layout.GetPlotStyleTableNames() '打印样式
    For i = LBound(dayinstylenames) To UBound(dayinstylenames)
        ComboBox3.AddItem dayinstylenames(i)
        If dayinstylenames(i) = "acad.ctb" Then ComboBox3.Text = "acad.ctb"
    Next
End Sub

20060510412

cad不再直接内嵌vba，vba的使用是不是大大受限了啊。

woxing1987

20060510412 发表于 2022-2-10 19:12
cad不再直接内嵌vba，vba的使用是不是大大受限了啊。

应该不会吧

f4800

感谢分享。。
虽然看不懂 但是大佬的分享精神值得学习

zhaoqi415

感谢分享。。
虽然看不懂 但是大佬的分享精神值得学习

669423907

非常感谢楼主分享好代码，没用过vba，请问代码要保存的后缀是什么？要怎么加载？

woxing1987

669423907 发表于 2022-3-19 08:56
非常感谢楼主分享好代码，没用过vba，请问代码要保存的后缀是什么？要怎么加载？

百度搜索 AutoCAD  vba 二次开发  会有很多资料

BHL-DONG

前人栽树后人乘凉，感谢楼主