autocad vba print

CAD打图脚本

Public Sub 打印当前()







Dim acadApp As AcadApplication, objDoc As AcadDocument
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
If Err Then
Set acadApp = CreateObject("AutoCAD.Application")
End If
On Error GoTo 0
'acadApp.Visible = True
'acadApp.Documents.Close
Set objDoc = acadApp.ActiveDocument
On Error Resume Next



Dim M As pdfFactoryPro
Set M = New pdfFactoryPro
'Debug.Print M.ShowDlg
M.ShowDlg = 2
M.PdfAction = 0
M.CollectJobs = Sheet4.Cells(7, 7).Value '2
M.OutputFile = objDoc.Path & "\" & Sheet4.Cells(6, 7).Value & ".pdf" 'Replace(objDoc.Name, "dwg", "pdf")




Dim ptMin As Variant, ptMax As Variant
Dim Ent As AcadEntity
Dim PlotCount As Integer
Set objLayout = objDoc.Layouts.Item("Model")
Set objPlot = objDoc.Plot
objLayout.ConfigName = "pdfFactory Pro"
objLayout.StyleSheet = "monochrome.ctb"
 
' 设置图纸尺寸
objLayout.CanonicalMediaName = "A3"

 
' 设置图纸单位
objLayout.PaperUnits = acMillimeters
'objLayout.PaperUnits = acInches
 
' 设置默认图纸打印方向
objLayout.PlotRotation = ac0degrees
 
' 设置图纸打印比例
'objLayout.StandardScale = ac1_100 'acScaleToFit
'objLayout.UseStandardScale = True  '使用标准打印比例
objLayout.UseStandardScale = False '使用自定义打印比例
 

 
' 设置图纸是否居中打印
objLayout.CenterPlot = True
 
' 打印时使用图形文件中的线宽
objLayout.PlotWithLineweights = True
 
' 设置是否应用打印样式
objLayout.PlotWithPlotStyles = True
 
' 打印时隐藏图纸空间对象
objLayout.PlotHidden = False
 
' 设置图纸打印份数
objPlot.NumberOfCopies = 1
 
' 将打印错误报告切换为静默错误模式，以便不间断地执行打印任务
objPlot.QuietErrorMode = True
 
' 重新生成当前图形

 
' 设置前台打印，使打印任务按打印顺序依次发送到打印机
objDoc.SetVariable "BACKGROUNDPLOT", 0
 
PlotCount = 0  '打印计数
Dim PointArrs(11) As Double
For Each Ent In objDoc.ModelSpace
    If TypeOf Ent Is AcadBlockReference Then
        If Ent.Name = "A3图衔(50)模板new" Then
            
            
            Ent.GetBoundingBox ptMin, ptMax
            PointArrs(0) = ptMin(0) + 15750 * Ent.XScaleFactor
            PointArrs(1) = ptMin(1) + 875 * Ent.XScaleFactor
            PointArrs(2) = 0
            
            PointArrs(3) = ptMin(0) + 20750 * Ent.XScaleFactor
            PointArrs(4) = ptMin(1) + 875 * Ent.XScaleFactor
            PointArrs(5) = 0
            
            PointArrs(6) = ptMin(0) + 20750 * Ent.XScaleFactor
            PointArrs(7) = ptMin(1) + 1450 * Ent.XScaleFactor
            PointArrs(8) = 0
            
            PointArrs(9) = ptMin(0) + 15750 * Ent.XScaleFactor
            PointArrs(10) = ptMin(1) + 1450 * Ent.XScaleFactor
            PointArrs(11) = 0
            
            Dim SSet As AcadSelectionSet
            If Not IsNull(objDoc.SelectionSets.Item("Example")) Then
            Set SSet = objDoc.SelectionSets.Item("Example")
            SSet.Delete
            End If
            Set SSet = objDoc.SelectionSets.Add("Example")
            
            SSet.SelectByPolygon acSelectionSetWindowPolygon, PointArrs
            
            Dim pickedobjs As AcadText
            For Each pickedobjs In SSet
            'pickedobjs.TextString = "123456789"
            Debug.Print pickedobjs.TextString
            Next
            
            ' 将三维点转化为二维点坐标
            ReDim Preserve ptMin(0 To 1)
            ReDim Preserve ptMax(0 To 1)
            
            ' 设置打印窗口
            Debug.Print "设置打印窗口" & "(" & ptMin(0) & "," & ptMin(1) & ")" & "(" & ptMax(0) & "," & ptMax(1) & ")"
            objLayout.SetWindowToPlot ptMin, ptMax
            objLayout.PlotType = acWindow
            ' 设置自定义打印比例
            Debug.Print "设置打印比例 1:" & 50 * Ent.XScaleFactor
            objLayout.SetCustomScale 1, 50 * Ent.XScaleFactor
            objDoc.Regen acAllViewports
            objPlot.PlotToDevice objLayout.ConfigName
            PlotCount = PlotCount + 1
        End If
    End If
Next Ent



End Sub



 MinX	MinY	MaxX	MaxY
项目总负责人	12750	1625	13750	2000
设计人	12750	1250	13750	1625
校审人	12750	875	13750	1250
专业审核人	12750	500	13750	875
专业负责人	14750	1625	15750	2000
单位	14750	1250	15750	1625
比例	14750	875	15750	1250
出图日期	14750	500	15750	875
图号	16250	500	20750	875
图名	15750	875	20750	1450