[VBA程序]：VB批量打印代码

zjxjesse

Dim StartPoint As Variant, EndPoint As Variant
    Dim seta As AcadSelectionSet
    Dim dataTYPE(0 To 1) As Integer
    Dim dataValue(0 To 1) As Variant
    Dim aa As Integer
    Dim bb As String
    Dim Docname As String
   
        
    Dim docObj As AcadDocument
    Set aCADapp = GetObject(, "AutoCAD.Application.16")
  ' Set ThisDrawing = AcadApp.ActiveDocument

    For aa = 0 To ListBox1.ListCount - 1

        bb = ListBox1.List(aa)
        Docname = dirc & bb

        Set ThisDrawing = aCADapp.Documents.Open(Docname)
        
        dataTYPE(0) = 2
        dataTYPE(1) = 8
        'dataTYPE(2) = 8
        'dataValue(0) = "AcDbBlockReference"
        dataValue(0) = "T*"      '块参照的名称
        dataValue(1) = "BORDER"  '图层名
   
        Set seta = ThisDrawing.SelectionSets.Add("Chen")       '添加一选择集
        ZoomAll
        seta.Select acSelectionSetAll, , , dataTYPE, dataValue '过滤条件
        'seta.SelectOnScreen dataTYPE, dataValue               '在屏幕上选取过滤条件(图框)

        Dim bl As AcadBlockReference
        For i = 0 To seta.Count - 1
           
            'MsgBox seta.Item(i).ObjectName
            seta.Highlight True
            If i = 0 Then
            
              Set bl = seta.Item(i)
            Else
              Set bl = seta.Item(i - 1)
            End If
            'MsgBox bl.Name
        Next
        
        
       'Dim oPlot As AcadPlot
        Dim AddedLayouts() As String
        Dim LayoutList As Variant
        Dim oLayout As AcadLayout
        Dim ArraySize As Integer, BatchCount As Integer
        
        For Each oLayout In ThisDrawing.Layouts
            ArraySize = ArraySize + 1
            ReDim Preserve AddedLayouts(1 To ArraySize)
            AddedLayouts(ArraySize) = oLayout.Name
        Next
        LayoutList = AddedLayouts
         
        bl.GetBoundingBox StartPoint, EndPoint   '得到图框尺寸
        'ThisDrawing.ActiveLayout.PlotType = acWindow
        ThisDrawing.ModelSpace.Layout.GetWindowToPlot StartPoint, EndPoint

        
        '打印到文件
        Dim plotFileName As String
        Dim result As Boolean
        Dim currentPlot As AcadPlot
        Set currentPlot = ThisDrawing.Plot
        
        plotFileName = "c:\\MyPlot\\MyPlot" & aa & ".plt"
        'currentPlot.SetLayoutsToPlot
         currentPlot.SetLayoutsToPlot LayoutList
      
      
       ' 验证活动空间是模型空间
   
        If ThisDrawing.ActiveSpace = acPaperSpace Then
            ThisDrawing.MSpace = True
            ThisDrawing.ActiveSpace = acModelSpace
   
        End If
        
        
        Dim ACADPref As AcadPreferencesOutput
        Dim originalValue As Boolean
        
         
        ' 设置打印区域的范围和比例
   
        ThisDrawing.ModelSpace.Layout.PlotType = acExtents
      ' ThisDrawing.ModelSpace.Layout.GetPaperSize 420, 297
        ThisDrawing.ModelSpace.Layout.StandardScale = acScaleToFit

        ' 设置打印区域的范围和比例
        ThisDrawing.ModelSpace.Layout.PlotType = acExtents
        ThisDrawing.ModelSpace.Layout.StandardScale = acScaleToFit
   
        ' 将打印份数设置为 1
        ThisDrawing.Plot.NumberOfCopies = 1
   
        ' 初始化打印
        Dim PlotConfigurations As AcadPlotConfigurations
        Dim PlotConfiguration As AcadPlotConfiguration
        Dim NewPC1 As AcadPlotConfiguration, NewPC2 As AcadPlotConfiguration
   
        ' Get PlotConfigurations collection from document object
        Set PlotConfigurations = ThisDrawing.PlotConfigurations
        
        ' Add NewPC1 and customize some of the properties
        Set NewPC1 = PlotConfigurations.Item(0)
        NewPC1.PlotRotation = ac270degrees
        NewPC1.PlotHidden = True
        NewPC1.PaperUnits = acMillimeters
        
        ' ThisDrawing.Plot.PlotToFile plotFileName, NewPC1
   
        ' This example will access the PlotConfigurations collection for the current drawing,
        ' add a plot configuration, and list basic information about the
        ' plot configurations in the drawing.
   
        Dim msg As String
        
        ' Get PlotConfigurations collection from document object
        Set PlotConfigurations = ThisDrawing.PlotConfigurations
        
        ' If there aren't any plot configurations, then add one
        If PlotConfigurations.Count = 0 Then
            '*** Customize the new configuration to your satisfaction ***
            PlotConfigurations.Add "NEW_CONFIGURATION"
        End If
        
        msg = vbCrLf & vbCrLf   ' Start with a space
        
        ' Get the names of the plot configurations in this drawing
        For Each PlotConfiguration In PlotConfigurations
            msg = msg & PlotConfiguration.Name & vbCrLf
        Next
        
        ' Display a list of available plot configurations
        MsgBox "There are " & PlotConfigurations.Count & " plot configuration(s) in " & ThisDrawing.WindowTitle & ":" & msg
   
       '============================打印预览==========================
        
        ' This example creates a circle and then performs a plot preview.
        
        ' Create the circle
        Dim circleObj As AcadCircle
        Dim center(0 To 2) As Double
        Dim radius As Double
        center(0) = 2: center(1) = 2: center(2) = 0
        radius = 1
        Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius)
        ZoomAll
        
        ' Preview the plot of the circle
        ' ThisDrawing.Plot.DisplayPlotPreview acFullPreview

        
        ' ==========================打印到文件============================
        ' Define the output file name.
        ' Use "" to use the drawing name as the file name.
               
      
        result = currentPlot.PlotToFile(plotFileName)
               ' 初始化打印cbx
        'ThisDrawing.Plot.PlotToDevice
        'currentPlot.PlotToDevice       '输出到当前打印设备
        seta.Delete                     '删除选择集
        
        ThisDrawing.Close               '关闭当前文档
        'ThisDrawing.Application.Documents.Close '关闭所有文档
    Next aa



'打印或页面设置开始前调用GetPrintName过程 Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)     If CommandName = "PAGESETUP" Or CommandName = "PLOT" Then         Call GetPrintName     End If End Sub

Private Sub GetPrintName()     On Error Resume Next     Dim Layout As AcadLayout     Set Layout = ThisDrawing.ActiveLayout With Layout     .ConfigName = ThisDrawing.Application.Preferences.Output.DefaultOutputDevice ' cad默认打印机的名称     .StyleSheet = ThisDrawing.Application.Preferences.Output.DefaultPlotStyleTable '设置默认打印样式     .CenterPlot = True     .StandardScale = acScaleToFit     .PlotRotation = ac270degrees     .PaperUnits = acMillimeters End With End Sub '本程序在cad2002上运行通过。作用是在打印的时候，总是使用cad默认的打印机和默认的打印样子来打印。

yunzhong80

楼主可不以把上边的程序作一些说明？
我看不明白，并且我拷贝下来也不可以运行
我现在正想找批量打印的程序，我对这还一点不懂
请楼主帮忙，谢谢！！！