明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
楼主: xyghzzj

自己用VBA编的批量打印程序(原创)

    [复制链接]
发表于 2008-4-16 11:06 | 显示全部楼层
非常感谢!!
发表于 2008-6-5 13:21 | 显示全部楼层
下来看看                
发表于 2008-6-5 21:52 | 显示全部楼层
请问CAD2006如何加载CADBatchPlot.mns 呢,另外CAD2006版本不能使用这个程序吗?
发表于 2009-2-20 23:53 | 显示全部楼层

我也下了,过段时间就学习

发表于 2009-2-23 16:01 | 显示全部楼层
可能大家的应用情况不同。我自己也写了个自动打印程序。我用的办法是识别图纸外框多段线的长度来自动识别图纸的位置。因为a3,a4图纸的周长是固定,所以不用去选择坐标。运行程序,全部自动打印。。。还有很多不完善的地方,不过自己公司的够用了
发表于 2009-3-10 10:35 | 显示全部楼层
顶你一下吧,很好的东西
 楼主| 发表于 2009-7-22 00:11 | 显示全部楼层

2009.7.21更新:

可以设置打印顺序为先行后列即Z型,或者先列后行的N型打印

 楼主| 发表于 2009-7-22 00:15 | 显示全部楼层
源代码见附件。

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2009-7-22 00:25 | 显示全部楼层
下来参考一下。辛苦。
 楼主| 发表于 2009-7-22 00:26 | 显示全部楼层

Option Explicit
'图形集合
Private colDwgs As New Collection
'文档对象
Private objDoc As AcadDocument
'布局对象
Private objLayout As AcadLayout
'打印配置集合
Private objPlotConfigurations As AcadPlotConfigurations
'打印配置
Private objPlotConfiguration As AcadPlotConfiguration
Private objOriginalPC As AcadPlotConfiguration
'打印对象
Private objPlot As AcadPlot
'图纸尺寸名称数组
Private paperSizes  As Variant
Private Numerator As Double, Denominator As Double
Private OffsetX As Double, OffsetY As Double
Private ms As Boolean

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
        ' 设置图纸尺寸
        objPlotConfiguration.CanonicalMediaName = paperSizes(cboPaperSize.ListIndex)
        ' 显示图纸尺寸
        Call SetPlotZone
        ' 当居中打印时重新计算打印偏移
        If chkCenterPlot.Value Then Call SetOffset
    End If
End Sub

Private Sub cboPlotScale_Click()
    '定义图纸尺寸数组
    Dim Nu, De
    '定义分子数组
    Nu = Array(" ", "", "1", "1", "1", "1", "1", "1", "1", "1", _
        "1", "1", "1", "1", "1", "1", "1", "1", "1", "1", _
        "1", "1", "1", "1", "1", "1", "1", "1", "1", "1", _
        "1", "1", "1")
    '定义分母数组
    De = Array(" ", "", "1", "2", "4", "8", "10", "16", "20", "30", _
        "40", "50", "100", "0.5", "0.25", "0.125", "0.1", "0.01", "1536", "768", _
        "384", "192", "128", "96", "64", "48", "32", "24", "16", "12", _
        "4", "2", "1")
   
    '设置默认的显示项目
    If cboPlotScale.ListIndex = 0 Then
        '使用自定义比例
        Numerator = 1
        Denominator = 1
        txtNumerator.Text = Numerator
        txtDenominator.Text = Denominator
    Else
        If cboPlotScale.ListIndex > 1 Then
            Numerator = Nu(cboPlotScale.ListIndex)
            Denominator = De(cboPlotScale.ListIndex)
            txtNumerator.Text = Numerator
            txtDenominator.Text = Denominator
        Else
            '计算缩放比例
            Call SetScaleToFit
        End If
    End If
    Dim Q1
    '定义组合框索引到打印比例枚举值的映射
    Q1 = Array(100, 0, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, _
        1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15)
    ' 设置图纸打印比例
    If cboPlotScale.ListIndex <> 0 Then
        '使用标准打印比例
        objPlotConfiguration.UseStandardScale = True
        '设置标准打印比例
        objPlotConfiguration.StandardScale = Q1(cboPlotScale.ListIndex)
    Else
        '使用自定义打印比例
        objPlotConfiguration.UseStandardScale = False
        '设置自定义打印比例
        objPlotConfiguration.SetCustomScale Numerator, Denominator
    End If
   
    ' 当居中打印时重新计算打印偏移
    If chkCenterPlot.Value Then Call SetOffset

End Sub

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

Private Sub cboPrintersName_Click()
    '设置打印机配置
    objPlotConfiguration.ConfigName = cboPrintersName.Text
    '更新显示AutoCAD中当前可用的所有图纸尺寸
    Call ListPaperSize
End Sub

Private Sub chkCenterPlot_Click()
    On Error Resume Next
    If chkCenterPlot.Value Then
        ' 设置图纸是否居中打印
        objPlotConfiguration.CenterPlot = True
        '计算打印偏移
        Call SetOffset
    Else
        ' 设置图纸是否居中打印
        objPlotConfiguration.CenterPlot = False
        OffsetX = 0
        OffsetY = 0
        '设置文本框文本
        txtOffsetX.Text = "0.00"
        txtOffsetY.Text = "0.00"
    End If
   
End Sub

Public Sub SetOffset()
    'On Error Resume Next
    Dim PaperWidth As Double, PaperHeight As Double, t As Double
    Dim PlotWidth As Double, PlotHeight As Double
    Dim WindowWidth As Double, WindowHeight As Double
    Dim MarginLowerLeft As Variant, MarginUpperRight As Variant
    Dim WindowLowerLeft As Variant, WindowUpperRight As Variant
    '刷新打印设备信息
    objPlotConfiguration.RefreshPlotDeviceInfo
    '取得图纸尺寸信息
    objPlotConfiguration.GetPaperSize PaperWidth, PaperHeight
    '取得图纸边界信息
    objPlotConfiguration.GetPaperMargins MarginLowerLeft, MarginUpperRight
    '计算打印区域
    PlotWidth = PaperWidth - (MarginUpperRight(0) + MarginLowerLeft(0))
    PlotHeight = PaperHeight - (MarginUpperRight(1) + MarginLowerLeft(1))
    '根据选择的图形方向调换宽高
    If optVertical.Value Then
        '图形方向为“纵向”时宽小于高
        If PlotWidth > PlotHeight Then
            t = PlotWidth
            PlotWidth = PlotHeight
            PlotHeight = t
        End If
    Else
        '图形方向为“横向”时宽大于高
        If PlotWidth < PlotHeight Then
            t = PlotWidth
            PlotWidth = PlotHeight
            PlotHeight = t
        End If
    End If

    '单位由“英寸”转换为“毫米”的比例因子
    Dim scaleUnit As Double
    scaleUnit = IIf(optMillimeters.Value, 1, 25.4)
    '获得打印窗口尺寸
    objPlotConfiguration.GetWindowToPlot WindowLowerLeft, WindowUpperRight
    WindowWidth = WindowUpperRight(0) - WindowLowerLeft(0)
    WindowHeight = WindowUpperRight(1) - WindowLowerLeft(1)
    '获得缩放后的打印窗口尺寸
    WindowWidth = WindowWidth * Numerator / Denominator * scaleUnit
    WindowHeight = WindowHeight * Numerator / Denominator * scaleUnit
    '计算打印偏移
    OffsetX = (PlotWidth - WindowWidth) / 2
    OffsetY = (PlotHeight - WindowHeight) / 2
    Dim X As Double, Y As Double
    '单位由“毫米”转换为“英寸”
    X = IIf(optMillimeters.Value, OffsetX, OffsetX / 25.4)
    Y = IIf(optMillimeters.Value, OffsetY, OffsetY / 25.4)
    '设置文本框文本
    txtOffsetX.Text = Format(X, "#########0.00")
    txtOffsetY.Text = Format(Y, "#########0.00")
   
