自己用VBA编的批量打印程序（原创）

xyghzzj

  源码共享，回报明经！

注：58楼已更新。

2009.7.23

xyghzzj

Option Explicit
'图形集合
Private colDwgs As New Collection
'文档对象
Dim objDoc As AcadDocument
'布局对象
Dim objLayout As AcadLayout
'打印对象
Dim objPlot As AcadPlot

Private Type BrowseInfo
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
Private Const MAX_PATH = 260
'代表ESC键
Private Const VK_ESCAPE = &H1B

'API函数的声明
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal _
    pidl As Long, ByVal pszPath As String) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

' 功能：判断用户是否按下某一个键
' 输入：代表键的常量（从API Viewer中获得）
' 调用：API函数GetAsyncKeyState
' 返回：如果用户按下了指定的键，返回True；否则返回False
' 示例：
'       If CheckKey(&H1B) = True Then do sth
Private Function CheckKey(lngKey As Long) As Boolean
  If GetAsyncKeyState(lngKey) Then
    CheckKey = True
  Else
    CheckKey = False
  End If
End Function

Private Sub cboPaperSize_Change()
    '若组合框非空
    If cboPaperSize.Text <> "" Then
        ' 设置图纸尺寸
        objLayout.CanonicalMediaName = cboPaperSize.Text
        ' 显示图纸尺寸
        Call SetPlotZone
    End If
End Sub

Private Sub cboPlotScale_Click()
    If cboPlotScale.Value Then
        objLayout.UseStandardScale = True  '使用标准打印比例
    Else
        objLayout.UseStandardScale = False '使用自定义打印比例
    End If

    Select Case cboPlotScale.Value
    Case 0
        'txtNumerator = 1
        'txtDenominator = 1
    Case 1
        objLayout.StandardScale = acScaleToFit
        txtNumerator = 1
        txtDenominator = ""
    Case 2
        objLayout.StandardScale = ac1_1
        txtNumerator = 1
        txtDenominator = 1
    Case 3
        objLayout.StandardScale = ac1_2
        txtNumerator = 1
        txtDenominator = 2
    Case 4
        objLayout.StandardScale = ac1_4
        txtNumerator = 1
        txtDenominator = 4
    Case 5
        objLayout.StandardScale = ac1_8
        txtNumerator = 1
        txtDenominator = 8
    Case 6
        objLayout.StandardScale = ac1_10
        txtNumerator = 1
        txtDenominator = 10
    Case 7
        objLayout.StandardScale = ac1_16
        txtNumerator = 1
        txtDenominator = 16
    Case 8
        objLayout.StandardScale = ac1_20
        txtNumerator = 1
        txtDenominator = 20
    Case 9
        objLayout.StandardScale = ac1_30
        txtNumerator = 1
        txtDenominator = 30
    Case 10
        objLayout.StandardScale = ac1_40
        txtNumerator = 1
        txtDenominator = 40
    Case 11
        objLayout.StandardScale = ac1_50
        txtNumerator = 1
        txtDenominator = 50
    Case 12
        objLayout.StandardScale = ac1_100
        txtNumerator = 1
        txtDenominator = 100
    Case 13
        objLayout.StandardScale = ac2_1
        txtNumerator = 2
        txtDenominator = 1
    Case 14
        objLayout.StandardScale = ac4_1
        txtNumerator = 4
        txtDenominator = 1
    Case 15
        objLayout.StandardScale = ac8_1
        txtNumerator = 8
        txtDenominator = 1
    Case 16
        objLayout.StandardScale = ac10_1
        txtNumerator = 10
        txtDenominator = 1
    Case 17
        objLayout.StandardScale = ac100_1
        txtNumerator = 100
        txtDenominator = 1
    End Select
End Sub

Private Sub cboPlotStyleTableNames_Change()
    ' 设置打印样式表
    objLayout.StyleSheet = cboPlotStyleTableNames.Text
End Sub

Private Sub cboPrintersName_Change()
    On Error Resume Next
    ' 设置打印机配置（对应AutoCAD中：打印>打印设备>打印机配置>"DWF6 ePlot.pc3"）
    objLayout.ConfigName = cboPrintersName.Text
    ' 更新显示AutoCAD中当前可用的所有图纸尺寸
    Call ListPaperSize
    ' 更新显示AutoCAD中当前可用的所有打印样式表
    Call ListPlotStyleTableNames
End Sub

Private Sub chkCenterPlot_Change()
    Dim PtOffset(0 To 1) As Double
    ' 设置图纸是否居中打印
    If chkCenterPlot.Value Then
        PtOffset(0) = 0
        PtOffset(1) = 0
    Else
        PtOffset(0) = -5
        PtOffset(1) = -5
    End If
    txtOffsetX.Value = PtOffset(0)
    txtOffsetY.Value = PtOffset(1)
End Sub

Private Sub chkPlotHidden_Change()
    '设置是否隐藏图纸空间对象
    If chkPlotHidden.Value Then
        '打印时隐藏图纸空间对象
        objLayout.PlotHidden = True
    Else
        '打印时不隐藏图纸空间对象
        objLayout.PlotHidden = False
    End If
End Sub

Private Sub chkPlotToFile_Change()
    '设置“打印到文件”组各控件激活状态
    If chkPlotToFile.Value Then
        lbPlotPath.Enabled = True
        cboPlotPath.Enabled = True
        cmdBrowse2.Enabled = True
    Else
        lbPlotPath.Enabled = False
        cboPlotPath.Enabled = False
        cmdBrowse2.Enabled = False
    End If
End Sub

Private Sub chkPlotWithLineweights_Change()
    '设置是否打印对象线宽
    If chkPlotWithLineweights.Value Then
        '打印时使用图形文件中的线宽
        objLayout.PlotWithLineweights = True
     Else
        '打印时使用打印样式中的线宽
        objLayout.PlotWithLineweights = False
    End If
End Sub

Private Sub chkPlotWithPlotStyles_Change()
    '设置是否应用打印样式
    If chkPlotWithPlotStyles.Value Then
        '打印时在对象中使用打印样式
        objLayout.PlotWithPlotStyles = True
        chkPlotWithLineweights.Enabled = False
    Else
        '打印时在对象中不使用打印样式
        objLayout.PlotWithPlotStyles = False
        chkPlotWithLineweights.Enabled = True
    End If
End Sub

Private Sub chkReverse_Click()
    ' 设置图纸打印方向
    Call PaperRotationChange
End Sub

Private Sub cmdAdd_Click()
    '如果列表框中未存在任何元素
    If lstCurFiles.ListCount = 0 Then
        MsgBox "请先向列表框中添加文件！", vbCritical
        Exit Sub
    End If

    Dim strFlies As String
    Dim i As Integer
    Dim n As Integer
    n = 0
     '将上面列表框中选中的对象添加到下面的列表框中
    For i = 0 To lstCurFiles.ListCount - 1
        If lstCurFiles.Selected(i) Then
            strFlies = lstCurFiles.List(i)
            n = n + 1
            If Not HasItem(lstPlotFiles, strFlies) Then
                lstPlotFiles.AddItem lstCurFiles.List(i) '
            End If
        End If
    Next i
    '如果列表框中未存在被选择的元素
    If n = 0 Then
        MsgBox "请选择要从列表中添加的元素！", vbCritical
        Exit Sub
    End If
End Sub

Private Sub cmdAddAll_Click()
    '如果列表框中未存在任何元素
    If lstCurFiles.ListCount = 0 Then
        MsgBox "请先向列表框中添加文件！", vbCritical
        Exit Sub
    End If
   
    Dim strFlies As String
    Dim i As Integer
     '将上面列表框中选中的对象添加到下面的列表框中
    For i = 0 To lstCurFiles.ListCount - 1
        strFlies = lstCurFiles.List(i)
        If Not HasItem(lstPlotFiles, strFlies) Then
            lstPlotFiles.AddItem lstCurFiles.List(i)
        End If
    Next i
