谁能提供将DWG批量转换成PLT格式的程序,最好提供VB代码!

Jianyu

谁能提供将DWG批量转换成PLT文件的程序,最好提供VB代码!

有可以解答VB编程疑问的高手,请联系我.

QQ:34731786

Email:  Jianyu416@sina.com

 先谢了!

Jianyu

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

s305040093

嗯 很好 正好需要 不过程序还可以更完善一些

s305040093

奇怪的是这个贴子的日期怎么这么早