End Sub

Private Sub chkOnlyPlotThis_Change()
    '设置“打印到文件”组各控件激活状态
    If chkOnlyPlotThis.Value Then
        '清除列表框中所有元素
        lstPlotFiles.Clear
        '获得当前图形名
        Dim strTemp As String
        strTemp = ThisDrawing.Application.ActiveDocument.Path & "\" & ThisDrawing.Application.ActiveDocument.name
        '向列表框添加当前图形
        lstPlotFiles.AddItem strTemp
        cmdBrowse.Enabled = False
        cmdAdd.Enabled = False
        cmdAddAll.Enabled = False
        cmdClear.Enabled = False
        cmdClearAll.Enabled = False
        lstCurFiles.Enabled = False
        lstPlotFiles.Enabled = False
    Else
        cmdBrowse.Enabled = True
        cmdAdd.Enabled = True
        cmdAddAll.Enabled = True
        cmdClear.Enabled = True
        cmdClearAll.Enabled = True
        lstCurFiles.Enabled = True
        lstPlotFiles.Enabled = True
    End If

End Sub

Private Sub chkPlotHidden_Change()
    '设置是否隐藏图纸空间对象
    If Not objPlotConfiguration.ModelType Then _
        objPlotConfiguration.PlotHidden = chkPlotHidden.Value
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 Not chkPlotWithPlotStyles.Value Then _
        objPlotConfiguration.PlotWithLineweights = chkPlotWithLineweights.Value
End Sub