End Sub

Private Sub cmdBrowse_Click()
    '在文本框中显示获得的路径
    txtCurPath.Text = ReturnFolder(0)
End Sub

Private Sub cmdBrowse2_Click()
    Dim strPath As String
    strPath = ReturnFolder(0)
    '若返回文件夹路径非空
    If strPath <> "" Then
        '若组合框中未存在返回文件夹路径，则将其添加到组合框中
        If HasItem2(strPath) < 0 Then
            '在组合框中显示获得的路径
            With cboPlotPath
                .AddItem strPath, 0
                '使用下拉列表的形式
                .Style = fmStyleDropDownList
                '设置下拉列表的下标下限
                .BoundColumn = 0
                '设置默认的显示项目
                .ListIndex = 0
            End With
        '若组合框中已存在返回文件夹路径，则将返回文件夹路径置为选中
        Else
            With cboPlotPath
                 '设置默认的显示项目
                .ListIndex = HasItem2(strPath)
            End With
        End If
    End If
End Sub

Private Sub cmdClear_Click()
    '如果列表框中未存在任何元素
    If lstPlotFiles.ListCount = 0 Then
        MsgBox "请先向列表框中添加文件！", vbCritical
        Exit Sub
    End If
   
    Dim i As Integer, n As Integer, count As Integer
    '列表框中元素的数量
    count = lstPlotFiles.ListCount
    n = 0
     '将列表框中选中的对象删除
    For i = 0 To count - 1
        If lstPlotFiles.Selected(i) Then
            n = n + 1
        Else
            '移动列表框中的元素
            lstPlotFiles.List(i - n) = lstPlotFiles.List(i)
        End If
    Next i
   
    '如果列表框中未存在被选择的元素
    If n = 0 Then
        MsgBox "请选择要从列表中清除的元素！", vbCritical
        Exit Sub
    End If
   
     '删除最后n行的元素
    For i = 1 To n
        lstPlotFiles.RemoveItem (count - i)
    Next i
   
   

End Sub

Private Sub cmdClearAll_Click()
    '如果列表框中未存在任何元素
    If lstPlotFiles.ListCount = 0 Then
        MsgBox "请先向列表框中添加文件！", vbCritical
        Exit Sub
    End If
   
    Dim Msg, Style, Title, Help, Ctxt, Response, MyString
    Msg = "清除整个图形列表?"
    Style = vbOKCancel + vbQuestion + vbDefaultButton2
    Title = "Clear Files"
   
    Response = MsgBox(Msg, Style, Title)
    If Response = vbOK Then
        txtCurPath.Text = ""
        '清除列表框中所有元素
        lstPlotFiles.Clear
    End If
   
   
End Sub

Private Sub cmdExit_Click()
   '退出
   End
End Sub

Private Sub cmdInput_Click()
    '导入打印设置
    '设置标准对话框
    With comDlg
        '设置标准对话框标题
        .DialogTitle = "导入打印设置"
        '设置标准对话框类型列表中所显示的过滤器
        .Filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
        '设置标准对话框的起始目录
        '.InDir = "C:\"
        '显示[打开]对话框
        .ShowOpen
    End With
   
    Dim strFileName As String
    strFileName = comDlg.fileName
    'strFileName = "F:\AutoCAD\丹通施工图\打印设置.txt"
    '若返回文件名为空，不进行操作
    If strFileName = "" Then
        MsgBox "请重新选择文件位置！"
        Exit Sub
    End If
   
    '读入文件的操作
    Dim i As Integer, nFile As Integer
    Dim x As Double, y As Double
    Dim count As Integer, index As Integer
    Dim strTemp As String
    '获得下一个可供Open语句使用的文件号
    nFile = FreeFile
    '打开文件
    Open strFileName For Input As #nFile
   
    '读入当前路径
    '读入一行文本并存储在变量中
    Line Input #nFile, strTemp
    '读入当前路径并设置文本框文字
    Input #nFile, strTemp
    txtCurPath.Text = strTemp
   
     '读入打印文件列表并添加到列表框中
    Call InputData3(lstPlotFiles, nFile)
   
    '读入打印机配置列表并添加到组合框中
    Call InputData(cboPrintersName, nFile)
   
    '读入打印样式表并添加到组合框中
    Call InputData(cboPlotStyleTableNames, nFile)
   
    '读入图纸尺寸列表并添加到组合框中
    Call InputData(cboPaperSize, nFile)
   
    '读入图纸单位并设置单选按钮选择状态
    '读入一行文本并存储在变量中
    Line Input #nFile, strTemp
    '读入图纸单位
    Input #nFile, strTemp
    '设置单选按钮选择状态
    If strTemp = "毫米" Then
        optMillimeters.Value = True
    Else
        optInches.Value = True
    End If
   
    '读入图纸方向并设置单选按钮选择状态
    '读入一行文本并存储在变量中
    Line Input #nFile, strTemp
    '读入图纸方向
    Input #nFile, strTemp
    '设置单选按钮选择状态
    If strTemp = "纵向" Then
        optVertical.Value = True
    Else
        optHorizontal.Value = True
    End If
   
    '读入是否反向打印并设置复选按钮选择状态
    Call InputData2(chkReverse, nFile)
   
    '读入打印份数
    '读入一行文本并存储在变量中
    Line Input #nFile, strTemp
    '读入打印份数
    Input #nFile, count
    '设置文本框文字
    txtNumber.Text = count
   
    '读入是否打印到文件并设置复选按钮选择状态
    Call InputData2(chkPlotToFile, nFile)
   
    '读入打印路径列表并添加到组合框中
    Call InputData(cboPlotPath, nFile)
   
    '读入打印比例列表并添加到组合框中
    Call InputData(cboPlotScale, nFile)
   
    '读入一行文本并存储在变量中
    Line Input #nFile, strTemp
    '读入当前打印比例并设置文本框文字
    Input #nFile, x
    Input #nFile, y
    txtNumerator.Text = x
    txtDenominator.Text = y
   
    '读入是否居中打印并设置复选按钮选择状态
    Call InputData2(chkCenterPlot, nFile)
   
    '读入打印偏移
    '读入一行文本并存储在变量中
    Line Input #nFile, strTemp
    '读入打印偏移并设置文本框文字
    Input #nFile, x
    Input #nFile, y
    txtOffsetX.Text = x
    txtOffsetY.Text = y
   
    '读入是否打印对象线宽并设置复选按钮选择状态
    Call InputData2(chkPlotWithLineweights, nFile)
    '读入是否采用打印样式并设置复选按钮选择状态
    Call InputData2(chkPlotWithPlotStyles, nFile)
    '读入是否隐藏图纸空间对象并设置复选按钮选择状态
    Call InputData2(chkPlotHidden, nFile)
   
     '读入图框形式并设置单选按钮选择状态
    '读入一行文本并存储在变量中
    Line Input #nFile, strTemp
    '读入图框形式
    Input #nFile, strTemp
    '设置单选按钮选择状态
    If strTemp = "图块" Then
        optBlock.Value = True
    Else
        optLayer.Value = True
    End If
   
     '读入图块名列表并添加到组合框中
    Call InputData(cboBlockName, nFile)
   
    '读入图层名列表并添加到组合框中
    Call InputData(cboLayerName, nFile)
   
    '关闭文件
    Close #nFile

End Sub

Private Sub cmdListPrints_Click()
    ' 显示AutoCAD中当前可用的打印机列表
    Call ListPrinters
End Sub

