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

xyghzzj 发表于 2006-11-28 22:07:00

本帖最后由作者于 2009-7-22 0:32:30 编辑   源码共享，回报明经！ 注：58楼已更新。2009.7.23

xyghzzj 发表于 2006-11-28 22:16:00

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

牵牛发表于 2019-12-24 16:06:19

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

xyghzzj 发表于 2006-11-28 22:11:00

本帖最后由作者于 2006-11-28 22:45:07 编辑 整整花了一周时间，总算能用了。虽然不是很完美，以后就考大家完善了。 
使用方法：解压到*:\Program Files\AutoCAD 2004\Support下，在工具－>自定义－>菜单中加载CADBatchPlot.mns即可。

xyghzzj 发表于 2006-11-28 22:19:00

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

fanny_6 发表于 2006-11-29 00:12:00

粗粗看了以下，程序写的相当精彩，相当高手。 我调试了以下，没有问题。 题几个建议： 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 发表于 2006-11-29 09:13:00

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

tractor 发表于 2006-11-29 14:51:00

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

lijiao 发表于 2006-11-30 08:50:00

程序好长，功夫不错。
我也有一个类似的程序，是用VL写的，设置了几个命令，设置打印区、删除打印区、单文件打印和批量打印。
大致思路是设置打印区时，将文件名和打印区域的坐标自动写入一个文本文件（打印配置文件），打印时，从配置文件中找出打印数据即可。

wylong 发表于 2006-12-1 14:37:00

不错不错

xiangzhong 发表于 2006-12-3 14:26:00

相当赞啊

页: [1] 2 3 4 5 6 7 8 9 10

明经CAD社区's Archiver

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