Private Sub chkPlotWithPlotStyles_Change()
    '设置是否应用打印样式
    objPlotConfiguration.PlotWithPlotStyles = chkPlotWithPlotStyles.Value
    chkPlotWithLineweights.Enabled = Not (chkPlotWithPlotStyles.Value)
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|所有文件(*.*)|*.*"
        '显示[打开]对话框
        .ShowOpen
    End With
   
    Dim strFileName As String
    strFileName = comDlg.fileName
    '若返回文件名为空,不进行操作
    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 InputData2(chkOnlyPlotThis, 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 ListPlotDeviceNames
End Sub

Private Sub cmdOutput_Click()
    '导出打印设置
    '设置标准对话框
    With comDlg
        '设置标准对话框标题
        .DialogTitle = "导出打印设置"
        '设置标准对话框类型列表中所显示的过滤器
        .filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
        '设置[另存为]对话框的缺省扩展名
        .DefaultExt = "txt"
        '显示[另存为]对话框
        .ShowSave
    End With
   
    Dim strFileName As String, strTemp As String
    strFileName = comDlg.fileName
    '若返回文件名为空,不进行操作
    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 OutputData2(chkOnlyPlotThis, 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 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 Label26_Click()

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 And ms = False) Then
        '设置图纸单位
        objPlotConfiguration.PaperUnits = acMillimeters
        '修改标签
        lbUnit.Caption = "毫米 ="
        lbUnitX.Caption = "毫米"
        lbUnitY.Caption = "毫米"
        lbPaperUnit.Caption = "毫米"
        Denominator = Denominator / 25.4
        txtDenominator.Text = Format(Denominator, "#########0.000")
        txtOffsetX.Text = Format(OffsetX, "#########0.00")
        txtOffsetY.Text = Format(OffsetY, "#########0.00")
    ElseIf (optMillimeters.Value = False And ms = True) Then
        '设置图纸单位
        objPlotConfiguration.PaperUnits = acInches
        '修改标签
        lbUnit.Caption = "英寸 ="
        lbUnitX.Caption = "英寸"
        lbUnitY.Caption = "英寸"
        lbPaperUnit.Caption = "英寸"
        Denominator = Denominator * 25.4
        txtDenominator.Text = Format(Denominator, "#########0.000")
        txtOffsetX.Text = Format(OffsetX / 25.4, "#########0.00")
        txtOffsetY.Text = Format(OffsetY / 25.4, "#########0.00")
    End If
   
    '非“按图纸空间缩放”时由标准比例变为自定义比例
    If cboPlotScale.ListIndex > 1 Then cboPlotScale.ListIndex = 0
   
    '显示图纸尺寸
    Call SetPlotZone
   
    ms = optMillimeters.Value
End Sub

Private Sub optSortZ_Click()

End Sub

Private Sub OptVertical_Change()
    '设置图纸打印方向
    Call PaperRotationChange
    '当图纸比例选项为“按图纸空间缩放”时重新计算缩放比例
    If cboPlotScale.ListIndex = 1 Then Call SetScaleToFit
    ' 当居中打印时重新计算打印偏移
    If chkCenterPlot.Value Then Call SetOffset
   
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_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    ' 设置自定义图纸尺寸
    If IsNumeric(CDbl(txtDenominator.Text)) Then
        Dim strTemp As String
        '记住文本框文本
        strTemp = txtDenominator.Text
        '设置组合框显示项目为“自定义”
        cboPlotScale.ListIndex = 0
        '恢复文本框文字(上步操作有时会导致文本框值归1)
        txtDenominator.Text = strTemp
        '将文本框文本转换为实数
        Denominator = CDbl(txtDenominator.Text)
        '使用自定义打印比例
        objPlotConfiguration.UseStandardScale = False
        '设置自定义打印比例
        objPlotConfiguration.SetCustomScale Numerator, Denominator
        ' 当居中打印时重新计算打印偏移
        If chkCenterPlot.Value Then Call SetOffset
    Else
        MsgBox "请输入数字!", vbCritical
    End If
End Sub

Private Sub txtNumerator_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    ' 设置自定义图纸尺寸
    If IsNumeric(CDbl(txtNumerator.Text)) Then
        Dim strTemp As String
        '记住文本框文本
        strTemp = txtNumerator.Text
        '设置组合框显示项目为“自定义”
        cboPlotScale.ListIndex = 0
        '恢复文本框文字(上步操作有时会导致文本框值归1)
        txtNumerator.Text = strTemp
         '将文本框文本转换为实数
        Numerator = CDbl(txtNumerator.Text)
        '使用自定义打印比例
        objPlotConfiguration.UseStandardScale = False
        '设置自定义打印比例
        objPlotConfiguration.SetCustomScale Numerator, Denominator
        ' 当居中打印时重新计算打印偏移
        If chkCenterPlot.Value Then Call SetOffset
    Else
        MsgBox "请输入数字!", vbCritical
    End If
End Sub

Private Sub txtOffsetX_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    ' 输入检查
     If Not ((KeyAscii >= Asc("0") And KeyAscii <= Asc("9")) Or KeyAscii = Asc(".") Or KeyAscii = Asc("-")) Then
         MsgBox "请输入数字!", vbCritical
     End If
End Sub

Private Sub txtOffsetX_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
     On Error Resume Next
     ' 设置自定义图纸尺寸
     If IsNumeric(CDbl(txtOffsetX.Text)) Then
         Dim strTemp As String
         '记住文本框文本
         strTemp = txtOffsetX.Text
         '将文本框文本转换为实数
         OffsetX = CDbl(txtOffsetX.Text)
         '取消“居中打印”复选框
         chkCenterPlot.Value = False
         '恢复文本框文字(上步操作有时会导致文本框值归零)
         txtOffsetX.Text = strTemp
         Dim ptPlotOrigin(0 To 1) As Double
         '设置自定义打印偏移
         '图形方向为“横向”时宽高互调
         ptPlotOrigin(0) = IIf(optVertical.Value, OffsetX, OffsetY)
         ptPlotOrigin(1) = IIf(optVertical.Value, OffsetY, OffsetX)
         objPlotConfiguration.CenterPlot = False
         objPlotConfiguration.PlotOrigin = ptPlotOrigin
     Else
         MsgBox "请输入数字!", vbCritical
     End If
End Sub

Private Sub txtOffsetY_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
     ' 输入检查
     If Not ((KeyAscii >= Asc("0") And KeyAscii <= Asc("9")) Or KeyAscii = Asc(".") Or KeyAscii = Asc("-")) Then
         MsgBox "请输入数字!", vbCritical
     End If
End Sub

Private Sub txtOffsetY_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    On Error Resume Next
     ' 设置自定义图纸尺寸
     If IsNumeric(CDbl(txtOffsetY.Text)) Then
         Dim strTemp As String
         '记住文本框文本
         strTemp = txtOffsetY.Text
         '将文本框文本转换为实数
         OffsetY = CDbl(txtOffsetY.Text)
         '取消“居中打印”复选框
         chkCenterPlot.Value = False
          '恢复文本框文字(上步操作有时会导致文本框值归零)
         txtOffsetY.Text = strTemp
         Dim ptPlotOrigin(0 To 1) As Double
         '设置自定义打印偏移
         '图形方向为“横向”时宽高互调
         ptPlotOrigin(0) = IIf(optVertical.Value, OffsetX, OffsetY)
         ptPlotOrigin(1) = IIf(optVertical.Value, OffsetY, OffsetX)
         objPlotConfiguration.CenterPlot = False
         objPlotConfiguration.PlotOrigin = ptPlotOrigin
     Else
         MsgBox "请输入数字!", vbCritical
     End If
End Sub

Private Sub UserForm_Initialize()
    On Error Resume Next
    '取得当前文档对象
    Set objDoc = ThisDrawing.Application.ActiveDocument
    '取得当前布局对象
    Set objLayout = ThisDrawing.ActiveLayout
    '取得当前打印对象
    Set objPlot = ThisDrawing.Plot
    '从文件对象取得打印配置集合
    Set objPlotConfigurations = ThisDrawing.PlotConfigurations
    '清空以前的打印配置集合
    For Each objPlotConfiguration In objPlotConfigurations
        objPlotConfiguration.Delete
    Next
    '添加打印配置
    Set objOriginalPC = objPlotConfigurations.Add("原来的打印配置", True)
    Set objPlotConfiguration = objPlotConfigurations.Add("我的打印配置", True)
    '复制打印配置
    objOriginalPC.CopyFrom objLayout
    objPlotConfiguration.CopyFrom objLayout
    '重命名打印配置
    objOriginalPC.name = "原来的打印配置"
    objPlotConfiguration.name = "我的打印配置"
   
    '禁用“当前路径”文本框
    txtCurPath.Enabled = False
   
    '设置图纸单位
    If objOriginalPC.PaperUnits = acInches Then
        optInches.Value = True
    Else
        optMillimeters.Value = True
    End If
    '记录上次的图纸单位设置
    ms = optMillimeters.Value
    
    '设置图纸方向
    Call GetPlotRotation
    '刷新打印机列表
    Call ListPlotDeviceNames
    '刷新打印样式表
    Call ListPlotStyleTableNames
    '刷新打印比例列表
    Call ListPlotScale
   
    '设置是否居中打印
    chkCenterPlot.Value = objOriginalPC.CenterPlot
    '设置打印偏移
    If Not chkCenterPlot.Value Then
        Dim ptPlotOrigin As Variant
        '读取打印偏移
        ptPlotOrigin = objOriginalPC.PlotOrigin
        '设置打印偏移
        '图形方向为“横向”时宽高互调
        OffsetX = IIf(optVertical.Value, ptPlotOrigin(0), ptPlotOrigin(1))
        OffsetY = IIf(optVertical.Value, ptPlotOrigin(1), ptPlotOrigin(0))
        txtOffsetX.Text = OffsetX
        txtOffsetY.Text = OffsetY
    End If
   
    '设置图纸打印份数
    txtNumber.Text = objPlot.NumberOfCopies
   
    '设置“打印到文件”是否选中
    chkPlotToFile.Value = False
    '禁用“打印到文件”组各控件
    lbPlotPath.Enabled = False
    cboPlotPath.Enabled = False
    cmdBrowse2.Enabled = False
   
    '设置打印选项
    chkPlotWithPlotStyles.Value = objOriginalPC.PlotWithPlotStyles
    chkPlotWithLineweights.Enabled = Not (chkPlotWithPlotStyles.Value)
    chkPlotWithLineweights.Value = objOriginalPC.PlotWithLineweights
    chkPlotHidden.Value = objOriginalPC.PlotHidden
   
    ' 显示AutoCAD中当前可用的图块
    Call ListBlock
    ' 显示AutoCAD中当前可用的图层
    Call ListLayer
   
End Sub

Public Sub GetPlotRotation()
    Dim PaperWidth As Double, PaperHeight As Double, t As Double
    '取得图纸尺寸信息
    objOriginalPC.GetPaperSize PaperWidth, PaperHeight
    '设置图纸方向
    If PaperWidth < PaperHeight Then
        Select Case objOriginalPC.PlotRotation
            Case ac0degrees
                optVertical.Value = True
                chkReverse.Value = False
            Case ac90degrees
                optHorizontal.Value = True
                chkReverse.Value = False
            Case ac180degrees
                optVertical.Value = True
                chkReverse.Value = True
            Case ac270degrees
                optHorizontal.Value = True
                chkReverse.Value = True
        End Select
    Else
        Select Case objOriginalPC.PlotRotation
            Case ac0degrees
                optHorizontal.Value = True
                chkReverse.Value = False
            Case ac90degrees
                optVertical.Value = True
                chkReverse.Value = False
            Case ac180degrees
                optHorizontal.Value = True
                chkReverse.Value = True
            Case ac270degrees
                optVertical.Value = True
                chkReverse.Value = True
        End Select
    End If
   
End Sub

Public Sub SetPlotRotation()
    Dim PaperWidth As Double, PaperHeight As Double, t As Double
    '取得图纸尺寸信息
    objPlotConfiguration.GetPaperSize PaperWidth, PaperHeight
    ' 设置图纸打印方向
    If PaperWidth < PaperHeight Then
        If optVertical.Value = True Then
            If chkReverse.Value = False Then
                objPlotConfiguration.PlotRotation = ac0degrees
            Else
                objPlotConfiguration.PlotRotation = ac180degrees
            End If
        Else
            If chkReverse.Value = False Then
                objPlotConfiguration.PlotRotation = ac90degrees
            Else
                objPlotConfiguration.PlotRotation = ac270degrees
            End If
        End If
    Else
        If optVertical.Value = True Then
            If chkReverse.Value = False Then
                objPlotConfiguration.PlotRotation = ac90degrees
            Else
                objPlotConfiguration.PlotRotation = ac270degrees
            End If
        Else
            If chkReverse.Value = False Then
                objPlotConfiguration.PlotRotation = ac0degrees
            Else
                objPlotConfiguration.PlotRotation = ac180degrees
            End If
        End If
    End If
   
End Sub

Public Sub SetPlotConfiguration()
    '因有些选项会相互影响,打印前再应用一次打印配置以确保打印成功
    '设置打印机配置
    objPlotConfiguration.ConfigName = cboPrintersName.Text
    ' 设置打印样式表
    objPlotConfiguration.StyleSheet = cboPlotStyleTableNames.Text
    ' 设置图纸尺寸
    objPlotConfiguration.CanonicalMediaName = paperSizes(cboPaperSize.ListIndex)
    '设置图纸单位
    objPlotConfiguration.PaperUnits = IIf(optMillimeters.Value, acMillimeters, acInches)
   
    Dim Q1
     '定义组合框索引到打印比例枚举值的映射
    Q1 = Array(100, 0, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, _
        1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15)
    ' 设置图纸打印比例
    If cboPlotScale.ListIndex <> 0 Then
        '使用标准打印比例
        objPlotConfiguration.UseStandardScale = True
        '设置标准打印比例
        objPlotConfiguration.StandardScale = Q1(cboPlotScale.ListIndex)
    Else
        '使用自定义打印比例
        objPlotConfiguration.UseStandardScale = False
        '设置自定义打印比例
        objPlotConfiguration.SetCustomScale Numerator, Denominator
    End If
   
    ' 设置图纸打印方向
    Call SetPlotRotation
   
    ' 设置图纸是否居中打印
    If chkCenterPlot.Value Then
        objPlotConfiguration.CenterPlot = True
    Else
        '设置自定义打印偏移
        Dim ptPlotOrigin(0 To 1) As Double
        '图形方向为“横向”时宽高互调
        ptPlotOrigin(0) = IIf(optVertical.Value, OffsetX, OffsetY)
        ptPlotOrigin(1) = IIf(optVertical.Value, OffsetY, OffsetX)
        objPlotConfiguration.CenterPlot = False
        objPlotConfiguration.PlotOrigin = ptPlotOrigin
    End If
  
    '设置是否应用打印样式
    objPlotConfiguration.PlotWithPlotStyles = chkPlotWithPlotStyles.Value
    chkPlotWithLineweights.Enabled = Not (chkPlotWithPlotStyles.Value)
    '设置是否打印对象线宽
    If Not objPlotConfiguration.PlotWithPlotStyles Then _
        objPlotConfiguration.PlotWithLineweights = chkPlotWithLineweights.Value
    '设置是否隐藏图纸空间对象
    If Not objPlotConfiguration.ModelType Then objPlotConfiguration.PlotHidden = chkPlotHidden.Value
       
    '设置打印类型
    objPlotConfiguration.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, j 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 SetPlotConfiguration
        ' 将打印设置应用到当前图形
        objLayout.CopyFrom objPlotConfiguration
        '重新生成当前图形
        objDoc.Regen acAllViewports
        ' 确保AutoCAD在前台进行打印,这样后一次打印会在前一次打印完成之后才开始,避免出现错误
        objDoc.SetVariable "BACKGROUNDPLOT", 0
       
        '对当前图形模型空间中的所有打印区域进行打印
        Dim SSet As AcadSelectionSet
        '使用选择集获得对象集合
        Call SelectByBlock(strBlockReferenceName, SSet)
       
        Dim objCollection() As AcadEntity
        ReDim objCollection(SSet.count - 1)
        For j = 0 To SSet.count - 1
            Set objCollection(j) = SSet.Item(j)
        Next j
       
        ' 删除选择集
        SSet.Delete
       
        ' 设置图纸打印顺序
        If optSortZ.Value Then
            '按坐标对图框排序(左右,上下:y坐标从大到小,x坐标从小到大)
            Call SortZ(objCollection())
        Else
            '按坐标对图框排序(上下,左右:x坐标从小到大,y坐标从大到小)
            Call SortN(objCollection())
        End If
       
        ' 若选择倒序
        If chkSort.Value Then
            For j = 0 To UBound(objCollection) / 2
                Set ent = objCollection(j)
                Set objCollection(j) = objCollection(UBound(objCollection) - j)
                Set objCollection(UBound(objCollection) - j) = ent
            Next j
        End If
       
        '对选择集中每个对象进行打印或预览
        For j = 0 To UBound(objCollection)
            '获得每个对象最小包围框的两个角点
            objCollection(j).GetBoundingBox ptMin, ptMax
            '将世界坐标(WCS)转换为显示坐标(DCS)
            Dim PtMax_UCS As Variant
            Dim PtMin_UCS As Variant
            PtMax_UCS = ThisDrawing.Utility.TranslateCoordinates(ptMax, acWorld, acDisplayDCS, False)
            PtMin_UCS = ThisDrawing.Utility.TranslateCoordinates(ptMin, acWorld, acDisplayDCS, False)

            '将三维点转化为二维点坐标
            ReDim Preserve PtMin_UCS(0 To 1)
            ReDim Preserve PtMax_UCS(0 To 1)
           
            ' 设置打印窗口(为显示坐标DCS)
            objLayout.SetWindowToPlot PtMax_UCS, PtMin_UCS

            ' 打印当前的区域
            '若选中“打印到文件”
            If chkPlotToFile.Value Then
                objPlot.PlotToFile cboPlotPath.Text & objDoc.name & "-" & n & ".dwf"
                n = n + 1
            Else
               objPlot.PlotToDevice objLayout.ConfigName
            End If
        Next j
       
        ' 恢复系统变量的值
        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, j 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 SetPlotConfiguration
        ' 将打印设置应用到当前图形
        objLayout.CopyFrom objPlotConfiguration
        '重新生成当前图形
        objDoc.Regen acAllViewports
        ' 确保AutoCAD在前台进行打印,这样后一次打印会在前一次打印完成之后才开始,避免出现错误
        objDoc.SetVariable "BACKGROUNDPLOT", 0
       
        '对当前图形模型空间中的所有打印区域进行打印
        Dim SSet As AcadSelectionSet
        '使用选择集获得对象集合
        Call SelectByLayer(strLayerName, SSet)
       
        Dim objCollection() As AcadEntity
        ReDim objCollection(SSet.count - 1)
        For j = 0 To SSet.count - 1
            Set objCollection(j) = SSet.Item(j)
        Next j
       
        ' 删除选择集
        SSet.Delete
       
        ' 设置图纸打印顺序
        If optSortZ.Value Then
            '按坐标对图框排序(左右,上下:y坐标从大到小,x坐标从小到大)
            Call SortZ(objCollection())
        Else
            '按坐标对图框排序(上下,左右:x坐标从小到大,y坐标从大到小)
            Call SortN(objCollection())
        End If
       
        ' 若选择倒序
        If chkSort.Value Then
            For j = 0 To UBound(objCollection) / 2
                Set ent = objCollection(j)
                Set objCollection(j) = objCollection(UBound(objCollection) - j)
                Set objCollection(UBound(objCollection) - j) = ent
            Next j
        End If
       
        '对选择集中每个对象进行打印或预览
        For j = 0 To UBound(objCollection)
            '获得每个对象最小包围框的两个角点
            objCollection(j).GetBoundingBox ptMin, ptMax
            '将世界坐标(WCS)转换为显示坐标(DCS)
            Dim PtMax_UCS As Variant
            Dim PtMin_UCS As Variant
            PtMax_UCS = ThisDrawing.Utility.TranslateCoordinates(ptMax, acWorld, acDisplayDCS, False)
            PtMin_UCS = ThisDrawing.Utility.TranslateCoordinates(ptMin, acWorld, acDisplayDCS, False)

            '将三维点转化为二维点坐标
            ReDim Preserve PtMin_UCS(0 To 1)
            ReDim Preserve PtMax_UCS(0 To 1)
           
            ' 设置打印窗口(为显示坐标DCS)
            objLayout.SetWindowToPlot PtMax_UCS, PtMin_UCS

            ' 打印当前的区域
            '若选中“打印到文件”
            If chkPlotToFile.Value Then
                objPlot.PlotToFile cboPlotPath.Text & objDoc.name & "-" & n & ".dwf"
                n = n + 1
            Else
               objPlot.PlotToDevice objLayout.ConfigName
            End If
        Next j
       
        ' 恢复系统变量的值
        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)
    On Error Resume Next
    '如果列表框中未存在任何元素
    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, j 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 SetPlotConfiguration
        ' 将打印设置应用到当前图形
        objLayout.CopyFrom objPlotConfiguration
         '重新生成当前图形
        objDoc.Regen acAllViewports
       
        '对当前图形模型空间中的所有打印区域进行完全预览
        Dim SSet As AcadSelectionSet
        '使用选择集获得对象集合
        Call SelectByBlock(strBlockReferenceName, SSet)
       
        Dim objCollection() As AcadEntity
        ReDim objCollection(SSet.count - 1)
        For j = 0 To SSet.count - 1
            Set objCollection(j) = SSet.Item(j)
        Next j
       
        ' 删除选择集
        SSet.Delete
       
        ' 设置图纸打印顺序
        If optSortZ.Value Then
            '按坐标对图框排序(左右,上下:y坐标从大到小,x坐标从小到大)
            Call SortZ(objCollection())
        Else
            '按坐标对图框排序(上下,左右:x坐标从小到大,y坐标从大到小)
            Call SortN(objCollection())
        End If
       
        ' 若选择倒序
        If chkSort.Value Then
            For j = 0 To UBound(objCollection) / 2
                Set ent = objCollection(j)
                Set objCollection(j) = objCollection(UBound(objCollection) - j)
                Set objCollection(UBound(objCollection) - j) = ent
            Next j
        End If
       
        '对选择集中每个对象进行打印或预览
        For j = 0 To UBound(objCollection)
            '获得每个对象最小包围框的两个角点
            objCollection(j).GetBoundingBox ptMin, ptMax
            '将世界坐标(WCS)转换为显示坐标(DCS)
            Dim PtMax_UCS As Variant
            Dim PtMin_UCS As Variant
            PtMax_UCS = ThisDrawing.Utility.TranslateCoordinates(ptMax, acWorld, acDisplayDCS, False)
            PtMin_UCS = ThisDrawing.Utility.TranslateCoordinates(ptMin, acWorld, acDisplayDCS, False)

            '将三维点转化为二维点坐标
            ReDim Preserve PtMin_UCS(0 To 1)
            ReDim Preserve PtMax_UCS(0 To 1)
           
            ' 设置打印窗口(为显示坐标DCS)
            objLayout.SetWindowToPlot PtMax_UCS, PtMin_UCS

            '完全预览当前的区域
            objPlot.DisplayPlotPreview acFullPreview
             n = n + 1
             If n > 1 Then
                 '恢复原来的打印设置
                 objLayout.CopyFrom objOriginalPC
                 '显示对话框
                 frmBatchPlot.Show
                 Exit Sub
             End If
        Next j
    Next i
       
    '无打印区域时显示对话框
    MsgBox "选定图形中无打印区域!", vbCritical
    '恢复原来的打印设置
    objLayout.CopyFrom objOriginalPC
    '显示对话框
    frmBatchPlot.Show
   