Private Sub cmdOutput_Click()
    '导出打印设置
    '设置标准对话框
    With comDlg
        '设置标准对话框标题
        .DialogTitle = "导出打印设置"
        '设置标准对话框类型列表中所显示的过滤器
        .Filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
        '设置标准对话框的起始目录
        '.InDir = "C:\"
        '设置[另存为]对话框的缺省扩展名
        .DefaultExt = "txt"
        '显示[另存为]对话框
        .ShowSave
    End With
   
    Dim strFileName As String, strTemp As String
    strFileName = comDlg.fileName
    'strFileName = "F:\AutoCAD\丹通施工图\打印设置.txt"
    '若返回文件名为空，不进行操作
    If strFileName = "" Then
        MsgBox "请重新选择保存位置！"
        Exit Sub
    End If
   
    '保存文件的操作
    Dim i As Integer
    '打开文件
    Open strFileName For Output As #1
   
    '输出当前路径
    Print #1, "当前路径："
    Print #1, txtCurPath.Text
   
    '输出打印文件列表
    Print #1, "打印文件列表："
    '输出打印机配置列表的信息
    Call OutputData3(lstPlotFiles, 1)
   
    '输出打印机配置
    Print #1, "打印机配置："
    '输出打印机配置列表的信息
    Call OutputData(cboPrintersName, 1)
   
    '输出打印样式表
    Print #1, "打印样式表："
    '输出打印样式表的信息
    Call OutputData(cboPlotStyleTableNames, 1)
   
    '输出图纸尺寸列表
    Print #1, "图纸尺寸列表："
    '输出图纸尺寸列表的信息
    Call OutputData(cboPaperSize, 1)
   
    '输出图纸单位
    Print #1, "图纸单位："
    '输出图纸单位信息
    If optMillimeters.Value = True Then
        strTemp = "毫米"
    Else
        strTemp = "英寸"
    End If
    Print #1, strTemp
   
    '输出图纸方向
    Print #1, "图纸方向："
    '输出图纸方向信息
    If optVertical.Value = True Then
        strTemp = "纵向"
    Else
        strTemp = "横向"
    End If
    Print #1, strTemp
   
    '输出是否反向打印
    Print #1, "是否反向打印："
    Call OutputData2(chkReverse, 1)
   
    '输出打印份数
    Print #1, "打印份数："
    Print #1, txtNumber.Text
   
    '输出是否打印到文件
    Print #1, "是否打印到文件："
    Call OutputData2(chkPlotToFile, 1)
   
    '输出打印路径
    Print #1, "打印路径："
    '输出打印路径列表的信息
    Call OutputData(cboPlotPath, 1)
   
    '输出打印比例
    Print #1, "打印比例："
    '输出打印比例列表的信息
    Call OutputData(cboPlotScale, 1)
   
    '输出当前打印比例
    Print #1, "当前打印比例："
    Print #1, txtNumerator.Text
    Print #1, txtDenominator.Text
   
    '输出是否居中打印
    Print #1, "是否居中打印："
    Call OutputData2(chkCenterPlot, 1)
   
    '输出打印偏移
    Print #1, "打印偏移："
    Print #1, txtOffsetX.Text
    Print #1, txtOffsetY.Text
   
    '输出是否打印对象线宽
    Print #1, "是否打印对象线宽："
    Call OutputData2(chkPlotWithLineweights, 1)
    '输出是否采用打印样式
    Print #1, "是否采用打印样式："
    Call OutputData2(chkPlotWithPlotStyles, 1)
    '输出是否隐藏图纸空间对象
    Print #1, "是否隐藏图纸空间对象："
    Call OutputData2(chkPlotHidden, 1)
   
    '输出图框形式
    Print #1, "图框形式："
    '输出图框形式信息
    If optBlock.Value = True Then
        strTemp = "图块"
    Else
        strTemp = "图层"
    End If
    Print #1, strTemp
   
    '输出图块名列表
    Print #1, "图块名列表："
    '输出图块名列表的信息
    Call OutputData(cboBlockName, 1)
   
    '输出图层名列表
    Print #1, "图块名列表："
    '输出图层名列表的信息
    Call OutputData(cboLayerName, 1)
   
    '关闭文件
    Close 1

End Sub

Private Sub cmdPick_Click()
    On Error Resume Next
    Dim objSelect As AcadEntity
    Dim ptPick As Variant
    Dim strTemp As String
   
    Set objDoc = ThisDrawing.Application.ActiveDocument
    '将控制权交给AutoCAD
    frmBatchPlot.Hide
    '在AutoCAD中选择实体并判断类型
Retry:
    objDoc.Utility.GetEntity objSelect, ptPick, vbCrLf & "请选择实体："
    ' 处理按下Esc键的错误
    If objSelect Is Nothing Then
        If CheckKey(VK_ESCAPE) = True Then
            '显示对话框
            frmBatchPlot.Show
            Exit Sub
        Else
            GoTo Retry
        End If
    End If
     ' 处理未选择到实体的错误
    If Err <> 0 Then
        Err.Clear
        GoTo Retry
    End If
   
    '若为指定图块
    If optBlock.Value = True Then
        '判断实体是否块参照
        If TypeOf objSelect Is AcadBlockReference Then
            '判断实体是否模型空间、图纸空间和匿名块
            If StrComp(Left(objSelect.Name, 1), "*") <> 0 Then
                '获得块参照名
                strTemp = objSelect.Name
            Else
                MsgBox "您选择的是匿名块，请重新选择块参照！", vbCritical
                '显示对话框
                frmBatchPlot.Show
                Exit Sub
            End If
        Else
            MsgBox "您选择的不是块参照，请重新选择块参照！", vbCritical
            '显示对话框
            frmBatchPlot.Show
            Exit Sub
        End If
        '刷新块参照列表
        Call ListBlock
        '将所选块参照在组合框中置为当前
        Call SetSelected(cboBlockName, strTemp)
    Else
        '判断实体是否多段线
        If TypeOf objSelect Is AcadLWPolyline Then
            '获得多段线所在图层名
            strTemp = objSelect.Layer
        Else
            MsgBox "您选择的不是轻量多段线，请重新选择轻量多段线！", vbCritical
            '显示对话框
            frmBatchPlot.Show
            Exit Sub
        End If
        ' 刷新图层列表
        Call ListLayer
        '将所选实体所在图层在组合框中置为当前
        Call SetSelected(cboLayerName, strTemp)
    End If
    '显示对话框
    frmBatchPlot.Show

End Sub

Private Sub SetSelected(ListObject As Object, SItem As String)
    '将该元素在组合框中置为当前
    Dim i As Long
   
    '通过比较确定该元素的位置
    For i = 0 To (ListObject.ListCount - 1)
        If StrComp(ListObject.List(i), SItem, vbTextCompare) = 0 Then
            ListObject.ListIndex = i
            Exit Sub
        End If
    Next

End Sub

Private Sub cmdPreview_Click()
    '若按图块进行批量打印
    If optBlock.Value = True Then
        If cboBlockName.ListCount = 0 Or cboBlockName.Text = "" Then
           MsgBox "请先选择块参照！", vbCritical
           Exit Sub
        End If
        Call PreviewByBlock(cboBlockName.Text)
    '若按图层进行批量打印
    Else
        If cboLayerName.ListCount = 0 Or cboLayerName.Text = "" Then
           MsgBox "请先选择块参照！", vbCritical
           Exit Sub
        End If
        Call PreviewByLayer(cboLayerName.Text)
    End If
   
End Sub

Private Sub cmdRefresh_Click()
    '刷新块参照列表
    Call ListBlock
    ' 刷新图层列表
    Call ListLayer
End Sub

