沙漠骆驼工具箱源码-6批量打印
工具条：批量打印，界面和代码如下：
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
cad不再直接内嵌vba，vba的使用是不是大大受限了啊。 20060510412 发表于 2022-2-10 19:12
cad不再直接内嵌vba，vba的使用是不是大大受限了啊。
应该不会吧 感谢分享。。
虽然看不懂 但是大佬的分享精神值得学习
感谢分享。。
虽然看不懂 但是大佬的分享精神值得学习 非常感谢楼主分享好代码，没用过vba，请问代码要保存的后缀是什么？要怎么加载？ 669423907 发表于 2022-3-19 08:56
非常感谢楼主分享好代码，没用过vba，请问代码要保存的后缀是什么？要怎么加载？
百度搜索 AutoCADvba 二次开发会有很多资料 前人栽树后人乘凉，感谢楼主
页:
[1]