End Sub

Private Sub PreviewByLayer(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, j 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 SetPlotConfiguration
        ' 将打印设置应用到当前图形
        objLayout.CopyFrom objPlotConfiguration
        '重新生成当前图形
        objDoc.Regen acAllViewports
       
        '对当前图形模型空间中的所有打印区域进行完全预览
        Dim SSet As AcadSelectionSet
        '使用选择集获得对象集合
        Call SelectByLayer(strLayerName, SSet)
       
        Dim objCollection() As AcadEntity
        ReDim objCollection(SSet.count - 1)
        For j = 0 To SSet.count - 1
            Set objCollection(j) = SSet.Item(j)
        Next j
       
        ' 删除选择集
        SSet.Delete
       
        ' 设置图纸打印顺序
        If optSortZ.Value Then
            '按坐标对图框排序(左右,上下:y坐标从大到小,x坐标从小到大)
            Call SortZ(objCollection())
        Else
            '按坐标对图框排序(上下,左右:x坐标从小到大,y坐标从大到小)
            Call SortN(objCollection())
        End If
       
        ' 若选择倒序
        If chkSort.Value Then
            For j = 0 To UBound(objCollection) / 2
                Set ent = objCollection(j)
                Set objCollection(j) = objCollection(UBound(objCollection) - j)
                Set objCollection(UBound(objCollection) - j) = ent
            Next j
        End If
       
        '对选择集中每个对象进行打印或预览
        For j = 0 To UBound(objCollection)
            '获得每个对象最小包围框的两个角点
            objCollection(j).GetBoundingBox ptMin, ptMax
            '将世界坐标(WCS)转换为显示坐标(DCS)
            Dim PtMax_UCS As Variant
            Dim PtMin_UCS As Variant
            PtMax_UCS = ThisDrawing.Utility.TranslateCoordinates(ptMax, acWorld, acDisplayDCS, False)
            PtMin_UCS = ThisDrawing.Utility.TranslateCoordinates(ptMin, acWorld, acDisplayDCS, False)

            '将三维点转化为二维点坐标
            ReDim Preserve PtMin_UCS(0 To 1)
            ReDim Preserve PtMax_UCS(0 To 1)
           
            ' 设置打印窗口(为显示坐标DCS)
            objLayout.SetWindowToPlot PtMax_UCS, PtMin_UCS

            '完全预览当前的区域
            objPlot.DisplayPlotPreview acFullPreview
             n = n + 1
             If n > 1 Then
                 '恢复原来的打印设置
                 objLayout.CopyFrom objOriginalPC
                 '显示对话框
                 frmBatchPlot.Show
                 Exit Sub
             End If
        Next j
       
    Next i
   
    '无打印区域时显示对话框
    MsgBox "选定图形中无打印区域!", vbCritical
    '恢复原来的打印设置
    objLayout.CopyFrom objOriginalPC
    '显示对话框
    frmBatchPlot.Show
   
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 ListPlotDeviceNames()
    '取得当前布局对象
    Set objLayout = ThisDrawing.ActiveLayout
    '取得当前打印机配置信息
    objPlotConfiguration.ConfigName = objLayout.ConfigName
    '刷新这个工作任务当前的打印信息
    objPlotConfiguration.RefreshPlotDeviceInfo
    '列出系统上所有有效的设备名称
    Dim plotDevices  As Variant
    plotDevices = objPlotConfiguration.GetPlotDeviceNames
    '删除以前的打印机列表
    cboPrintersName.Clear
    '显示打印机列表
    Dim i As Integer
    For i = 0 To UBound(plotDevices)
        cboPrintersName.AddItem (plotDevices(i))
        '设置默认的显示项目
        If objPlotConfiguration.ConfigName = plotDevices(i) Then cboPrintersName.ListIndex = i
    Next i
    '设置组合框初始选项
    With cboPrintersName
        '使用下拉列表的形式
        .Style = fmStyleDropDownList
        '设置默认的显示项目
        If .ListIndex = -1 Then .ListIndex = 0
    End With
   
End Sub

' 显示AutoCAD中当前可用的图纸尺寸
Public Sub ListPaperSize()
    '取得当前布局对象
    Set objLayout = ThisDrawing.ActiveLayout
    If cboPrintersName.Text = objLayout.ConfigName Then
        '取得当用图纸尺寸
        objPlotConfiguration.CanonicalMediaName = objLayout.CanonicalMediaName
    End If
    '刷新打印设备信息
    objPlotConfiguration.RefreshPlotDeviceInfo
    '列出所有介质的名称以及它们的本地版本
    paperSizes = objPlotConfiguration.GetCanonicalMediaNames
    '删除以前的图纸尺寸列表
    cboPaperSize.Clear
    '显示图纸尺寸列表
    Dim i As Integer
    For i = 0 To UBound(paperSizes)
        cboPaperSize.AddItem objPlotConfiguration.GetLocaleMediaName(paperSizes(i))
        '设置默认的显示项目
        If objPlotConfiguration.CanonicalMediaName = paperSizes(i) Then cboPaperSize.ListIndex = i
    Next i
   
    '设置组合框初始选项
    With cboPaperSize
        '使用下拉列表的形式
        .Style = fmStyleDropDownList
        '设置默认的显示项目
        If .ListIndex = -1 Then .ListIndex = 0
    End With
   
End Sub

' 显示AutoCAD中当前可用的打印样式
Public Sub ListPlotStyleTableNames()
    '取得当前布局对象
    Set objLayout = ThisDrawing.ActiveLayout
    '取得当前打印样式
    objPlotConfiguration.StyleSheet = objLayout.StyleSheet
    '刷新打印设备信息
    objPlotConfiguration.RefreshPlotDeviceInfo
    ' 获得所有的可用打印样式
    Dim plotStyleTables  As Variant
    plotStyleTables = objPlotConfiguration.GetPlotStyleTableNames
   
    ' 删除以前的打印样式列表
    cboPlotStyleTableNames.Clear
    ' 添加打印样式列表
    Dim i As Integer
    Dim str As String
    For i = 0 To UBound(plotStyleTables)
        str = plotStyleTables(i)
        Call AddSorted(cboPlotStyleTableNames, str)
    Next i
   
    '设置默认的显示项目
    For i = 0 To UBound(plotStyleTables)
        str = plotStyleTables(i)
        If cboPlotStyleTableNames.List(i) = objPlotConfiguration.StyleSheet Then
            cboPlotStyleTableNames.ListIndex = i
            Exit For
        End If
    Next i
   
    ' 设置组合框初始选项
    With cboPlotStyleTableNames
        '使用下拉列表的形式
        .Style = fmStyleDropDownList
        '设置默认的显示项目
        If .ListIndex = -1 Then .ListIndex = 0
    End With
   
End Sub

' 显示AutoCAD中可以使用的打印比例
Public Sub ListPlotScale()
    Dim i As Integer
    '定义图纸尺寸数组
    Dim P, Nu, De, Q1, Q2
    '定义图纸尺寸数组
    P = Array("自定义", "按图纸空间缩放", "1:1", "1:2", "1:4", "1:8", "1:10", "1:16", "1:20", "1:30", _
        "1:40", "1:50", "1:100", "2:1", "4:1", "8:1", "10:1", "100:1", "1/128""= 1'", "1/64""= 1'", _
        "1/32""= 1'", "1/16""= 1'", "3/32""= 1'", "1/8""= 1'", "3/16""= 1'", "1/4""= 1'", "3/8""= 1'", _
        "1/2""= 1'", "3/4""= 1'", "1""= 1'", "3""= 1'", "6""= 1'", "1'= 1'")
    '定义分子数组
    Nu = Array(" ", "", "1", "1", "1", "1", "1", "1", "1", "1", _
        "1", "1", "1", "1", "1", "1", "1", "1", "1", "1", _
        "1", "1", "1", "1", "1", "1", "1", "1", "1", "1", _
        "1", "1", "1")
    '定义分母数组
    De = Array(" ", "", "1", "2", "4", "8", "10", "16", "20", "30", _
        "40", "50", "100", "0.5", "0.25", "0.125", "0.1", "0.01", "1536", "768", _
        "384", "192", "128", "96", "64", "48", "32", "24", "16", "12", _
        "4", "2", "1")
    '定义组合框索引到打印比例枚举值的映射
    Q1 = Array(100, 0, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, _
        1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15)
    '定义打印比例枚举值到组合框索引的映射
    Q2 = Array(1, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, _
        2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 100)
   
    '取得当前布局对象
    Set objLayout = ThisDrawing.ActiveLayout
    '取得当前打印比例
    objPlotConfiguration.UseStandardScale = objLayout.UseStandardScale
    ' 显示打印比例列表
    With cboPlotScale
        ' 清空打印比例列表
        .Clear
        For i = 0 To 32
            .AddItem P(i), i
        Next
        '使用下拉列表的形式
        .Style = fmStyleDropDownList
        '设置默认的显示项目
        If Not objPlotConfiguration.UseStandardScale Then
            '使用自定义比例
            .ListIndex = 0
            objLayout.GetCustomScale Numerator, Denominator
            objPlotConfiguration.SetCustomScale Numerator, Denominator
            '设置文本框文本
            txtNumerator.Text = Numerator
            txtDenominator.Text = Denominator
        Else
            '使用标准比例
            objPlotConfiguration.StandardScale = objLayout.StandardScale
            .ListIndex = Q2(objPlotConfiguration.StandardScale)
            If .ListIndex > 1 Then
                Numerator = Nu(cboPlotScale.ListIndex)
                Denominator = De(cboPlotScale.ListIndex)
                '设置文本框文本
                txtNumerator.Text = Numerator
                txtDenominator.Text = Denominator
            Else
                '计算缩放比例
                Call SetScaleToFit
            End If
        End If
     End With
 
End Sub

Public Sub SetScaleToFit()
    Dim PaperWidth As Double, PaperHeight As Double, t As Double
    Dim PlotWidth As Double, PlotHeight As Double
    Dim WindowWidth As Double, WindowHeight As Double
    Dim MarginLowerLeft As Variant, MarginUpperRight As Variant
    Dim WindowLowerLeft As Variant, WindowUpperRight As Variant
    '刷新打印设备信息
    objPlotConfiguration.RefreshPlotDeviceInfo
    '取得图纸尺寸信息
    objPlotConfiguration.GetPaperSize PaperWidth, PaperHeight
    '取得图纸边界信息
    objPlotConfiguration.GetPaperMargins MarginLowerLeft, MarginUpperRight
    '计算打印区域
    PlotWidth = PaperWidth - (MarginUpperRight(0) + MarginLowerLeft(0))
    PlotHeight = PaperHeight - (MarginUpperRight(1) + MarginLowerLeft(1))
    '根据选择的图形方向调换宽高
    If optVertical.Value Then
        '图形方向为“纵向”时宽小于高
        If PlotWidth > PlotHeight Then
            t = PlotWidth
            PlotWidth = PlotHeight
            PlotHeight = t
        End If
    Else
        '图形方向为“横向”时宽大于高
        If PlotWidth < PlotHeight Then
            t = PlotWidth
            PlotWidth = PlotHeight
            PlotHeight = t
        End If
    End If
    '获得打印窗口
    objPlotConfiguration.GetWindowToPlot WindowLowerLeft, WindowUpperRight
    WindowWidth = WindowUpperRight(0) - WindowLowerLeft(0)
    WindowHeight = WindowUpperRight(1) - WindowLowerLeft(1)
    '计算所需比例
    Dim ScaleX As Double, ScaleY As Double
    ScaleX = WindowWidth / PlotWidth
    ScaleY = WindowHeight / PlotHeight
    Numerator = 1
    Denominator = IIf(ScaleX > ScaleY, ScaleX, ScaleY)
    Dim d As Double
    '单位由“毫米”转换为“英寸”
    d = IIf(optMillimeters.Value, Denominator, Denominator * 25.4)
    '设置文本框文本
    txtNumerator.Text = Numerator
    txtDenominator.Text = Format(d, "#########0.###")
   
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
            objPlotConfiguration.PlotRotation = ac0degrees
        Else
            objPlotConfiguration.PlotRotation = ac180degrees
        End If
    Else
        If chkReverse.Value = False Then
            objPlotConfiguration.PlotRotation = ac90degrees
        Else
            objPlotConfiguration.PlotRotation = ac270degrees
        End If
    End If
    ' 显示图纸大小
    Call SetPlotZone
End Sub

' 设置图纸可打印区域大小
Public Sub SetPlotZone()
    Dim PaperWidth As Double, PaperHeight As Double, t As Double
    Dim PlotWidth As Double, PlotHeight As Double
    Dim MarginLowerLeft As Variant, MarginUpperRight As Variant
    '刷新打印设备信息
    objPlotConfiguration.RefreshPlotDeviceInfo
  
    '取得图纸尺寸信息
    objPlotConfiguration.GetPaperSize PaperWidth, PaperHeight
    '取得图纸边界信息
    objPlotConfiguration.GetPaperMargins MarginLowerLeft, MarginUpperRight
    '计算打印区域
    PlotWidth = PaperWidth - (MarginUpperRight(0) + MarginLowerLeft(0))
    PlotHeight = PaperHeight - (MarginUpperRight(1) + MarginLowerLeft(1))
    '根据选择的图形方向调换宽高
    If optVertical.Value Then
        '图形方向为“纵向”时宽小于高
        If PlotWidth > PlotHeight Then
            t = PlotWidth
            PlotWidth = PlotHeight
            PlotHeight = t
        End If
    Else
        '图形方向为“横向”时宽大于高
        If PlotWidth < PlotHeight Then
            t = PlotWidth
            PlotWidth = PlotHeight
            PlotHeight = t
        End If
    End If
   
    '单位由“毫米”转换为“英寸”
    If optMillimeters.Value = False Then
        PlotWidth = PlotWidth / 25.4
        PlotHeight = PlotHeight / 25.4
    End If
    ' 显示图纸大小
    lbPaperSize.Caption = Format(PlotWidth, "#########0.00") & " × " & Format(PlotHeight, "#########0.00")
   
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

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

'使用选择集获得对象集合(按图层)
Public Sub SelectByLayer(strLayerName As String, ByRef SSet As AcadSelectionSet)
    On Error Resume Next
    Dim strSSetName As String
    strSSetName = "打印区域选择集"
    ' 安全创建选择集
    If Not IsNull(ThisDrawing.SelectionSets.Item(strSSetName)) Then
        Set SSet = ThisDrawing.SelectionSets.Item(strSSetName)
        SSet.Delete
    End If
    Set SSet = ThisDrawing.SelectionSets.Add(strSSetName)
    ' 选择集过滤器
    Dim fType As Variant, fData As Variant
    ' 用CreateSSetFilter函数改进的过滤器
    Call CreateSSetFilter(fType, fData, 0, "LWPOLYLINE", 8, strLayerName)
    '选择指定图层的多段线
    SSet.Select acSelectionSetAll, , , fType, fData
   
End Sub

'使用选择集获得对象集合(按块参照)
Public Sub SelectByBlock(strBlockName As String, ByRef SSet As AcadSelectionSet)
    On Error Resume Next
    Dim strSSetName As String
    strSSetName = "打印区域选择集"
    ' 安全创建选择集
    If Not IsNull(ThisDrawing.SelectionSets.Item(strSSetName)) Then
        Set SSet = ThisDrawing.SelectionSets.Item(strSSetName)
        SSet.Delete
    End If
    Set SSet = ThisDrawing.SelectionSets.Add(strSSetName)
    ' 选择集过滤器
    Dim fType As Variant, fData As Variant
    ' 用CreateSSetFilter函数改进的过滤器
    Call CreateSSetFilter(fType, fData, 0, "INSERT", 2, strBlockName)
    '选择指定图层的多段线
    SSet.Select acSelectionSetAll, , , fType, fData
   
End Sub

' 创建选择集过滤器
Public Sub CreateSSetFilter(ByRef filterType As Variant, ByRef filterData As Variant, ParamArray filter())
    If UBound(filter) Mod 2 = 0 Then
        MsgBox "filter参数无效!"
        Exit Sub
    End If
   
    ' 过滤器规则
    Dim fType() As Integer
    ' 过滤器参数
    Dim fData() As Variant
    Dim count As Integer
    count = (UBound(filter) + 1) / 2
    ReDim fType(count - 1)
    ReDim fData(count - 1)
   
    Dim i As Integer
    For i = 0 To count - 1
        fType(i) = filter(2 * i)
        fData(i) = filter(2 * i + 1)
    Next i
   
    filterType = fType
    filterData = fData
End Sub

'按坐标对图框排序(上下,左右:x坐标从小到大,y坐标从大到小)
Public Function SortN(ByRef objCollection() As AcadEntity)

'选择集为空时退出函数
If UBound(objCollection) = 0 Then
    Exit Function
End If

Dim ent As AcadEntity
Dim i As Integer, j As Integer
Dim ptiMin As Variant, ptiMax As Variant
Dim ptjMin As Variant, ptjMax As Variant

'容许误差
Dim NumError As Double
NumError = 0

'按x坐标排序
For i = 0 To UBound(objCollection)
    For j = i + 1 To UBound(objCollection)
        '获得每个对象最小包围框的两个角点
        objCollection(i).GetBoundingBox ptiMin, ptiMax
        objCollection(j).GetBoundingBox ptjMin, ptjMax
        '将三维点转化为二维点坐标
        ReDim Preserve ptiMin(0 To 1)
        ReDim Preserve ptjMin(0 To 1)
       
        If ptiMin(0) - ptjMin(0) > NumError Then
            Set ent = objCollection(i)
            Set objCollection(i) = objCollection(j)
            Set objCollection(j) = ent
        End If
    Next j
Next i

'对x坐标相等的进行y坐标排序
For i = 0 To UBound(objCollection)
    For j = 0 To UBound(objCollection)
        '获得每个对象最小包围框的两个角点
        objCollection(i).GetBoundingBox ptiMin, ptiMax
        objCollection(j).GetBoundingBox ptjMin, ptjMax
        '将三维点转化为二维点坐标
        ReDim Preserve ptiMin(0 To 1)
        ReDim Preserve ptjMin(0 To 1)

        If ptiMin(0) = ptjMin(0) Then
            If ptiMin(1) - ptjMin(1) > NumError Then
                Set ent = objCollection(i)
                Set objCollection(i) = objCollection(j)
                Set objCollection(j) = ent
            End If
        End If
    Next j
Next i

End Function

'按坐标对图框排序(左右,上下:y坐标从大到小,x坐标从小到大)
Public Function SortZ(ByRef objCollection() As AcadEntity)

'选择集为空时退出函数
If UBound(objCollection) = 0 Then
    Exit Function
End If

Dim ent As AcadEntity
Dim i As Integer, j As Integer
Dim ptiMin As Variant, ptiMax As Variant
Dim ptjMin As Variant, ptjMax As Variant

'容许误差
Dim NumError As Double
NumError = 0

'按y坐标排序
For i = 0 To UBound(objCollection)
    For j = i + 1 To UBound(objCollection)
        '获得每个对象最小包围框的两个角点
        objCollection(i).GetBoundingBox ptiMin, ptiMax
        objCollection(j).GetBoundingBox ptjMin, ptjMax
        '将三维点转化为二维点坐标
        ReDim Preserve ptiMin(0 To 1)
        ReDim Preserve ptjMin(0 To 1)
       
        If ptiMin(1) - ptjMin(1) < NumError Then
            Set ent = objCollection(i)
            Set objCollection(i) = objCollection(j)
            Set objCollection(j) = ent
        End If
    Next j
Next i

'对y坐标相等的进行x坐标排序
For i = 0 To UBound(objCollection)
    For j = 0 To UBound(objCollection)
        '获得每个对象最小包围框的两个角点
        objCollection(i).GetBoundingBox ptiMin, ptiMax
        objCollection(j).GetBoundingBox ptjMin, ptjMax
        '将三维点转化为二维点坐标
        ReDim Preserve ptiMin(0 To 1)
        ReDim Preserve ptjMin(0 To 1)

        If ptiMin(1) = ptjMin(1) Then
            If ptiMin(0) - ptjMin(0) < NumError Then
                Set ent = objCollection(i)
                Set objCollection(i) = objCollection(j)
                Set objCollection(j) = ent
            End If
        End If
    Next j
Next i

End Function

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 05:12 , Processed in 0.256248 second(s), 17 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表