Private Sub cmdPlot_Click()
    '若按图块进行批量打印
    If optBlock.Value = True Then
        If cboBlockName.ListCount = 0 Or cboBlockName.Text = "" Then
           MsgBox "请先选择块参照！", vbCritical
           Exit Sub
        End If
        Call BatchPlotByBlock(cboBlockName.Text)
    '若按图层进行批量打印
    Else
        If cboLayerName.ListCount = 0 Or cboLayerName.Text = "" Then
           MsgBox "请先选择块参照！", vbCritical
           Exit Sub
        End If
        Call BatchPlotByLayer(cboLayerName.Text)
    End If
   
End Sub

Private Sub cmdAbout_Click()
   '显示关于对话框
   frmAbout.Show
End Sub

Private Sub optBlock_Change()
    '设置“图块与图层”组各控件激活状态
    If optBlock.Value = True Then
        lbBlockName.Enabled = True
        cboBlockName.Enabled = True
        lbLayerName.Enabled = False
        cboLayerName.Enabled = False
    Else
        lbBlockName.Enabled = False
        cboBlockName.Enabled = False
        lbLayerName.Enabled = True
        cboLayerName.Enabled = True
    End If
End Sub

Private Sub optLayer_Change()
    '设置“图块与图层”组各控件激活状态
    If optBlock.Value = True Then
        lbBlockName.Enabled = True
        cboBlockName.Enabled = True
        lbLayerName.Enabled = False
        cboLayerName.Enabled = False
    Else
        lbBlockName.Enabled = False
        cboBlockName.Enabled = False
        lbLayerName.Enabled = True
        cboLayerName.Enabled = True
    End If
End Sub

Private Sub optMillimeters_Change()
    ' 设置图纸单位
    If optMillimeters.Value = True Then
        objLayout.PaperUnits = acMillimeters
        lbUnit.Caption = "毫米 ＝"
        lbUnitX.Caption = "毫米"
        lbUnitY.Caption = "毫米"
        lbPaperUnit.Caption = "毫米"
    Else
        objLayout.PaperUnits = acInches
        lbUnit.Caption = "英寸 ＝"
        lbUnitX.Caption = "英寸"
        lbUnitY.Caption = "英寸"
        lbPaperUnit.Caption = "英寸"
    End If
    ' 显示图纸尺寸
    Call SetPlotZone
   
End Sub

Private Sub OptVertical_Change()
    ' 设置图纸打印方向
    Call PaperRotationChange
End Sub

Private Sub spnAngle_SpinDown()
    If CInt(txtNumber.Text) > 1 Then
        txtNumber.Text = CInt(txtNumber.Text) - 1
    End If
End Sub

Private Sub spnAngle_SpinUp()
    txtNumber.Text = CInt(txtNumber.Text) + 1
End Sub

Private Sub txtCurPath_Change()
    '查找文件，向列表框中添加
    If Len(Dir(txtCurPath.Text)) > 0 Then
        FindFile colDwgs, txtCurPath.Text, "dwg"
        If AddToList(lstCurFiles, colDwgs) Then
        End If
    End If
End Sub

Private Sub txtDenominator_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    ' 设置自定义图纸尺寸
    If IsNumeric(txtDenominator) Then
        '设置组合框显示项目为“自定义”
        cboPlotScale.ListIndex = 0
    Else
        MsgBox "请输入数字！", vbCritical
    End If
End Sub

Private Sub txtNumber_Change()
    ' 设置图纸打印份数
    'objPlot.NumberOfCopies = CDbl(txtNumber.Text)
    'objPlot.NumberOfCopies = CInt(txtNumber.Text)
    objPlot.NumberOfCopies = txtNumber.Value
End Sub

Private Sub txtNumerator_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    ' 设置自定义图纸尺寸
    If IsNumeric(txtNumerator) Then
        '设置组合框显示项目为“自定义”
        cboPlotScale.ListIndex = 0
    Else
        MsgBox "请输入数字！", vbCritical
    End If
End Sub

Private Sub txtOffsetX_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
     ' 设置自定义图纸尺寸
     If (KeyAscii >= Asc("0") And KeyAscii <= Asc("9")) Or KeyAscii = Asc(".") Or KeyAscii = Asc("-") Then
         '取消“居中打印”复选框
         chkCenterPlot.Value = False
     Else
         MsgBox "请输入数字！", vbCritical
     End If
End Sub

Private Sub txtOffsetY_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
     ' 设置自定义图纸尺寸
     If (KeyAscii >= Asc("0") And KeyAscii <= Asc("9")) Or KeyAscii = Asc(".") Or KeyAscii = Asc("-") Then
         '取消“居中打印”复选框
         chkCenterPlot.Value = False
     Else
         MsgBox "请输入数字！", vbCritical
     End If
End Sub

Private Sub UserForm_Initialize()
    Set objDoc = ThisDrawing.Application.ActiveDocument
    Set objLayout = ThisDrawing.ActiveLayout
    Set objPlot = ThisDrawing.Plot
    '禁用“当前路径”文本框
    txtCurPath.Enabled = False
    '列出当前所有打印机
    Call ListPrinters
    ' 显示AutoCAD中当前可用的打印比例列表
    Call ListPlotScale
   
    '设置“打印到文件”是否选中
    chkPlotToFile.Value = False
    '禁用“打印到文件”组各控件
    lbPlotPath.Enabled = False
    cboPlotPath.Enabled = False
    cmdBrowse2.Enabled = False
   
    ' 显示AutoCAD中当前可用的图块
    Call ListBlock
    ' 显示AutoCAD中当前可用的图层
    Call ListLayer
   
   
   
   
End Sub

