打印所有打开的dwg (PS选项卡)
有人有任何代码可以循环遍历所有打开的dwg并在每个dwg上绘制所有PS选项卡吗？**** Hidden Message ***** 不完全是，但是修改我的东西会很容易 每个布局是否使用相同的打印设置？ 这应该可以让您开始
Option Explicit
Public Sub PlotAll()
Dim dwg As AcadDocument, dwgs As AcadDocuments
Set dwgs = Application.Documents
Dim PSLayout As AcadLayout, PSLayouts As AcadLayouts
For Each dwg In dwgs
Set PSLayouts = ThisDrawing.Layouts
For Each PSLayout In PSLayouts
SetupAndPlot
Next
Next
End Sub
Private Sub SetupAndPlot() 'ByRef Plotter As String, CTB As String, SIZE As String, PSCALE As String, ROT As String) ' either pass these or hard code below
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.PlotViewportBorders = False
Layout.PlotViewportsFirst = 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
ThisDrawing.Plot.PlotToDevice
ThisDrawing.Close (True)
Exit_Here:
Exit Sub
Err_Control:
Select Case Err.Number
Case "-2145320861"
MsgBox "Unable to Save Drawing- " & Err.Description
Case "-2145386493"
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
页:
[1]