Public Function ReturnFolder(lngHwnd As Long) As String
    Dim Browser As BrowseInfo
    Dim lngFolder As Long
    Dim strPath As String
    Dim strTemp As String
   
    With Browser
        .hOwner = lngHwnd
        .lpszTitle = "选择工作路径"
        .pszDisplayName = String(MAX_PATH, 0)
    End With
   
    '用空格填充字符串
    strPath = String(MAX_PATH, 0)
    '调用API函数显示文件夹列表
    lngFolder = SHBrowseForFolder(Browser)
   
    '使用API函数获取返回的路径
    If lngFolder Then
        SHGetPathFromIDList lngFolder, strPath
        strTemp = Left(strPath, InStr(strPath, vbNullChar) - 1)
       
        If (Right(strTemp, 1) <> "\") Then
            strTemp = strTemp & "\"
        End If
       
        ReturnFolder = strTemp
    End If
End Function

Public Sub FindFile(ByRef files As Collection, strDir, strExt)
    '删除集合中所有的对象
    Dim i As Integer
    For i = 1 To files.count
        files.Remove 1
    Next i
   
    '查找dwg文件，并将其添加到集合中
    Dim strFileName As String
   
    If (Right(strDir, 1) <> "\") Then
        strDir = strDir & "\"
    End If
    strFileName = Dir(strDir & "*.*", vbDirectory)
   
    Do While (strFileName <> "")
        If (UCase(Right(strFileName, 3)) = UCase(strExt)) Then
            files.Add strDir & strFileName
        End If
        strFileName = Dir   '返回下一个符合条件的文件
    Loop
End Sub

Public Function AddToList(objBox As ListBox, Names As Collection) As Boolean
    Dim i As Integer
    On Error GoTo Error_Control
   
    objBox.Clear
    '将集合中的对象添加到列表框中
    For i = 1 To Names.count
        objBox.AddItem Names(i)
    Next i
   
Exit_Here:
    AddToList = True
    Exit Function
   
Error_Control:
    MsgBox "发生下面的错误：" & Err.Number
    AddToList = False
End Function

Private Function HasItem(objBox As ListBox, strFlies As String) As Boolean
   
    '检查路径是否已经存在
    HasItem = False
 
    Dim i As Integer
    If objBox.ListCount > 0 Then
        For i = 0 To objBox.ListCount - 1
            If StrComp(objBox.List(i), strFlies, vbTextCompare) = 0 Then
                HasItem = True
                Exit Function
            End If
        Next i
    End If
End Function

Private Function HasItem2(ByVal strPath As String) As Integer
   
    '检查路径是否已经存在
    HasItem2 = -1
 
    Dim i As Integer
    If cboPlotPath.ListCount > 0 Then
        For i = 0 To cboPlotPath.ListCount - 1
            If StrComp(cboPlotPath.List(i), strPath, vbTextCompare) = 0 Then
                HasItem2 = i
                Exit Function
            End If
        Next i
    End If
End Function

'打开或激活文件
Private Sub OpenFile(fileName As String)
    Dim dwgFile  As AcadDocument
    Dim strFile  As String
    For Each dwgFile In ThisDrawing.Application.Documents
        strFile = dwgFile.Path & "\" & dwgFile.Name
        '若第i个图形文件已经被打开，则将其激活
        If strFile = fileName Then
           '若dwgFile尚未激活，则将其激活
            If dwgFile.Active = False Then
                ThisDrawing.Application.ActiveDocument = dwgFile
            End If
            Exit Sub
        End If
    Next
    '若第i个图形文件尚未被打开，则将其打开
    ThisDrawing.Application.Documents.Open fileName
   
End Sub

' 显示AutoCAD中当前可用的打印机列表
Public Sub ListPrinters()
    objLayout.RefreshPlotDeviceInfo
   
    ' 获得所有的可用打印机
    Dim plotDevices  As Variant
    plotDevices = objLayout.GetPlotDeviceNames
   
    ' 删除以前的打印机列表
    cboPrintersName.Clear
    ' 显示打印机列表
    Dim i As Integer
    For i = 0 To UBound(plotDevices)
        cboPrintersName.AddItem (plotDevices(i))
    Next i
    ' 设置组合框初始选项
    With cboPrintersName
        '使用下拉列表的形式
        .Style = fmStyleDropDownList
        '设置下拉列表的下标下限
        .BoundColumn = 0
        '设置默认的显示项目
        .ListIndex = 1
    End With
   
End Sub

' 显示AutoCAD中当前可用的打印样式
Public Sub ListPlotStyleTableNames()
    Set objLayout = ThisDrawing.ActiveLayout
    objLayout.RefreshPlotDeviceInfo
   
    ' 获得所有的可用打印样式
    Dim plotStyleTables  As Variant
    plotStyleTables = objLayout.GetPlotStyleTableNames
   
    ' 删除以前的打印样式列表
    cboPlotStyleTableNames.Clear
    ' 显打印样式列表
    Dim i As Integer
    For i = 0 To UBound(plotStyleTables)
        cboPlotStyleTableNames.AddItem (plotStyleTables(i))
    Next i
    ' 设置组合框初始选项
    With cboPlotStyleTableNames
        '使用下拉列表的形式
        .Style = fmStyleDropDownList
        '设置下拉列表的下标下限
        .BoundColumn = 0
        '设置默认的显示项目
        .ListIndex = 0
    End With
   
End Sub

' 显示AutoCAD中当前可用的图纸尺寸
Public Sub ListPaperSize()
    objLayout.RefreshPlotDeviceInfo
   
    ' 获得所有当前可用可用图纸尺寸列表
    Dim paperSizes  As Variant
    paperSizes = objLayout.GetCanonicalMediaNames
   
    ' 删除以前的图纸尺寸列表
    cboPaperSize.Clear
    ' 显示图纸尺寸列表
    Dim i As Integer
    For i = 0 To UBound(paperSizes)
        cboPaperSize.AddItem (paperSizes(i))
    Next i
    ' 设置组合框初始选项
    With cboPaperSize
        '使用下拉列表的形式
        .Style = fmStyleDropDownList
        '设置下拉列表的下标下限
        .BoundColumn = 0
        '设置默认的显示项目
        .ListIndex = 0
    End With
   
End Sub

' 显示AutoCAD中可以使用的打印比例
Public Sub ListPlotScale()
' 显打印比例列表
With cboPlotScale
    .AddItem ("自定义"), 0
    .AddItem ("按图纸空间缩放"), 1
    .AddItem ("1:1"), 2
    .AddItem ("1:2"), 3
    .AddItem ("1:4"), 4
    .AddItem ("1:8"), 5
    .AddItem ("1:10"), 6
    .AddItem ("1:16"), 7
    .AddItem ("1:20"), 8
    .AddItem ("1:30"), 9
    .AddItem ("1:40"), 10
    .AddItem ("1:50"), 11
    .AddItem ("1:100"), 12
    .AddItem ("2:1"), 13
    .AddItem ("4:1"), 14
    .AddItem ("8:1"), 15
    .AddItem ("10:1"), 16
    .AddItem ("100:1"), 17
   
    '使用下拉列表的形式
    .Style = fmStyleDropDownList
    '设置下拉列表的下标下限
    .BoundColumn = 0
    '设置默认的显示项目
    .ListIndex = 2
 End With
 txtNumerator = 1
 txtDenominator = 1
 
End Sub

' 显示AutoCAD中当前可用的图层
Public Sub ListLayer()
    Dim LayerList As Collection
    '获得图形中存在的图层列表
    Set LayerList = GetLayerList()
   
    '刷新图层列表
    Call RefreshList(cboLayerName, LayerList)
   
    '选择图层列表中的第一个实体
    If cboLayerName.ListIndex = -1 Then
        cboLayerName.ListIndex = 0
    End If
   
End Sub

'获得图形中存在的图层列表
Private Function GetLayerList() As Collection
    Dim objLayer As AcadLayer
    Dim LayerList As New Collection
   
    Set objDoc = ThisDrawing.Application.ActiveDocument
    '获得可用的图层
    For Each objLayer In objDoc.Layers
        LayerList.Add objLayer.Name, objLayer.Name
    Next
   
    '返回图形中块参照的列表
    Set GetLayerList = LayerList
   
End Function

' 显示AutoCAD中当前可用的图块
Public Sub ListBlock()
    Dim BlockReferenceList As Collection
    '获得图形中存在的块参照列表
    Set BlockReferenceList = GetBlockReferences()
   
    '判断是否存在块参照
    If BlockReferenceList Is Nothing Then
        MsgBox "当前图形中不存在任何的块！", vbExclamation
        Exit Sub
    End If
   
    '刷新块参照列表
    Call RefreshList(cboBlockName, BlockReferenceList)
   
    '选择块参照列表中的第一个实体
    If cboBlockName.ListIndex = -1 Then
        cboBlockName.ListIndex = 0
    End If
   
End Sub

'获得图形中存在的块参照列表
Private Function GetBlockReferences() As Collection
    Dim BlockList As New Collection
    Dim AcadObject As AcadEntity
   
    Set objDoc = ThisDrawing.Application.ActiveDocument
    '获得可用的块参照
    For Each AcadObject In objDoc.ModelSpace
        If AcadObject.ObjectName = "AcDbBlockReference" Then
            '不将模型空间、图纸空间和匿名块添加到组合框中
            If StrComp(Left(AcadObject.Name, 1), "*") <> 0 Then
                On Error Resume Next
                BlockList.Add AcadObject.Name, AcadObject.Name
            End If
        End If
    Next
   
    '返回图形中块参照的列表
    If BlockList.count > 0 Then
        Set GetBlockReferences = BlockList
    Else
        Set GetBlockReferences = Nothing
    End If
End Function

'将组合对象中的元素写入列表框或组合框中
Private Sub RefreshList(ByRef ListObject As Object, ByRef BlockList As Collection)
    Dim i As Long
    '清空列表框
    ListObject.Clear
    '向列表框中添加新的元素
    For i = 1 To BlockList.count
        AddSorted ListObject, BlockList(i)
    Next
   
End Sub

Private Sub AddSorted(ListObject As Object, SItem As String)
    '将元素添加到组合框或列表框中，并且排序
    Dim i As Long
   
    '元素数目小于1，不进行排序
    If ListObject.ListCount = 0 Then
        ListObject.AddItem SItem
        Exit Sub
    End If
   
    '通过比较确定该元素的位置，类似于插入排序法
    For i = 0 To (ListObject.ListCount - 1)
        If StrComp(ListObject.List(i), SItem, vbTextCompare) = 1 Then
            ListObject.AddItem SItem, i
            Exit Sub
        End If
    Next
   
    '添加到列表框的最后
    ListObject.AddItem SItem

End Sub

Public Sub PaperRotationChange()
    ' 设置图纸打印方向
    If optVertical.Value = True Then
        If chkReverse.Value = False Then
            objLayout.PlotRotation = ac0degrees
        Else
            objLayout.PlotRotation = ac180degrees
        End If
    Else
        If chkReverse.Value = False Then
            objLayout.PlotRotation = ac90degrees
        Else
            objLayout.PlotRotation = ac270degrees
        End If
    End If
    ' 显示图纸大小
    Call SetPlotZone
End Sub

' 设置图纸可打印区域大小
Public Sub SetPlotZone()
    Dim Width As Double, Height As Double, t As Double
    ' 获得图纸大小
    objLayout.GetPaperSize Width, Height
    '图形方向为“横向”时宽高互调
    If optVertical.Value = False Then
        t = Width
        Width = Height
        Height = t
    End If
    '单位由“毫米”转换为“英寸”
    If optMillimeters.Value = False Then
        Width = Width / 25.393
        Height = Height / 25.393
    End If
    ' 显示图纸大小
    lbPaperSize.Caption = Round(Width, 2) & " × " & Round(Height, 2)
End Sub

Private Sub OutputData(objBox As ComboBox, nFile As Integer)
    Dim i As Integer, count As Integer, index As Integer
    '获得组合框列表数目
    count = objBox.ListCount
    '获得组合框当前选项的的索引号
    index = objBox.ListIndex
    '输出组合框列表数目
    Write #nFile, count
    '输出组合框当前选项的的索引号
    Write #nFile, index
    '输出所有的组合框选项
    For i = 0 To count - 1
        Print #nFile, objBox.List(i)
    Next
   
End Sub

Private Sub OutputData2(objBox As CheckBox, nFile As Integer)
    Dim strTemp As String
    '输出复选框选中状态
    If objBox.Value = True Then
        strTemp = "是"
    Else
        strTemp = "否"
    End If
    Print #nFile, strTemp
End Sub

Private Sub OutputData3(objBox As ListBox, nFile As Integer)
    Dim i As Integer, count As Integer, index As Integer
    '获得列表框列表数目
    count = objBox.ListCount
    '获得列表框当前选项的的索引号
    index = objBox.ListIndex
    '输出列表框列表数目
    Write #nFile, count
    '输出列表框当前选项的的索引号
    Write #nFile, index
    '输出所有的列表框选项
    For i = 0 To count - 1
        Print #nFile, objBox.List(i)
    Next
   
End Sub

Private Sub InputData(objBox As ComboBox, nFile As Integer)
    Dim i As Integer, count As Integer, index As Integer
    Dim strTemp As String
    '读入一行文本并存储在变量中
    Line Input #nFile, strTemp
    '读入组合框列表数目
    Input #nFile, count
    '读入组合框当前元素的的索引号
    Input #nFile, index
    '清空组合框所有元素
    objBox.Clear
    '读入组合框元素
    For i = 0 To count - 1
        Line Input #nFile, strTemp
        '将读入的列表添加到组合框中
        objBox.AddItem strTemp
    Next
    ' 设置组合框初始选项
    With objBox
        '使用下拉列表的形式
        .Style = fmStyleDropDownList
        '设置下拉列表的下标下限
        .BoundColumn = 0
        '设置默认的显示项目
        .ListIndex = index
    End With
   
End Sub

Private Sub InputData2(objBox As CheckBox, nFile As Integer)
    Dim strTemp As String
    '读入一行文本并存储在变量中
    Line Input #nFile, strTemp
    '读入复选框选中状态
    Input #nFile, strTemp
    '设置复选按钮选择状态
    If strTemp = "是" Then
        objBox.Value = True
    Else
        objBox.Value = False
    End If
End Sub

Private Sub InputData3(objBox As ListBox, nFile As Integer)
    Dim i As Integer, count As Integer, index As Integer
    Dim strTemp As String
    '读入一行文本并存储在变量中
    Line Input #nFile, strTemp
    '读入列表框列表数目
    Input #nFile, count
    '读入列表框当前元素的的索引号
    Input #nFile, index
    '清空列表框所有元素
    objBox.Clear
    '读入列表框元素
    For i = 0 To count - 1
        Line Input #nFile, strTemp
        '将读入的列表添加到列表框中
        objBox.AddItem strTemp
    Next
    ' 设置组合框初始选项
    With objBox
        '设置下拉列表的下标下限
        .BoundColumn = 0
        '设置默认的显示项目
        .ListIndex = index
    End With
   
End Sub

Public Sub SetPrinter()
    ' 设置打印机配置
    objLayout.ConfigName = cboPrintersName.Text
    ' 设置打印样式表
    objLayout.StyleSheet = cboPlotStyleTableNames.Text
    ' 设置图纸尺寸
    objLayout.CanonicalMediaName = cboPaperSize.Text
    ' 设置图纸单位
    If optMillimeters.Value = True Then
        objLayout.PaperUnits = acMillimeters
    Else
        objLayout.PaperUnits = acInches
    End If
    ' 设置图纸打印方向
    If optVertical.Value = True Then
        If chkReverse.Value = False Then
            objLayout.PlotRotation = ac0degrees
        Else
            objLayout.PlotRotation = ac180degrees
        End If
    Else
        If chkReverse.Value = False Then
            objLayout.PlotRotation = ac90degrees
        Else
            objLayout.PlotRotation = ac270degrees
        End If
    End If
    ' 设置图纸打印比例
    If cboPlotScale.Value Then
        objLayout.UseStandardScale = True  '使用标准打印比例
    Else
        objLayout.UseStandardScale = False '使用自定义打印比例
    End If
    Select Case cboPlotScale.Value
    Case 0
        '设置自定义打印比例
        objLayout.SetCustomScale txtNumerator.Value, txtDenominator.Value
    Case 1
        objLayout.StandardScale = acScaleToFit
    Case 2
        objLayout.StandardScale = ac1_1
    Case 3
        objLayout.StandardScale = ac1_2
    Case 4
        objLayout.StandardScale = ac1_4
    Case 5
        objLayout.StandardScale = ac1_8
    Case 6
        objLayout.StandardScale = ac1_10
    Case 7
        objLayout.StandardScale = ac1_16
    Case 8
        objLayout.StandardScale = ac1_20
    Case 9
        objLayout.StandardScale = ac1_30
    Case 10
        objLayout.StandardScale = ac1_40
    Case 11
        objLayout.StandardScale = ac1_50
    Case 12
        objLayout.StandardScale = ac1_100
    Case 13
        objLayout.StandardScale = ac2_1
    Case 14
        objLayout.StandardScale = ac4_1
    Case 15
        objLayout.StandardScale = ac8_1
    Case 16
        objLayout.StandardScale = ac10_1
    Case 17
        objLayout.StandardScale = ac100_1
    End Select
    ' 设置图纸是否居中打印
    If chkCenterPlot.Value Then
        objLayout.CenterPlot = True
    Else
        ' 设置自定义打印偏移
        Dim PtOffset(0 To 1) As Double
        PtOffset(0) = txtOffsetX.Value
        PtOffset(1) = txtOffsetY.Value
        objLayout.CenterPlot = False
        objLayout.PlotOrigin = PtOffset
    End If
   
    '设置是否打印对象线宽
    If chkPlotWithLineweights.Enabled = True Then
        If chkPlotWithLineweights.Value Then
            '打印时使用图形文件中的线宽
            objLayout.PlotWithLineweights = True
         Else
            '打印时使用打印样式中的线宽
            objLayout.PlotWithLineweights = False
        End If
    End If
    '设置是否应用打印样式
    If chkPlotWithPlotStyles.Value Then
        '打印时在对象中使用打印样式
        objLayout.PlotWithPlotStyles = True
        chkPlotWithLineweights.Enabled = False
    Else
        '打印时在对象中不使用打印样式
        objLayout.PlotWithPlotStyles = False
        chkPlotWithLineweights.Enabled = True
    End If
    If chkPlotHidden.Enabled = True Then
         '设置是否隐藏图纸空间对象
        If chkPlotHidden.Value Then
            '打印时隐藏图纸空间对象
            objLayout.PlotHidden = True
        Else
            '打印时不隐藏图纸空间对象
            objLayout.PlotHidden = False
        End If
    End If
    ' 设置打印类型（对应AutoCAD中：打印>打印设置>打印区域>窗口）
    objLayout.PlotType = acWindow
   
    ' 设置图纸打印份数
    objPlot.NumberOfCopies = txtNumber.Value
    ' 将打印错误报告切换为静默错误模式，以便不间断地执行打印任务
    objPlot.QuietErrorMode = True

End Sub

Private Sub BatchPlotByBlock(strBlockReferenceName As String)
    On Error Resume Next
    '如果列表框中未存在任何元素
    If lstPlotFiles.ListCount = 0 Then
        MsgBox "请先向列表框中添加文件！", vbCritical
        Exit Sub
    End If
    
    '将控制权交给AutoCAD
    frmBatchPlot.Hide
    ' 对第i个图形的每一个打印区域进行打印
    Dim ptMin As Variant, ptMax As Variant
    Dim ent As AcadEntity
    Dim i As Integer, n As Integer
    For i = 0 To lstPlotFiles.ListCount - 1
        n = 1
        '检查文件是否存在
        If Len(Dir(lstPlotFiles.List(i))) = 0 Then
            MsgBox "文件" & lstPlotFiles.List(i) & "不存在！"
        End If
        '打开或激活第i个图形文件
        Call OpenFile(lstPlotFiles.List(i))
        Set objDoc = ThisDrawing.Application.ActiveDocument
        '实现范围缩放
        ThisDrawing.Application.ZoomExtents
        ' 确保当前布局是模型空间
        Set objLayout = objDoc.Layouts.Item("Model")
        Set objPlot = objDoc.Plot
        ' 设置打印选项
        Call SetPrinter
        '重新生成当前图形
        objDoc.Regen acAllViewports
        ' 确保AutoCAD在前台进行打印，这样后一次打印会在前一次打印完成之后才开始
        ' 避免出现错误
        objDoc.SetVariable "BACKGROUNDPLOT", 0
        '对当前图形模型空间中的所有打印区域进行打印
        For Each ent In objDoc.ModelSpace
        If TypeOf ent Is AcadBlockReference Then
            If StrComp(ent.Name, strBlockReferenceName, vbTextCompare) = 0 Then
                ent.GetBoundingBox ptMin, ptMax
                       
                ' 将三维点转化为二维点坐标
                ReDim Preserve ptMin(0 To 1)
                ReDim Preserve ptMax(0 To 1)
           
                ' 设置打印窗口
                objLayout.SetWindowToPlot ptMin, ptMax
               
                ' 打印当前的区域
                '若选中“打印到文件”
                If chkPlotToFile.Value Then
                    objPlot.PlotToFile cboPlotPath.Text & objDoc.Name & "-" & n & ".dwf"
                    n = n + 1
                Else
                   objPlot.PlotToDevice objLayout.ConfigName
                End If
            End If
        End If
        Next ent
        ' 恢复系统变量的值
        objDoc.SetVariable "BACKGROUNDPLOT", 2
        '保存当前图形
        'objDoc.Save
        '关闭但不保存当前图形
        '保证至少一个文件打开
        If ThisDrawing.Application.Documents.count > 1 Then
            objDoc.Close False
        End If
    Next i
    '显示对话框
    frmBatchPlot.Show
End Sub

Private Sub BatchPlotByLayer(strLayerName As String)
    On Error Resume Next
    '如果列表框中未存在任何元素
    If lstPlotFiles.ListCount = 0 Then
        MsgBox "请先向列表框中添加文件！", vbCritical
        Exit Sub
    End If
    
    '将控制权交给AutoCAD
    frmBatchPlot.Hide
    ' 对第i个图形的每一个打印区域进行打印
    Dim ptMin As Variant, ptMax As Variant
    Dim ent As AcadEntity
    Dim i As Integer, n As Integer
    For i = 0 To lstPlotFiles.ListCount - 1
        n = 1
        '检查文件是否存在
        If Len(Dir(lstPlotFiles.List(i))) = 0 Then
            MsgBox "文件" & lstPlotFiles.List(i) & "不存在！"
        End If
        '打开或激活第i个图形文件
        Call OpenFile(lstPlotFiles.List(i))
        Set objDoc = ThisDrawing.Application.ActiveDocument
        '实现范围缩放
        ThisDrawing.Application.ZoomExtents
        ' 确保当前布局是模型空间
        Set objLayout = objDoc.Layouts.Item("Model")
        Set objPlot = objDoc.Plot
        ' 设置打印选项
        Call SetPrinter
        '重新生成当前图形
        objDoc.Regen acAllViewports
        ' 确保AutoCAD在前台进行打印，这样后一次打印会在前一次打印完成之后才开始
        ' 避免出现错误
        objDoc.SetVariable "BACKGROUNDPLOT", 0
        '对当前图形模型空间中的所有打印区域进行打印
        For Each ent In objDoc.ModelSpace
        If StrComp(ent.Layer, strLayerName, vbTextCompare) = 0 Then
            If TypeOf ent Is AcadLWPolyline Then
                ent.GetBoundingBox ptMin, ptMax
                       
                ' 将三维点转化为二维点坐标
                ReDim Preserve ptMin(0 To 1)
                ReDim Preserve ptMax(0 To 1)
           
                ' 设置打印窗口
                objLayout.SetWindowToPlot ptMin, ptMax
               
                ' 打印当前的区域
                '若选中“打印到文件”
                If chkPlotToFile.Value Then
                    objPlot.PlotToFile cboPlotPath.Text & objDoc.Name & "-" & n & ".dwf"
                    n = n + 1
                Else
                   objPlot.PlotToDevice objLayout.ConfigName
                End If
            End If
        End If
        Next ent
        ' 恢复系统变量的值
        objDoc.SetVariable "BACKGROUNDPLOT", 2
        '保存当前图形
        'objDoc.Save
        '关闭但不保存当前图形
        '保证至少一个文件打开
        If ThisDrawing.Application.Documents.count > 1 Then
            objDoc.Close False
        End If
    Next i
    '显示对话框
    frmBatchPlot.Show
End Sub

Private Sub PreviewByBlock(strBlockReferenceName As String)
    '如果列表框中未存在任何元素
    If lstPlotFiles.ListCount = 0 Then
        MsgBox "请先向列表框中添加文件！", vbCritical
        Exit Sub
    End If
    
    '将控制权交给AutoCAD
    frmBatchPlot.Hide
    ' 对第一个图形的第一个打印区域进行完全预览
    Dim ptMin As Variant, ptMax As Variant
    Dim ent As AcadEntity
    Dim i As Integer, n As Integer
    For i = 0 To lstPlotFiles.ListCount - 1
        n = 1
        '检查文件是否存在
        If Len(Dir(lstPlotFiles.List(i))) = 0 Then
            MsgBox "文件" & lstPlotFiles.List(i) & "不存在！"
        End If
        '打开或激活第i个图形文件
        Call OpenFile(lstPlotFiles.List(i))
        Set objDoc = ThisDrawing.Application.ActiveDocument
        '实现范围缩放
        ThisDrawing.Application.ZoomExtents
        ' 确保当前布局是模型空间
        Set objLayout = objDoc.Layouts.Item("Model")
        Set objPlot = objDoc.Plot
        ' 设置打印选项
        Call SetPrinter
         '重新生成当前图形
        objDoc.Regen acAllViewports
        ' 确保AutoCAD在前台进行打印，这样后一次打印会在前一次打印完成之后才开始
        ' 避免出现错误
        'ThisDrawing.SetVariable "BACKGROUNDPLOT", 0
        '对当前图形模型空间中的所有打印区域进行打印
        For Each ent In objDoc.ModelSpace
        If TypeOf ent Is AcadBlockReference Then
            If StrComp(ent.Name, strBlockReferenceName, vbTextCompare) = 0 Then
                ent.GetBoundingBox ptMin, ptMax
                       
                ' 将三维点转化为二维点坐标
                ReDim Preserve ptMin(0 To 1)
                ReDim Preserve ptMax(0 To 1)
           
                ' 设置打印窗口
                ThisDrawing.ActiveLayout.SetWindowToPlot ptMin, ptMax
               
                '完全预览当前的区域
                objPlot.DisplayPlotPreview acFullPreview
                 n = n + 1
                 If n > 1 Then
                     '显示对话框
                     frmBatchPlot.Show
                     Exit Sub
                 End If
           
            End If
        End If
        Next ent
       
        '保存当前图形
        'objDoc.Save
        '关闭但不保存当前图形
        '保证至少一个文件打开
        If ThisDrawing.Application.Documents.count > 1 Then
            objDoc.Close False
        End If
    Next i

End Sub

Private Sub PreviewByLayer(strLayerName As String)
    '如果列表框中未存在任何元素
    If lstPlotFiles.ListCount = 0 Then
        MsgBox "请先向列表框中添加文件！", vbCritical
        Exit Sub
    End If
    
    '将控制权交给AutoCAD
    frmBatchPlot.Hide
    ' 对第一个图形的第一个打印区域进行完全预览
    Dim ptMin As Variant, ptMax As Variant
    Dim ent As AcadEntity
    Dim i As Integer, n As Integer
    For i = 0 To lstPlotFiles.ListCount - 1
        n = 1
        '检查文件是否存在
        If Len(Dir(lstPlotFiles.List(i))) = 0 Then
            MsgBox "文件" & lstPlotFiles.List(i) & "不存在！"
        End If
        '打开或激活第i个图形文件
        Call OpenFile(lstPlotFiles.List(i))
        Set objDoc = ThisDrawing.Application.ActiveDocument
        '实现范围缩放
        ThisDrawing.Application.ZoomExtents
        ' 确保当前布局是模型空间
        Set objLayout = objDoc.Layouts.Item("Model")
        Set objPlot = objDoc.Plot
        ' 设置打印选项
        Call SetPrinter
        '重新生成当前图形
        objDoc.Regen acAllViewports
        ' 确保AutoCAD在前台进行打印，这样后一次打印会在前一次打印完成之后才开始
        ' 避免出现错误
        'ThisDrawing.SetVariable "BACKGROUNDPLOT", 0
        '对当前图形模型空间中的所有打印区域进行完全预览
        For Each ent In ThisDrawing.ModelSpace
        If StrComp(ent.Layer, strLayerName, vbTextCompare) = 0 Then
            If TypeOf ent Is AcadLWPolyline Then
                ent.GetBoundingBox ptMin, ptMax
                       
                ' 将三维点转化为二维点坐标
                ReDim Preserve ptMin(0 To 1)
                ReDim Preserve ptMax(0 To 1)
           
                ' 设置打印窗口
                ThisDrawing.ActiveLayout.SetWindowToPlot ptMin, ptMax
               
                '完全预览当前的区域
                objPlot.DisplayPlotPreview acFullPreview
                 n = n + 1
                 If n > 1 Then
                     '显示对话框
                     frmBatchPlot.Show
                     Exit Sub
                 End If
           
            End If
        End If
        Next ent
       
        '保存当前图形
        'objDoc.Save
        '关闭但不保存当前图形
        '保证至少一个文件打开
        If ThisDrawing.Application.Documents.count > 1 Then
            objDoc.Close False
        End If
    Next i
   
End Sub

 

牵牛

楼主你好 你的代码好像只能打印“模型”窗口的图纸，布局空间的该如何打印，简单说 我想打印包括模型、所有布局空间中的图纸 该如何实现 期待您的回复 我最近是想做个打印集合 很想实现这个功能 还望您能给指导一下

xyghzzj

整整花了一周时间，总算能用了。虽然不是很完美，以后就考大家完善了。

使用方法：解压到*:\Program Files\AutoCAD 2004\Support下，在工具－>自定义－>菜单中加载CADBatchPlot.mns即可。

xyghzzj

Public Sub BatchPlot()
    '显示主对话框
    frmBatchPlot.Show
End Sub

Public Sub ShowAbout()
    '显示关于对话框
    frmAbout.Show
End Sub

fanny_6

粗粗看了以下，程序写的相当精彩，相当高手。
我调试了以下，没有问题。
题几个建议：
1、横向、纵向纸张的打印可以自动识别（根据矩形的长宽）
2、A3、A4自动识别，有两种实现方法，推荐方案2
方法1、根据不同的块名；
方法2：由于一般工程的出图，一般框的长宽比例都是一定的，且A3、A4的比例不会一样，所以，可以这样：长宽比例为a值附近的打印成A4，长宽比例为b值附近的的、打印成A3，分界点由用户设置。
其实1、2两点总结一下就是根据图框的长宽比例，采用不同的打印样式打印
3、分图层打印：如共1、2、3图层，1、2图层打一张，2、3图层打一张
（根据打印图框名或图框的图层来判断是否分层打印）
4、打印设置的默认值由用户设置
5、我现在仅对当前图纸进行批量打印，如果用你的程序就必须再添加一次该图纸，
这样好像不大方便。
6、方面起见，选择文件路径的这个框，每次显示初始位置，应该为上次打印的路径，而不是“我的电脑”
7、举例：10个文件，每个文件2张图纸，现在只要求打印第一张，你的程序是不能实现的
，建议可以设置，比如只打印左上角这一张。

wyj7485

确实很好,慢慢研究一下...

tractor

看到高手的代码，忍不禁下载下来，慢慢研究一下！明经是我的启蒙老师，亦是我现在和将来的老师！

lijiao

程序好长，功夫不错。

我也有一个类似的程序，是用VL写的，设置了几个命令，设置打印区、删除打印区、单文件打印和批量打印。

大致思路是设置打印区时，将文件名和打印区域的坐标自动写入一个文本文件（打印配置文件），打印时，从配置文件中找出打印数据即可。

wylong

不错不错

xiangzhong

相当赞啊