cailv
发表于 2008-4-16 11:06:00
非常感谢！！
dfgs
发表于 2008-6-5 13:21:00
下来看看
nhy12345678
发表于 2008-6-5 21:52:00
请问CAD2006如何加载CADBatchPlot.mns 呢，另外CAD2006版本不能使用这个程序吗？<br/>
war3dd
发表于 2009-2-20 23:53:00
<p>我也下了，过段时间就学习 </p>
wubohan84
发表于 2009-2-23 16:01:00
可能大家的应用情况不同。我自己也写了个自动打印程序。我用的办法是识别图纸外框多段线的长度来自动识别图纸的位置。因为a3，a4图纸的周长是固定，所以不用去选择坐标。运行程序，全部自动打印。。。还有很多不完善的地方，不过自己公司的够用了
glhht
发表于 2009-3-10 10:35:00
顶你一下吧，很好的东西
xyghzzj
发表于 2009-7-22 00:11:00
<p>2009.7.21更新：</p><p>可以设置打印顺序为先行后列即Z型，或者先列后行的N型打印</p>
xyghzzj
发表于 2009-7-22 00:15:00
源代码见附件。
StartMe
发表于 2009-7-22 00:25:00
下来参考一下。辛苦。
xyghzzj
发表于 2009-7-22 00:26:00
<p>Option Explicit<br/>'图形集合<br/>Private colDwgs As New Collection<br/>'文档对象<br/>Private objDoc As AcadDocument<br/>'布局对象<br/>Private objLayout As AcadLayout<br/>'打印配置集合<br/>Private objPlotConfigurations As AcadPlotConfigurations<br/>'打印配置<br/>Private objPlotConfiguration As AcadPlotConfiguration<br/>Private objOriginalPC As AcadPlotConfiguration<br/>'打印对象<br/>Private objPlot As AcadPlot<br/>'图纸尺寸名称数组<br/>Private paperSizes As Variant<br/>Private Numerator As Double, Denominator As Double<br/>Private OffsetX As Double, OffsetY As Double<br/>Private ms As Boolean</p><p>Private Type BrowseInfo<br/> hOwner As Long<br/> pidlRoot As Long<br/> pszDisplayName As String<br/> lpszTitle As String<br/> ulFlags As Long<br/> lpfn As Long<br/> lParam As Long<br/> iImage As Long<br/>End Type<br/>Private Const MAX_PATH = 260<br/>'代表ESC键<br/>Private Const VK_ESCAPE = &H1B</p><p>'API函数的声明<br/>Private Declare Function SHBrowseForFolder Lib "shell32.dll" _<br/> Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long<br/>Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _<br/> ByVal lpWindowName As String) As Long<br/>Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal _<br/> pidl As Long, ByVal pszPath As String) As Long<br/>Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer</p><p>' 功能：判断用户是否按下某一个键<br/>' 输入：代表键的常量（从API Viewer中获得）<br/>' 调用：API函数GetAsyncKeyState<br/>' 返回：如果用户按下了指定的键，返回True；否则返回False<br/>' 示例：<br/>' If CheckKey(&H1B) = True Then do sth<br/>Private Function CheckKey(lngKey As Long) As Boolean<br/> If GetAsyncKeyState(lngKey) Then<br/> CheckKey = True<br/> Else<br/> CheckKey = False<br/> End If<br/>End Function</p><p>Private Sub cboPaperSize_Change()<br/> '若组合框非空<br/> If cboPaperSize.Text <> "" Then<br/> ' 设置图纸尺寸<br/> objPlotConfiguration.CanonicalMediaName = paperSizes(cboPaperSize.ListIndex)<br/> ' 显示图纸尺寸<br/> Call SetPlotZone<br/> ' 当居中打印时重新计算打印偏移<br/> If chkCenterPlot.Value Then Call SetOffset<br/> End If<br/>End Sub</p><p>Private Sub cboPlotScale_Click()<br/> '定义图纸尺寸数组<br/> Dim Nu, De<br/> '定义分子数组<br/> Nu = Array(" ", "", "1", "1", "1", "1", "1", "1", "1", "1", _<br/> "1", "1", "1", "1", "1", "1", "1", "1", "1", "1", _<br/> "1", "1", "1", "1", "1", "1", "1", "1", "1", "1", _<br/> "1", "1", "1")<br/> '定义分母数组<br/> De = Array(" ", "", "1", "2", "4", "8", "10", "16", "20", "30", _<br/> "40", "50", "100", "0.5", "0.25", "0.125", "0.1", "0.01", "1536", "768", _<br/> "384", "192", "128", "96", "64", "48", "32", "24", "16", "12", _<br/> "4", "2", "1")<br/> <br/> '设置默认的显示项目<br/> If cboPlotScale.ListIndex = 0 Then<br/> '使用自定义比例<br/> Numerator = 1<br/> Denominator = 1<br/> txtNumerator.Text = Numerator<br/> txtDenominator.Text = Denominator<br/> Else<br/> If cboPlotScale.ListIndex > 1 Then<br/> Numerator = Nu(cboPlotScale.ListIndex)<br/> Denominator = De(cboPlotScale.ListIndex)<br/> txtNumerator.Text = Numerator<br/> txtDenominator.Text = Denominator<br/> Else<br/> '计算缩放比例<br/> Call SetScaleToFit<br/> End If<br/> End If<br/> Dim Q1<br/> '定义组合框索引到打印比例枚举值的映射<br/> Q1 = Array(100, 0, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, _<br/> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15)<br/> ' 设置图纸打印比例<br/> If cboPlotScale.ListIndex <> 0 Then<br/> '使用标准打印比例<br/> objPlotConfiguration.UseStandardScale = True<br/> '设置标准打印比例<br/> objPlotConfiguration.StandardScale = Q1(cboPlotScale.ListIndex)<br/> Else<br/> '使用自定义打印比例<br/> objPlotConfiguration.UseStandardScale = False<br/> '设置自定义打印比例<br/> objPlotConfiguration.SetCustomScale Numerator, Denominator<br/> End If<br/> <br/> ' 当居中打印时重新计算打印偏移<br/> If chkCenterPlot.Value Then Call SetOffset</p><p>End Sub</p><p>Private Sub cboPlotStyleTableNames_Change()<br/> ' 设置打印样式表<br/> objPlotConfiguration.StyleSheet = cboPlotStyleTableNames.Text<br/>End Sub</p><p>Private Sub cboPrintersName_Click()<br/> '设置打印机配置<br/> objPlotConfiguration.ConfigName = cboPrintersName.Text<br/> '更新显示AutoCAD中当前可用的所有图纸尺寸<br/> Call ListPaperSize<br/>End Sub</p><p>Private Sub chkCenterPlot_Click()<br/> On Error Resume Next<br/> If chkCenterPlot.Value Then<br/> ' 设置图纸是否居中打印<br/> objPlotConfiguration.CenterPlot = True<br/> '计算打印偏移<br/> Call SetOffset<br/> Else<br/> ' 设置图纸是否居中打印<br/> objPlotConfiguration.CenterPlot = False<br/> OffsetX = 0<br/> OffsetY = 0<br/> '设置文本框文本<br/> txtOffsetX.Text = "0.00"<br/> txtOffsetY.Text = "0.00"<br/> End If<br/> <br/>End Sub</p><p>Public Sub SetOffset()<br/> 'On Error Resume Next<br/> Dim PaperWidth As Double, PaperHeight As Double, t As Double<br/> Dim PlotWidth As Double, PlotHeight As Double<br/> Dim WindowWidth As Double, WindowHeight As Double<br/> Dim MarginLowerLeft As Variant, MarginUpperRight As Variant<br/> Dim WindowLowerLeft As Variant, WindowUpperRight As Variant<br/> '刷新打印设备信息<br/> objPlotConfiguration.RefreshPlotDeviceInfo<br/> '取得图纸尺寸信息<br/> objPlotConfiguration.GetPaperSize PaperWidth, PaperHeight<br/> '取得图纸边界信息<br/> objPlotConfiguration.GetPaperMargins MarginLowerLeft, MarginUpperRight<br/> '计算打印区域<br/> PlotWidth = PaperWidth - (MarginUpperRight(0) + MarginLowerLeft(0))<br/> PlotHeight = PaperHeight - (MarginUpperRight(1) + MarginLowerLeft(1))<br/> '根据选择的图形方向调换宽高<br/> If optVertical.Value Then<br/> '图形方向为“纵向”时宽小于高<br/> If PlotWidth > PlotHeight Then<br/> t = PlotWidth<br/> PlotWidth = PlotHeight<br/> PlotHeight = t<br/> End If<br/> Else<br/> '图形方向为“横向”时宽大于高<br/> If PlotWidth < PlotHeight Then<br/> t = PlotWidth<br/> PlotWidth = PlotHeight<br/> PlotHeight = t<br/> End If<br/> End If</p><p> '单位由“英寸”转换为“毫米”的比例因子<br/> Dim scaleUnit As Double<br/> scaleUnit = IIf(optMillimeters.Value, 1, 25.4)<br/> '获得打印窗口尺寸<br/> objPlotConfiguration.GetWindowToPlot WindowLowerLeft, WindowUpperRight<br/> WindowWidth = WindowUpperRight(0) - WindowLowerLeft(0)<br/> WindowHeight = WindowUpperRight(1) - WindowLowerLeft(1)<br/> '获得缩放后的打印窗口尺寸<br/> WindowWidth = WindowWidth * Numerator / Denominator * scaleUnit<br/> WindowHeight = WindowHeight * Numerator / Denominator * scaleUnit<br/> '计算打印偏移<br/> OffsetX = (PlotWidth - WindowWidth) / 2<br/> OffsetY = (PlotHeight - WindowHeight) / 2<br/> Dim X As Double, Y As Double<br/> '单位由“毫米”转换为“英寸”<br/> X = IIf(optMillimeters.Value, OffsetX, OffsetX / 25.4)<br/> Y = IIf(optMillimeters.Value, OffsetY, OffsetY / 25.4)<br/> '设置文本框文本<br/> txtOffsetX.Text = Format(X, "#########0.00")<br/> txtOffsetY.Text = Format(Y, "#########0.00")<br/> <br/>End Sub</p><p>Private Sub chkOnlyPlotThis_Change()<br/> '设置“打印到文件”组各控件激活状态<br/> If chkOnlyPlotThis.Value Then<br/> '清除列表框中所有元素<br/> lstPlotFiles.Clear<br/> '获得当前图形名<br/> Dim strTemp As String<br/> strTemp = ThisDrawing.Application.ActiveDocument.Path & "\" & ThisDrawing.Application.ActiveDocument.name<br/> '向列表框添加当前图形<br/> lstPlotFiles.AddItem strTemp<br/> cmdBrowse.Enabled = False<br/> cmdAdd.Enabled = False<br/> cmdAddAll.Enabled = False<br/> cmdClear.Enabled = False<br/> cmdClearAll.Enabled = False<br/> lstCurFiles.Enabled = False<br/> lstPlotFiles.Enabled = False<br/> Else<br/> cmdBrowse.Enabled = True<br/> cmdAdd.Enabled = True<br/> cmdAddAll.Enabled = True<br/> cmdClear.Enabled = True<br/> cmdClearAll.Enabled = True<br/> lstCurFiles.Enabled = True<br/> lstPlotFiles.Enabled = True<br/> End If</p><p>End Sub</p><p>Private Sub chkPlotHidden_Change()<br/> '设置是否隐藏图纸空间对象<br/> If Not objPlotConfiguration.ModelType Then _<br/> objPlotConfiguration.PlotHidden = chkPlotHidden.Value<br/>End Sub</p><p>Private Sub chkPlotToFile_Change()<br/> '设置“打印到文件”组各控件激活状态<br/> If chkPlotToFile.Value Then<br/> lbPlotPath.Enabled = True<br/> cboPlotPath.Enabled = True<br/> cmdBrowse2.Enabled = True<br/> Else<br/> lbPlotPath.Enabled = False<br/> cboPlotPath.Enabled = False<br/> cmdBrowse2.Enabled = False<br/> End If<br/>End Sub</p><p>Private Sub chkPlotWithLineweights_Change()<br/> '设置是否打印对象线宽<br/> If Not chkPlotWithPlotStyles.Value Then _<br/> objPlotConfiguration.PlotWithLineweights = chkPlotWithLineweights.Value<br/>End Sub</p><p>Private Sub chkPlotWithPlotStyles_Change()<br/> '设置是否应用打印样式<br/> objPlotConfiguration.PlotWithPlotStyles = chkPlotWithPlotStyles.Value<br/> chkPlotWithLineweights.Enabled = Not (chkPlotWithPlotStyles.Value)<br/>End Sub</p><p>Private Sub chkReverse_Click()<br/> '设置图纸打印方向<br/> Call PaperRotationChange<br/>End Sub</p><p>Private Sub cmdAdd_Click()<br/> '如果列表框中未存在任何元素<br/> If lstCurFiles.ListCount = 0 Then<br/> MsgBox "请先向列表框中添加文件！", vbCritical<br/> Exit Sub<br/> End If</p><p> Dim strFlies As String<br/> Dim i As Integer<br/> Dim n As Integer<br/> n = 0<br/> '将上面列表框中选中的对象添加到下面的列表框中<br/> For i = 0 To lstCurFiles.ListCount - 1<br/> If lstCurFiles.Selected(i) Then<br/> strFlies = lstCurFiles.List(i)<br/> n = n + 1<br/> If Not HasItem(lstPlotFiles, strFlies) Then<br/> lstPlotFiles.AddItem lstCurFiles.List(i)<br/> End If<br/> End If<br/> Next i<br/> '如果列表框中未存在被选择的元素<br/> If n = 0 Then<br/> MsgBox "请选择要从列表中添加的元素！", vbCritical<br/> Exit Sub<br/> End If<br/>End Sub</p><p>Private Sub cmdAddAll_Click()<br/> '如果列表框中未存在任何元素<br/> If lstCurFiles.ListCount = 0 Then<br/> MsgBox "请先向列表框中添加文件！", vbCritical<br/> Exit Sub<br/> End If<br/> <br/> Dim strFlies As String<br/> Dim i As Integer<br/> '将上面列表框中选中的对象添加到下面的列表框中<br/> For i = 0 To lstCurFiles.ListCount - 1<br/> strFlies = lstCurFiles.List(i)<br/> If Not HasItem(lstPlotFiles, strFlies) Then<br/> lstPlotFiles.AddItem lstCurFiles.List(i)<br/> End If<br/> Next i<br/>End Sub</p><p>Private Sub cmdBrowse_Click()<br/> '在文本框中显示获得的路径<br/> txtCurPath.Text = ReturnFolder(0)<br/>End Sub</p><p>Private Sub cmdBrowse2_Click()<br/> Dim strPath As String<br/> strPath = ReturnFolder(0)<br/> '若返回文件夹路径非空<br/> If strPath <> "" Then<br/> '若组合框中未存在返回文件夹路径，则将其添加到组合框中<br/> If HasItem2(strPath) < 0 Then<br/> '在组合框中显示获得的路径<br/> With cboPlotPath<br/> .AddItem strPath, 0<br/> '使用下拉列表的形式<br/> .Style = fmStyleDropDownList<br/> '设置下拉列表的下标下限<br/> .BoundColumn = 0<br/> '设置默认的显示项目<br/> .ListIndex = 0<br/> End With<br/> '若组合框中已存在返回文件夹路径，则将返回文件夹路径置为选中<br/> Else<br/> With cboPlotPath<br/> '设置默认的显示项目<br/> .ListIndex = HasItem2(strPath)<br/> End With<br/> End If<br/> End If<br/>End Sub</p><p>Private Sub cmdClear_Click()<br/> '如果列表框中未存在任何元素<br/> If lstPlotFiles.ListCount = 0 Then<br/> MsgBox "请先向列表框中添加文件！", vbCritical<br/> Exit Sub<br/> End If<br/> <br/> Dim i As Integer, n As Integer, count As Integer<br/> '列表框中元素的数量<br/> count = lstPlotFiles.ListCount<br/> n = 0<br/> '将列表框中选中的对象删除<br/> For i = 0 To count - 1<br/> If lstPlotFiles.Selected(i) Then<br/> n = n + 1<br/> Else<br/> '移动列表框中的元素<br/> lstPlotFiles.List(i - n) = lstPlotFiles.List(i)<br/> End If<br/> Next i<br/> <br/> '如果列表框中未存在被选择的元素<br/> If n = 0 Then<br/> MsgBox "请选择要从列表中清除的元素！", vbCritical<br/> Exit Sub<br/> End If<br/> <br/> '删除最后n行的元素<br/> For i = 1 To n<br/> lstPlotFiles.RemoveItem (count - i)<br/> Next i</p><p>End Sub</p><p>Private Sub cmdClearAll_Click()<br/> '如果列表框中未存在任何元素<br/> If lstPlotFiles.ListCount = 0 Then<br/> MsgBox "请先向列表框中添加文件！", vbCritical<br/> Exit Sub<br/> End If<br/> <br/> Dim Msg, Style, Title, Help, Ctxt, Response, MyString<br/> Msg = "清除整个图形列表?"<br/> Style = vbOKCancel + vbQuestion + vbDefaultButton2<br/> Title = "Clear Files"<br/> <br/> Response = MsgBox(Msg, Style, Title)<br/> If Response = vbOK Then<br/> txtCurPath.Text = ""<br/> '清除列表框中所有元素<br/> lstPlotFiles.Clear<br/> End If<br/> <br/>End Sub</p><p>Private Sub cmdExit_Click()<br/> '退出<br/> End<br/>End Sub</p><p>Private Sub cmdInput_Click()<br/> '导入打印设置<br/> '设置标准对话框<br/> With comDlg<br/> '设置标准对话框标题<br/> .DialogTitle = "导入打印设置"<br/> '设置标准对话框类型列表中所显示的过滤器<br/> .filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"<br/> '显示[打开]对话框<br/> .ShowOpen<br/> End With<br/> <br/> Dim strFileName As String<br/> strFileName = comDlg.fileName<br/> '若返回文件名为空，不进行操作<br/> If strFileName = "" Then<br/> MsgBox "请重新选择文件位置！"<br/> Exit Sub<br/> End If<br/> <br/> '读入文件的操作<br/> Dim i As Integer, nFile As Integer<br/> Dim X As Double, Y As Double<br/> Dim count As Integer, index As Integer<br/> Dim strTemp As String<br/> '获得下一个可供Open语句使用的文件号<br/> nFile = FreeFile<br/> '打开文件<br/> Open strFileName For Input As #nFile<br/> <br/> '读入当前路径<br/> '读入一行文本并存储在变量中<br/> Line Input #nFile, strTemp<br/> '读入当前路径并设置文本框文字<br/> Input #nFile, strTemp<br/> txtCurPath.Text = strTemp<br/> <br/> '读入打印文件列表并添加到列表框中<br/> Call InputData3(lstPlotFiles, nFile)<br/> <br/> '读入是否仅打印当前图形并设置复选按钮选择状态<br/> Call InputData2(chkOnlyPlotThis, nFile)<br/> <br/> '读入打印机配置列表并添加到组合框中<br/> Call InputData(cboPrintersName, nFile)<br/> <br/> '读入打印样式表并添加到组合框中<br/> Call InputData(cboPlotStyleTableNames, nFile)<br/> <br/> '读入图纸尺寸列表并添加到组合框中<br/> Call InputData(cboPaperSize, nFile)<br/> <br/> '读入图纸单位并设置单选按钮选择状态<br/> '读入一行文本并存储在变量中<br/> Line Input #nFile, strTemp<br/> '读入图纸单位<br/> Input #nFile, strTemp<br/> '设置单选按钮选择状态<br/> If strTemp = "毫米" Then<br/> optMillimeters.Value = True<br/> Else<br/> optInches.Value = True<br/> End If<br/> <br/> '读入图纸方向并设置单选按钮选择状态<br/> '读入一行文本并存储在变量中<br/> Line Input #nFile, strTemp<br/> '读入图纸方向<br/> Input #nFile, strTemp<br/> '设置单选按钮选择状态<br/> If strTemp = "纵向" Then<br/> optVertical.Value = True<br/> Else<br/> optHorizontal.Value = True<br/> End If<br/> <br/> '读入是否反向打印并设置复选按钮选择状态<br/> Call InputData2(chkReverse, nFile)<br/> <br/> '读入打印份数<br/> '读入一行文本并存储在变量中<br/> Line Input #nFile, strTemp<br/> '读入打印份数<br/> Input #nFile, count<br/> '设置文本框文字<br/> txtNumber.Text = count<br/> <br/> '读入是否打印到文件并设置复选按钮选择状态<br/> Call InputData2(chkPlotToFile, nFile)<br/> <br/> '读入打印路径列表并添加到组合框中<br/> Call InputData(cboPlotPath, nFile)<br/> <br/> '读入打印比例列表并添加到组合框中<br/> Call InputData(cboPlotScale, nFile)<br/> <br/> '读入一行文本并存储在变量中<br/> Line Input #nFile, strTemp<br/> '读入当前打印比例并设置文本框文字<br/> Input #nFile, X<br/> Input #nFile, Y<br/> txtNumerator.Text = X<br/> txtDenominator.Text = Y<br/> <br/> '读入是否居中打印并设置复选按钮选择状态<br/> Call InputData2(chkCenterPlot, nFile)<br/> <br/> '读入打印偏移<br/> '读入一行文本并存储在变量中<br/> Line Input #nFile, strTemp<br/> '读入打印偏移并设置文本框文字<br/> Input #nFile, X<br/> Input #nFile, Y<br/> txtOffsetX.Text = X<br/> txtOffsetY.Text = Y<br/> <br/> '读入是否打印对象线宽并设置复选按钮选择状态<br/> Call InputData2(chkPlotWithLineweights, nFile)<br/> '读入是否采用打印样式并设置复选按钮选择状态<br/> Call InputData2(chkPlotWithPlotStyles, nFile)<br/> '读入是否隐藏图纸空间对象并设置复选按钮选择状态<br/> Call InputData2(chkPlotHidden, nFile)<br/> <br/> '读入图框形式并设置单选按钮选择状态<br/> '读入一行文本并存储在变量中<br/> Line Input #nFile, strTemp<br/> '读入图框形式<br/> Input #nFile, strTemp<br/> '设置单选按钮选择状态<br/> If strTemp = "图块" Then<br/> optBlock.Value = True<br/> Else<br/> optLayer.Value = True<br/> End If<br/> <br/> '读入图块名列表并添加到组合框中<br/> Call InputData(cboBlockName, nFile)<br/> <br/> '读入图层名列表并添加到组合框中<br/> Call InputData(cboLayerName, nFile)<br/> <br/> '关闭文件<br/> Close #nFile</p><p>End Sub</p><p>Private Sub cmdListPrints_Click()<br/> ' 显示AutoCAD中当前可用的打印机列表<br/> Call ListPlotDeviceNames<br/>End Sub</p><p>Private Sub cmdOutput_Click()<br/> '导出打印设置<br/> '设置标准对话框<br/> With comDlg<br/> '设置标准对话框标题<br/> .DialogTitle = "导出打印设置"<br/> '设置标准对话框类型列表中所显示的过滤器<br/> .filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"<br/> '设置[另存为]对话框的缺省扩展名<br/> .DefaultExt = "txt"<br/> '显示[另存为]对话框<br/> .ShowSave<br/> End With<br/> <br/> Dim strFileName As String, strTemp As String<br/> strFileName = comDlg.fileName<br/> '若返回文件名为空，不进行操作<br/> If strFileName = "" Then<br/> MsgBox "请重新选择保存位置！"<br/> Exit Sub<br/> End If<br/> <br/> '保存文件的操作<br/> Dim i As Integer<br/> '打开文件<br/> Open strFileName For Output As #1<br/> <br/> '输出当前路径<br/> Print #1, "当前路径："<br/> Print #1, txtCurPath.Text<br/> <br/> '输出打印文件列表<br/> Print #1, "打印文件列表："<br/> '输出打印机配置列表的信息<br/> Call OutputData3(lstPlotFiles, 1)<br/> <br/> '输出是否仅打印当前图形<br/> Print #1, "是否仅打印当前图形"<br/> Call OutputData2(chkOnlyPlotThis, 1)<br/> <br/> '输出打印机配置<br/> Print #1, "打印机配置："<br/> '输出打印机配置列表的信息<br/> Call OutputData(cboPrintersName, 1)<br/> <br/> '输出打印样式表<br/> Print #1, "打印样式表："<br/> '输出打印样式表的信息<br/> Call OutputData(cboPlotStyleTableNames, 1)<br/> <br/> '输出图纸尺寸列表<br/> Print #1, "图纸尺寸列表："<br/> '输出图纸尺寸列表的信息<br/> Call OutputData(cboPaperSize, 1)<br/> <br/> '输出图纸单位<br/> Print #1, "图纸单位："<br/> '输出图纸单位信息<br/> If optMillimeters.Value = True Then<br/> strTemp = "毫米"<br/> Else<br/> strTemp = "英寸"<br/> End If<br/> Print #1, strTemp<br/> <br/> '输出图纸方向<br/> Print #1, "图纸方向："<br/> '输出图纸方向信息<br/> If optVertical.Value = True Then<br/> strTemp = "纵向"<br/> Else<br/> strTemp = "横向"<br/> End If<br/> Print #1, strTemp<br/> <br/> '输出是否反向打印<br/> Print #1, "是否反向打印："<br/> Call OutputData2(chkReverse, 1)<br/> <br/> '输出打印份数<br/> Print #1, "打印份数："<br/> Print #1, txtNumber.Text<br/> <br/> '输出是否打印到文件<br/> Print #1, "是否打印到文件："<br/> Call OutputData2(chkPlotToFile, 1)<br/> <br/> '输出打印路径<br/> Print #1, "打印路径："<br/> '输出打印路径列表的信息<br/> Call OutputData(cboPlotPath, 1)<br/> <br/> '输出打印比例<br/> Print #1, "打印比例："<br/> '输出打印比例列表的信息<br/> Call OutputData(cboPlotScale, 1)<br/> <br/> '输出当前打印比例<br/> Print #1, "当前打印比例："<br/> Print #1, txtNumerator.Text<br/> Print #1, txtDenominator.Text<br/> <br/> '输出是否居中打印<br/> Print #1, "是否居中打印："<br/> Call OutputData2(chkCenterPlot, 1)<br/> <br/> '输出打印偏移<br/> Print #1, "打印偏移："<br/> Print #1, txtOffsetX.Text<br/> Print #1, txtOffsetY.Text<br/> <br/> '输出是否打印对象线宽<br/> Print #1, "是否打印对象线宽："<br/> Call OutputData2(chkPlotWithLineweights, 1)<br/> '输出是否采用打印样式<br/> Print #1, "是否采用打印样式："<br/> Call OutputData2(chkPlotWithPlotStyles, 1)<br/> '输出是否隐藏图纸空间对象<br/> Print #1, "是否隐藏图纸空间对象："<br/> Call OutputData2(chkPlotHidden, 1)<br/> <br/> '输出图框形式<br/> Print #1, "图框形式："<br/> '输出图框形式信息<br/> If optBlock.Value = True Then<br/> strTemp = "图块"<br/> Else<br/> strTemp = "图层"<br/> End If<br/> Print #1, strTemp<br/> <br/> '输出图块名列表<br/> Print #1, "图块名列表："<br/> '输出图块名列表的信息<br/> Call OutputData(cboBlockName, 1)<br/> <br/> '输出图层名列表<br/> Print #1, "图块名列表："<br/> '输出图层名列表的信息<br/> Call OutputData(cboLayerName, 1)<br/> <br/> '关闭文件<br/> Close 1</p><p>End Sub</p><p>Private Sub cmdPick_Click()<br/> On Error Resume Next<br/> Dim objSelect As AcadEntity<br/> Dim ptPick As Variant<br/> Dim strTemp As String<br/> <br/> Set objDoc = ThisDrawing.Application.ActiveDocument<br/> '将控制权交给AutoCAD<br/> frmBatchPlot.Hide<br/> '在AutoCAD中选择实体并判断类型<br/>Retry:<br/> objDoc.Utility.GetEntity objSelect, ptPick, vbCrLf & "请选择实体："<br/> ' 处理按下Esc键的错误<br/> If objSelect Is Nothing Then<br/> If CheckKey(VK_ESCAPE) = True Then<br/> '显示对话框<br/> frmBatchPlot.Show<br/> Exit Sub<br/> Else<br/> GoTo Retry<br/> End If<br/> End If<br/> ' 处理未选择到实体的错误<br/> If Err <> 0 Then<br/> Err.Clear<br/> GoTo Retry<br/> End If<br/> <br/> '若为指定图块<br/> If optBlock.Value = True Then<br/> '判断实体是否块参照<br/> If TypeOf objSelect Is AcadBlockReference Then<br/> '判断实体是否模型空间、图纸空间和匿名块<br/> If StrComp(Left(objSelect.name, 1), "*") <> 0 Then<br/> '获得块参照名<br/> strTemp = objSelect.name<br/> Else<br/> MsgBox "您选择的是匿名块，请重新选择块参照！", vbCritical<br/> '显示对话框<br/> frmBatchPlot.Show<br/> Exit Sub<br/> End If<br/> Else<br/> MsgBox "您选择的不是块参照，请重新选择块参照！", vbCritical<br/> '显示对话框<br/> frmBatchPlot.Show<br/> Exit Sub<br/> End If<br/> '刷新块参照列表<br/> Call ListBlock<br/> '将所选块参照在组合框中置为当前<br/> Call SetSelected(cboBlockName, strTemp)<br/> Else<br/> '判断实体是否多段线<br/> If TypeOf objSelect Is AcadLWPolyline Then<br/> '获得多段线所在图层名<br/> strTemp = objSelect.Layer<br/> Else<br/> MsgBox "您选择的不是轻量多段线，请重新选择轻量多段线！", vbCritical<br/> '显示对话框<br/> frmBatchPlot.Show<br/> Exit Sub<br/> End If<br/> ' 刷新图层列表<br/> Call ListLayer<br/> '将所选实体所在图层在组合框中置为当前<br/> Call SetSelected(cboLayerName, strTemp)<br/> End If<br/> '显示对话框<br/> frmBatchPlot.Show</p><p>End Sub</p><p>Private Sub cmdPreview_Click()<br/> '若按图块进行批量打印<br/> If optBlock.Value = True Then<br/> If cboBlockName.ListCount = 0 Or cboBlockName.Text = "" Then<br/> MsgBox "请先选择块参照！", vbCritical<br/> Exit Sub<br/> End If<br/> Call PreviewByBlock(cboBlockName.Text)<br/> '若按图层进行批量打印<br/> Else<br/> If cboLayerName.ListCount = 0 Or cboLayerName.Text = "" Then<br/> MsgBox "请先选择块参照！", vbCritical<br/> Exit Sub<br/> End If<br/> Call PreviewByLayer(cboLayerName.Text)<br/> End If<br/> <br/>End Sub</p><p>Private Sub cmdRefresh_Click()<br/> '刷新块参照列表<br/> Call ListBlock<br/> ' 刷新图层列表<br/> Call ListLayer<br/>End Sub</p><p>Private Sub cmdPlot_Click()<br/> '若按图块进行批量打印<br/> If optBlock.Value = True Then<br/> If cboBlockName.ListCount = 0 Or cboBlockName.Text = "" Then<br/> MsgBox "请先选择块参照！", vbCritical<br/> Exit Sub<br/> End If<br/> Call BatchPlotByBlock(cboBlockName.Text)<br/> '若按图层进行批量打印<br/> Else<br/> If cboLayerName.ListCount = 0 Or cboLayerName.Text = "" Then<br/> MsgBox "请先选择块参照！", vbCritical<br/> Exit Sub<br/> End If<br/> Call BatchPlotByLayer(cboLayerName.Text)<br/> End If<br/> <br/>End Sub</p><p>Private Sub cmdAbout_Click()<br/> '显示关于对话框<br/> frmAbout.Show<br/>End Sub</p><p>Private Sub Label26_Click()</p><p>End Sub</p><p>Private Sub optBlock_Change()<br/> '设置“图块与图层”组各控件激活状态<br/> If optBlock.Value = True Then<br/> lbBlockName.Enabled = True<br/> cboBlockName.Enabled = True<br/> lbLayerName.Enabled = False<br/> cboLayerName.Enabled = False<br/> Else<br/> lbBlockName.Enabled = False<br/> cboBlockName.Enabled = False<br/> lbLayerName.Enabled = True<br/> cboLayerName.Enabled = True<br/> End If<br/>End Sub</p><p>Private Sub optLayer_Change()<br/> '设置“图块与图层”组各控件激活状态<br/> If optBlock.Value = True Then<br/> lbBlockName.Enabled = True<br/> cboBlockName.Enabled = True<br/> lbLayerName.Enabled = False<br/> cboLayerName.Enabled = False<br/> Else<br/> lbBlockName.Enabled = False<br/> cboBlockName.Enabled = False<br/> lbLayerName.Enabled = True<br/> cboLayerName.Enabled = True<br/> End If<br/>End Sub</p><p>Private Sub optMillimeters_Change()<br/> '设置图纸单位<br/> If (optMillimeters.Value = True And ms = False) Then<br/> '设置图纸单位<br/> objPlotConfiguration.PaperUnits = acMillimeters<br/> '修改标签<br/> lbUnit.Caption = "毫米 ＝"<br/> lbUnitX.Caption = "毫米"<br/> lbUnitY.Caption = "毫米"<br/> lbPaperUnit.Caption = "毫米"<br/> Denominator = Denominator / 25.4<br/> txtDenominator.Text = Format(Denominator, "#########0.000")<br/> txtOffsetX.Text = Format(OffsetX, "#########0.00")<br/> txtOffsetY.Text = Format(OffsetY, "#########0.00")<br/> ElseIf (optMillimeters.Value = False And ms = True) Then<br/> '设置图纸单位<br/> objPlotConfiguration.PaperUnits = acInches<br/> '修改标签<br/> lbUnit.Caption = "英寸 ＝"<br/> lbUnitX.Caption = "英寸"<br/> lbUnitY.Caption = "英寸"<br/> lbPaperUnit.Caption = "英寸"<br/> Denominator = Denominator * 25.4<br/> txtDenominator.Text = Format(Denominator, "#########0.000")<br/> txtOffsetX.Text = Format(OffsetX / 25.4, "#########0.00")<br/> txtOffsetY.Text = Format(OffsetY / 25.4, "#########0.00")<br/> End If<br/> <br/> '非“按图纸空间缩放”时由标准比例变为自定义比例<br/> If cboPlotScale.ListIndex > 1 Then cboPlotScale.ListIndex = 0<br/> <br/> '显示图纸尺寸<br/> Call SetPlotZone<br/> <br/> ms = optMillimeters.Value<br/>End Sub</p><p>Private Sub optSortZ_Click()</p><p>End Sub</p><p>Private Sub OptVertical_Change()<br/> '设置图纸打印方向<br/> Call PaperRotationChange<br/> '当图纸比例选项为“按图纸空间缩放”时重新计算缩放比例<br/> If cboPlotScale.ListIndex = 1 Then Call SetScaleToFit<br/> ' 当居中打印时重新计算打印偏移<br/> If chkCenterPlot.Value Then Call SetOffset<br/> <br/>End Sub</p><p>Private Sub spnAngle_SpinDown()<br/> If CInt(txtNumber.Text) > 1 Then<br/> txtNumber.Text = CInt(txtNumber.Text) - 1<br/> End If<br/>End Sub</p><p>Private Sub spnAngle_SpinUp()<br/> txtNumber.Text = CInt(txtNumber.Text) + 1<br/>End Sub</p><p>Private Sub txtCurPath_Change()<br/> '查找文件，向列表框中添加<br/> If Len(Dir(txtCurPath.Text)) > 0 Then<br/> FindFile colDwgs, txtCurPath.Text, "dwg"<br/> If AddToList(lstCurFiles, colDwgs) Then<br/> End If<br/> End If<br/>End Sub</p><p>Private Sub txtDenominator_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)<br/> ' 设置自定义图纸尺寸<br/> If IsNumeric(CDbl(txtDenominator.Text)) Then<br/> Dim strTemp As String<br/> '记住文本框文本<br/> strTemp = txtDenominator.Text<br/> '设置组合框显示项目为“自定义”<br/> cboPlotScale.ListIndex = 0<br/> '恢复文本框文字（上步操作有时会导致文本框值归1）<br/> txtDenominator.Text = strTemp<br/> '将文本框文本转换为实数<br/> Denominator = CDbl(txtDenominator.Text)<br/> '使用自定义打印比例<br/> objPlotConfiguration.UseStandardScale = False<br/> '设置自定义打印比例<br/> objPlotConfiguration.SetCustomScale Numerator, Denominator<br/> ' 当居中打印时重新计算打印偏移<br/> If chkCenterPlot.Value Then Call SetOffset<br/> Else<br/> MsgBox "请输入数字！", vbCritical<br/> End If<br/>End Sub</p><p>Private Sub txtNumerator_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)<br/> ' 设置自定义图纸尺寸<br/> If IsNumeric(CDbl(txtNumerator.Text)) Then<br/> Dim strTemp As String<br/> '记住文本框文本<br/> strTemp = txtNumerator.Text<br/> '设置组合框显示项目为“自定义”<br/> cboPlotScale.ListIndex = 0<br/> '恢复文本框文字（上步操作有时会导致文本框值归1）<br/> txtNumerator.Text = strTemp<br/> '将文本框文本转换为实数<br/> Numerator = CDbl(txtNumerator.Text)<br/> '使用自定义打印比例<br/> objPlotConfiguration.UseStandardScale = False<br/> '设置自定义打印比例<br/> objPlotConfiguration.SetCustomScale Numerator, Denominator<br/> ' 当居中打印时重新计算打印偏移<br/> If chkCenterPlot.Value Then Call SetOffset<br/> Else<br/> MsgBox "请输入数字！", vbCritical<br/> End If<br/>End Sub</p><p>Private Sub txtOffsetX_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)<br/> ' 输入检查<br/> If Not ((KeyAscii >= Asc("0") And KeyAscii <= Asc("9")) Or KeyAscii = Asc(".") Or KeyAscii = Asc("-")) Then<br/> MsgBox "请输入数字！", vbCritical<br/> End If<br/>End Sub</p><p>Private Sub txtOffsetX_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)<br/> On Error Resume Next<br/> ' 设置自定义图纸尺寸<br/> If IsNumeric(CDbl(txtOffsetX.Text)) Then<br/> Dim strTemp As String<br/> '记住文本框文本<br/> strTemp = txtOffsetX.Text<br/> '将文本框文本转换为实数<br/> OffsetX = CDbl(txtOffsetX.Text)<br/> '取消“居中打印”复选框<br/> chkCenterPlot.Value = False<br/> '恢复文本框文字（上步操作有时会导致文本框值归零）<br/> txtOffsetX.Text = strTemp<br/> Dim ptPlotOrigin(0 To 1) As Double<br/> '设置自定义打印偏移<br/> '图形方向为“横向”时宽高互调<br/> ptPlotOrigin(0) = IIf(optVertical.Value, OffsetX, OffsetY)<br/> ptPlotOrigin(1) = IIf(optVertical.Value, OffsetY, OffsetX)<br/> objPlotConfiguration.CenterPlot = False<br/> objPlotConfiguration.PlotOrigin = ptPlotOrigin<br/> Else<br/> MsgBox "请输入数字！", vbCritical<br/> End If<br/>End Sub</p><p>Private Sub txtOffsetY_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)<br/> ' 输入检查<br/> If Not ((KeyAscii >= Asc("0") And KeyAscii <= Asc("9")) Or KeyAscii = Asc(".") Or KeyAscii = Asc("-")) Then<br/> MsgBox "请输入数字！", vbCritical<br/> End If<br/>End Sub</p><p>Private Sub txtOffsetY_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)<br/> On Error Resume Next<br/> ' 设置自定义图纸尺寸<br/> If IsNumeric(CDbl(txtOffsetY.Text)) Then<br/> Dim strTemp As String<br/> '记住文本框文本<br/> strTemp = txtOffsetY.Text<br/> '将文本框文本转换为实数<br/> OffsetY = CDbl(txtOffsetY.Text)<br/> '取消“居中打印”复选框<br/> chkCenterPlot.Value = False<br/> '恢复文本框文字（上步操作有时会导致文本框值归零）<br/> txtOffsetY.Text = strTemp<br/> Dim ptPlotOrigin(0 To 1) As Double<br/> '设置自定义打印偏移<br/> '图形方向为“横向”时宽高互调<br/> ptPlotOrigin(0) = IIf(optVertical.Value, OffsetX, OffsetY)<br/> ptPlotOrigin(1) = IIf(optVertical.Value, OffsetY, OffsetX)<br/> objPlotConfiguration.CenterPlot = False<br/> objPlotConfiguration.PlotOrigin = ptPlotOrigin<br/> Else<br/> MsgBox "请输入数字！", vbCritical<br/> End If<br/>End Sub</p><p>Private Sub UserForm_Initialize()<br/> On Error Resume Next<br/> '取得当前文档对象<br/> Set objDoc = ThisDrawing.Application.ActiveDocument<br/> '取得当前布局对象<br/> Set objLayout = ThisDrawing.ActiveLayout<br/> '取得当前打印对象<br/> Set objPlot = ThisDrawing.Plot<br/> '从文件对象取得打印配置集合<br/> Set objPlotConfigurations = ThisDrawing.PlotConfigurations<br/> '清空以前的打印配置集合<br/> For Each objPlotConfiguration In objPlotConfigurations<br/> objPlotConfiguration.Delete<br/> Next<br/> '添加打印配置<br/> Set objOriginalPC = objPlotConfigurations.Add("原来的打印配置", True)<br/> Set objPlotConfiguration = objPlotConfigurations.Add("我的打印配置", True)<br/> '复制打印配置<br/> objOriginalPC.CopyFrom objLayout<br/> objPlotConfiguration.CopyFrom objLayout<br/> '重命名打印配置<br/> objOriginalPC.name = "原来的打印配置"<br/> objPlotConfiguration.name = "我的打印配置"<br/> <br/> '禁用“当前路径”文本框<br/> txtCurPath.Enabled = False<br/> <br/> '设置图纸单位<br/> If objOriginalPC.PaperUnits = acInches Then<br/> optInches.Value = True<br/> Else<br/> optMillimeters.Value = True<br/> End If<br/> '记录上次的图纸单位设置<br/> ms = optMillimeters.Value<br/> <br/> '设置图纸方向<br/> Call GetPlotRotation<br/> '刷新打印机列表<br/> Call ListPlotDeviceNames<br/> '刷新打印样式表<br/> Call ListPlotStyleTableNames<br/> '刷新打印比例列表<br/> Call ListPlotScale<br/> <br/> '设置是否居中打印<br/> chkCenterPlot.Value = objOriginalPC.CenterPlot<br/> '设置打印偏移<br/> If Not chkCenterPlot.Value Then<br/> Dim ptPlotOrigin As Variant<br/> '读取打印偏移<br/> ptPlotOrigin = objOriginalPC.PlotOrigin<br/> '设置打印偏移<br/> '图形方向为“横向”时宽高互调<br/> OffsetX = IIf(optVertical.Value, ptPlotOrigin(0), ptPlotOrigin(1))<br/> OffsetY = IIf(optVertical.Value, ptPlotOrigin(1), ptPlotOrigin(0))<br/> txtOffsetX.Text = OffsetX<br/> txtOffsetY.Text = OffsetY<br/> End If<br/> <br/> '设置图纸打印份数<br/> txtNumber.Text = objPlot.NumberOfCopies<br/> <br/> '设置“打印到文件”是否选中<br/> chkPlotToFile.Value = False<br/> '禁用“打印到文件”组各控件<br/> lbPlotPath.Enabled = False<br/> cboPlotPath.Enabled = False<br/> cmdBrowse2.Enabled = False<br/> <br/> '设置打印选项<br/> chkPlotWithPlotStyles.Value = objOriginalPC.PlotWithPlotStyles<br/> chkPlotWithLineweights.Enabled = Not (chkPlotWithPlotStyles.Value)<br/> chkPlotWithLineweights.Value = objOriginalPC.PlotWithLineweights<br/> chkPlotHidden.Value = objOriginalPC.PlotHidden<br/> <br/> ' 显示AutoCAD中当前可用的图块<br/> Call ListBlock<br/> ' 显示AutoCAD中当前可用的图层<br/> Call ListLayer<br/> <br/>End Sub</p><p>Public Sub GetPlotRotation()<br/> Dim PaperWidth As Double, PaperHeight As Double, t As Double<br/> '取得图纸尺寸信息<br/> objOriginalPC.GetPaperSize PaperWidth, PaperHeight<br/> '设置图纸方向<br/> If PaperWidth < PaperHeight Then<br/> Select Case objOriginalPC.PlotRotation<br/> Case ac0degrees<br/> optVertical.Value = True<br/> chkReverse.Value = False<br/> Case ac90degrees<br/> optHorizontal.Value = True<br/> chkReverse.Value = False<br/> Case ac180degrees<br/> optVertical.Value = True<br/> chkReverse.Value = True<br/> Case ac270degrees<br/> optHorizontal.Value = True<br/> chkReverse.Value = True<br/> End Select<br/> Else<br/> Select Case objOriginalPC.PlotRotation<br/> Case ac0degrees<br/> optHorizontal.Value = True<br/> chkReverse.Value = False<br/> Case ac90degrees<br/> optVertical.Value = True<br/> chkReverse.Value = False<br/> Case ac180degrees<br/> optHorizontal.Value = True<br/> chkReverse.Value = True<br/> Case ac270degrees<br/> optVertical.Value = True<br/> chkReverse.Value = True<br/> End Select<br/> End If<br/> <br/>End Sub</p><p>Public Sub SetPlotRotation()<br/> Dim PaperWidth As Double, PaperHeight As Double, t As Double<br/> '取得图纸尺寸信息<br/> objPlotConfiguration.GetPaperSize PaperWidth, PaperHeight<br/> ' 设置图纸打印方向<br/> If PaperWidth < PaperHeight Then<br/> If optVertical.Value = True Then<br/> If chkReverse.Value = False Then<br/> objPlotConfiguration.PlotRotation = ac0degrees<br/> Else<br/> objPlotConfiguration.PlotRotation = ac180degrees<br/> End If<br/> Else<br/> If chkReverse.Value = False Then<br/> objPlotConfiguration.PlotRotation = ac90degrees<br/> Else<br/> objPlotConfiguration.PlotRotation = ac270degrees<br/> End If<br/> End If<br/> Else<br/> If optVertical.Value = True Then<br/> If chkReverse.Value = False Then<br/> objPlotConfiguration.PlotRotation = ac90degrees<br/> Else<br/> objPlotConfiguration.PlotRotation = ac270degrees<br/> End If<br/> Else<br/> If chkReverse.Value = False Then<br/> objPlotConfiguration.PlotRotation = ac0degrees<br/> Else<br/> objPlotConfiguration.PlotRotation = ac180degrees<br/> End If<br/> End If<br/> End If<br/> <br/>End Sub</p><p>Public Sub SetPlotConfiguration()<br/> '因有些选项会相互影响，打印前再应用一次打印配置以确保打印成功<br/> '设置打印机配置<br/> objPlotConfiguration.ConfigName = cboPrintersName.Text<br/> ' 设置打印样式表<br/> objPlotConfiguration.StyleSheet = cboPlotStyleTableNames.Text<br/> ' 设置图纸尺寸<br/> objPlotConfiguration.CanonicalMediaName = paperSizes(cboPaperSize.ListIndex)<br/> '设置图纸单位<br/> objPlotConfiguration.PaperUnits = IIf(optMillimeters.Value, acMillimeters, acInches)<br/> <br/> Dim Q1<br/> '定义组合框索引到打印比例枚举值的映射<br/> Q1 = Array(100, 0, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, _<br/> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15)<br/> ' 设置图纸打印比例<br/> If cboPlotScale.ListIndex <> 0 Then<br/> '使用标准打印比例<br/> objPlotConfiguration.UseStandardScale = True<br/> '设置标准打印比例<br/> objPlotConfiguration.StandardScale = Q1(cboPlotScale.ListIndex)<br/> Else<br/> '使用自定义打印比例<br/> objPlotConfiguration.UseStandardScale = False<br/> '设置自定义打印比例<br/> objPlotConfiguration.SetCustomScale Numerator, Denominator<br/> End If<br/> <br/> ' 设置图纸打印方向<br/> Call SetPlotRotation<br/> <br/> ' 设置图纸是否居中打印<br/> If chkCenterPlot.Value Then<br/> objPlotConfiguration.CenterPlot = True<br/> Else<br/> '设置自定义打印偏移<br/> Dim ptPlotOrigin(0 To 1) As Double<br/> '图形方向为“横向”时宽高互调<br/> ptPlotOrigin(0) = IIf(optVertical.Value, OffsetX, OffsetY)<br/> ptPlotOrigin(1) = IIf(optVertical.Value, OffsetY, OffsetX)<br/> objPlotConfiguration.CenterPlot = False<br/> objPlotConfiguration.PlotOrigin = ptPlotOrigin<br/> End If<br/> <br/> '设置是否应用打印样式<br/> objPlotConfiguration.PlotWithPlotStyles = chkPlotWithPlotStyles.Value<br/> chkPlotWithLineweights.Enabled = Not (chkPlotWithPlotStyles.Value)<br/> '设置是否打印对象线宽<br/> If Not objPlotConfiguration.PlotWithPlotStyles Then _<br/> objPlotConfiguration.PlotWithLineweights = chkPlotWithLineweights.Value<br/> '设置是否隐藏图纸空间对象<br/> If Not objPlotConfiguration.ModelType Then objPlotConfiguration.PlotHidden = chkPlotHidden.Value<br/> <br/> '设置打印类型<br/> objPlotConfiguration.PlotType = acWindow<br/> <br/> '设置图纸打印份数<br/> objPlot.NumberOfCopies = txtNumber.Value<br/> '将打印错误报告切换为静默错误模式，以便不间断地执行打印任务<br/> objPlot.QuietErrorMode = True</p><p>End Sub</p><p>Private Sub BatchPlotByBlock(strBlockReferenceName As String)<br/> On Error Resume Next<br/> '如果列表框中未存在任何元素<br/> If lstPlotFiles.ListCount = 0 Then<br/> MsgBox "请先向列表框中添加文件！", vbCritical<br/> Exit Sub<br/> End If<br/> <br/> '将控制权交给AutoCAD<br/> frmBatchPlot.Hide<br/> ' 对第i个图形的每一个打印区域进行打印<br/> Dim ptMin As Variant, ptMax As Variant<br/> Dim ent As AcadEntity<br/> Dim i As Integer, j As Integer, n As Integer<br/> For i = 0 To lstPlotFiles.ListCount - 1<br/> n = 1<br/> '检查文件是否存在<br/> If Len(Dir(lstPlotFiles.List(i))) = 0 Then<br/> MsgBox "文件" & lstPlotFiles.List(i) & "不存在！"<br/> End If<br/> '打开或激活第i个图形文件<br/> Call OpenFile(lstPlotFiles.List(i))<br/> Set objDoc = ThisDrawing.Application.ActiveDocument<br/> '实现范围缩放<br/> ThisDrawing.Application.ZoomExtents<br/> ' 确保当前布局是模型空间<br/> Set objLayout = objDoc.Layouts.Item("Model")<br/> Set objPlot = objDoc.Plot<br/> ' 设置打印选项<br/> Call SetPlotConfiguration<br/> ' 将打印设置应用到当前图形<br/> objLayout.CopyFrom objPlotConfiguration<br/> '重新生成当前图形<br/> objDoc.Regen acAllViewports<br/> ' 确保AutoCAD在前台进行打印，这样后一次打印会在前一次打印完成之后才开始,避免出现错误<br/> objDoc.SetVariable "BACKGROUNDPLOT", 0<br/> <br/> '对当前图形模型空间中的所有打印区域进行打印<br/> Dim SSet As AcadSelectionSet<br/> '使用选择集获得对象集合<br/> Call SelectByBlock(strBlockReferenceName, SSet)<br/> <br/> Dim objCollection() As AcadEntity<br/> ReDim objCollection(SSet.count - 1)<br/> For j = 0 To SSet.count - 1<br/> Set objCollection(j) = SSet.Item(j)<br/> Next j<br/> <br/> ' 删除选择集<br/> SSet.Delete<br/> <br/> ' 设置图纸打印顺序<br/> If optSortZ.Value Then<br/> '按坐标对图框排序(左右，上下：y坐标从大到小,x坐标从小到大)<br/> Call SortZ(objCollection())<br/> Else<br/> '按坐标对图框排序(上下，左右：x坐标从小到大,y坐标从大到小)<br/> Call SortN(objCollection())<br/> End If<br/> <br/> ' 若选择倒序<br/> If chkSort.Value Then<br/> For j = 0 To UBound(objCollection) / 2<br/> Set ent = objCollection(j)<br/> Set objCollection(j) = objCollection(UBound(objCollection) - j)<br/> Set objCollection(UBound(objCollection) - j) = ent<br/> Next j<br/> End If<br/> <br/> '对选择集中每个对象进行打印或预览<br/> For j = 0 To UBound(objCollection)<br/> '获得每个对象最小包围框的两个角点<br/> objCollection(j).GetBoundingBox ptMin, ptMax<br/> '将世界坐标(WCS)转换为显示坐标(DCS)<br/> Dim PtMax_UCS As Variant<br/> Dim PtMin_UCS As Variant<br/> PtMax_UCS = ThisDrawing.Utility.TranslateCoordinates(ptMax, acWorld, acDisplayDCS, False)<br/> PtMin_UCS = ThisDrawing.Utility.TranslateCoordinates(ptMin, acWorld, acDisplayDCS, False)</p><p> '将三维点转化为二维点坐标<br/> ReDim Preserve PtMin_UCS(0 To 1)<br/> ReDim Preserve PtMax_UCS(0 To 1)<br/> <br/> ' 设置打印窗口(为显示坐标DCS)<br/> objLayout.SetWindowToPlot PtMax_UCS, PtMin_UCS</p><p> ' 打印当前的区域<br/> '若选中“打印到文件”<br/> If chkPlotToFile.Value Then<br/> objPlot.PlotToFile cboPlotPath.Text & objDoc.name & "-" & n & ".dwf"<br/> n = n + 1<br/> Else<br/> objPlot.PlotToDevice objLayout.ConfigName<br/> End If<br/> Next j<br/> <br/> ' 恢复系统变量的值<br/> objDoc.SetVariable "BACKGROUNDPLOT", 2<br/> '保存当前图形<br/> 'objDoc.Save<br/> '关闭但不保存当前图形<br/> '保证至少一个文件打开<br/> If ThisDrawing.Application.Documents.count > 1 Then<br/> objDoc.Close False<br/> End If<br/> Next i<br/> '显示对话框<br/> frmBatchPlot.Show<br/>End Sub</p><p>Private Sub BatchPlotByLayer(strLayerName As String)<br/> On Error Resume Next<br/> '如果列表框中未存在任何元素<br/> If lstPlotFiles.ListCount = 0 Then<br/> MsgBox "请先向列表框中添加文件！", vbCritical<br/> Exit Sub<br/> End If<br/> <br/> '将控制权交给AutoCAD<br/> frmBatchPlot.Hide<br/> ' 对第i个图形的每一个打印区域进行打印<br/> Dim ptMin As Variant, ptMax As Variant<br/> Dim ent As AcadEntity<br/> Dim i As Integer, j As Integer, n As Integer<br/> For i = 0 To lstPlotFiles.ListCount - 1<br/> n = 1<br/> '检查文件是否存在<br/> If Len(Dir(lstPlotFiles.List(i))) = 0 Then<br/> MsgBox "文件" & lstPlotFiles.List(i) & "不存在！"<br/> End If<br/> '打开或激活第i个图形文件<br/> Call OpenFile(lstPlotFiles.List(i))<br/> Set objDoc = ThisDrawing.Application.ActiveDocument<br/> '实现范围缩放<br/> ThisDrawing.Application.ZoomExtents<br/> ' 确保当前布局是模型空间<br/> Set objLayout = objDoc.Layouts.Item("Model")<br/> Set objPlot = objDoc.Plot<br/> ' 设置打印选项<br/> Call SetPlotConfiguration<br/> ' 将打印设置应用到当前图形<br/> objLayout.CopyFrom objPlotConfiguration<br/> '重新生成当前图形<br/> objDoc.Regen acAllViewports<br/> ' 确保AutoCAD在前台进行打印，这样后一次打印会在前一次打印完成之后才开始,避免出现错误<br/> objDoc.SetVariable "BACKGROUNDPLOT", 0<br/> <br/> '对当前图形模型空间中的所有打印区域进行打印<br/> Dim SSet As AcadSelectionSet<br/> '使用选择集获得对象集合<br/> Call SelectByLayer(strLayerName, SSet)<br/> <br/> Dim objCollection() As AcadEntity<br/> ReDim objCollection(SSet.count - 1)<br/> For j = 0 To SSet.count - 1<br/> Set objCollection(j) = SSet.Item(j)<br/> Next j<br/> <br/> ' 删除选择集<br/> SSet.Delete<br/> <br/> ' 设置图纸打印顺序<br/> If optSortZ.Value Then<br/> '按坐标对图框排序(左右，上下：y坐标从大到小,x坐标从小到大)<br/> Call SortZ(objCollection())<br/> Else<br/> '按坐标对图框排序(上下，左右：x坐标从小到大,y坐标从大到小)<br/> Call SortN(objCollection())<br/> End If<br/> <br/> ' 若选择倒序<br/> If chkSort.Value Then<br/> For j = 0 To UBound(objCollection) / 2<br/> Set ent = objCollection(j)<br/> Set objCollection(j) = objCollection(UBound(objCollection) - j)<br/> Set objCollection(UBound(objCollection) - j) = ent<br/> Next j<br/> End If<br/> <br/> '对选择集中每个对象进行打印或预览<br/> For j = 0 To UBound(objCollection)<br/> '获得每个对象最小包围框的两个角点<br/> objCollection(j).GetBoundingBox ptMin, ptMax<br/> '将世界坐标(WCS)转换为显示坐标(DCS)<br/> Dim PtMax_UCS As Variant<br/> Dim PtMin_UCS As Variant<br/> PtMax_UCS = ThisDrawing.Utility.TranslateCoordinates(ptMax, acWorld, acDisplayDCS, False)<br/> PtMin_UCS = ThisDrawing.Utility.TranslateCoordinates(ptMin, acWorld, acDisplayDCS, False)</p><p> '将三维点转化为二维点坐标<br/> ReDim Preserve PtMin_UCS(0 To 1)<br/> ReDim Preserve PtMax_UCS(0 To 1)<br/> <br/> ' 设置打印窗口(为显示坐标DCS)<br/> objLayout.SetWindowToPlot PtMax_UCS, PtMin_UCS</p><p> ' 打印当前的区域<br/> '若选中“打印到文件”<br/> If chkPlotToFile.Value Then<br/> objPlot.PlotToFile cboPlotPath.Text & objDoc.name & "-" & n & ".dwf"<br/> n = n + 1<br/> Else<br/> objPlot.PlotToDevice objLayout.ConfigName<br/> End If<br/> Next j<br/> <br/> ' 恢复系统变量的值<br/> objDoc.SetVariable "BACKGROUNDPLOT", 2<br/> '保存当前图形<br/> 'objDoc.Save<br/> '关闭但不保存当前图形<br/> '保证至少一个文件打开<br/> If ThisDrawing.Application.Documents.count > 1 Then<br/> objDoc.Close False<br/> End If<br/> Next i<br/> '显示对话框<br/> frmBatchPlot.Show<br/>End Sub</p><p>Private Sub PreviewByBlock(strBlockReferenceName As String)<br/> On Error Resume Next<br/> '如果列表框中未存在任何元素<br/> If lstPlotFiles.ListCount = 0 Then<br/> MsgBox "请先向列表框中添加文件！", vbCritical<br/> Exit Sub<br/> End If<br/> <br/> '将控制权交给AutoCAD<br/> frmBatchPlot.Hide<br/> ' 对第一个图形的第一个打印区域进行完全预览<br/> Dim ptMin As Variant, ptMax As Variant<br/> Dim ent As AcadEntity<br/> Dim i As Integer, j As Integer, n As Integer<br/> For i = 0 To lstPlotFiles.ListCount - 1<br/> n = 1<br/> '检查文件是否存在<br/> If Len(Dir(lstPlotFiles.List(i))) = 0 Then<br/> MsgBox "文件" & lstPlotFiles.List(i) & "不存在！"<br/> End If<br/> '打开或激活第i个图形文件<br/> Call OpenFile(lstPlotFiles.List(i))<br/> Set objDoc = ThisDrawing.Application.ActiveDocument<br/> '实现范围缩放<br/> ThisDrawing.Application.ZoomExtents<br/> ' 确保当前布局是模型空间<br/> Set objLayout = objDoc.Layouts.Item("Model")<br/> Set objPlot = objDoc.Plot<br/> ' 设置打印选项<br/> Call SetPlotConfiguration<br/> ' 将打印设置应用到当前图形<br/> objLayout.CopyFrom objPlotConfiguration<br/> '重新生成当前图形<br/> objDoc.Regen acAllViewports<br/> <br/> '对当前图形模型空间中的所有打印区域进行完全预览<br/> Dim SSet As AcadSelectionSet<br/> '使用选择集获得对象集合<br/> Call SelectByBlock(strBlockReferenceName, SSet)<br/> <br/> Dim objCollection() As AcadEntity<br/> ReDim objCollection(SSet.count - 1)<br/> For j = 0 To SSet.count - 1<br/> Set objCollection(j) = SSet.Item(j)<br/> Next j<br/> <br/> ' 删除选择集<br/> SSet.Delete<br/> <br/> ' 设置图纸打印顺序<br/> If optSortZ.Value Then<br/> '按坐标对图框排序(左右，上下：y坐标从大到小,x坐标从小到大)<br/> Call SortZ(objCollection())<br/> Else<br/> '按坐标对图框排序(上下，左右：x坐标从小到大,y坐标从大到小)<br/> Call SortN(objCollection())<br/> End If<br/> <br/> ' 若选择倒序<br/> If chkSort.Value Then<br/> For j = 0 To UBound(objCollection) / 2<br/> Set ent = objCollection(j)<br/> Set objCollection(j) = objCollection(UBound(objCollection) - j)<br/> Set objCollection(UBound(objCollection) - j) = ent<br/> Next j<br/> End If<br/> <br/> '对选择集中每个对象进行打印或预览<br/> For j = 0 To UBound(objCollection)<br/> '获得每个对象最小包围框的两个角点<br/> objCollection(j).GetBoundingBox ptMin, ptMax<br/> '将世界坐标(WCS)转换为显示坐标(DCS)<br/> Dim PtMax_UCS As Variant<br/> Dim PtMin_UCS As Variant<br/> PtMax_UCS = ThisDrawing.Utility.TranslateCoordinates(ptMax, acWorld, acDisplayDCS, False)<br/> PtMin_UCS = ThisDrawing.Utility.TranslateCoordinates(ptMin, acWorld, acDisplayDCS, False)</p><p> '将三维点转化为二维点坐标<br/> ReDim Preserve PtMin_UCS(0 To 1)<br/> ReDim Preserve PtMax_UCS(0 To 1)<br/> <br/> ' 设置打印窗口(为显示坐标DCS)<br/> objLayout.SetWindowToPlot PtMax_UCS, PtMin_UCS</p><p> '完全预览当前的区域<br/> objPlot.DisplayPlotPreview acFullPreview<br/> n = n + 1<br/> If n > 1 Then<br/> '恢复原来的打印设置<br/> objLayout.CopyFrom objOriginalPC<br/> '显示对话框<br/> frmBatchPlot.Show<br/> Exit Sub<br/> End If<br/> Next j<br/> Next i<br/> <br/> '无打印区域时显示对话框<br/> MsgBox "选定图形中无打印区域！", vbCritical<br/> '恢复原来的打印设置<br/> objLayout.CopyFrom objOriginalPC<br/> '显示对话框<br/> frmBatchPlot.Show<br/> <br/>End Sub</p><p>Private Sub PreviewByLayer(strLayerName As String)<br/> On Error Resume Next<br/> '如果列表框中未存在任何元素<br/> If lstPlotFiles.ListCount = 0 Then<br/> MsgBox "请先向列表框中添加文件！", vbCritical<br/> Exit Sub<br/> End If<br/> <br/> '将控制权交给AutoCAD<br/> frmBatchPlot.Hide<br/> ' 对第i个图形的每一个打印区域进行打印<br/> Dim ptMin As Variant, ptMax As Variant<br/> Dim ent As AcadEntity<br/> Dim i As Integer, j As Integer, n As Integer<br/> For i = 0 To lstPlotFiles.ListCount - 1<br/> n = 1<br/> '检查文件是否存在<br/> If Len(Dir(lstPlotFiles.List(i))) = 0 Then<br/> MsgBox "文件" & lstPlotFiles.List(i) & "不存在！"<br/> End If<br/> '打开或激活第i个图形文件<br/> Call OpenFile(lstPlotFiles.List(i))<br/> Set objDoc = ThisDrawing.Application.ActiveDocument<br/> '实现范围缩放<br/> ThisDrawing.Application.ZoomExtents<br/> ' 确保当前布局是模型空间<br/> Set objLayout = objDoc.Layouts.Item("Model")<br/> Set objPlot = objDoc.Plot<br/> ' 设置打印选项<br/> Call SetPlotConfiguration<br/> ' 将打印设置应用到当前图形<br/> objLayout.CopyFrom objPlotConfiguration<br/> '重新生成当前图形<br/> objDoc.Regen acAllViewports<br/> <br/> '对当前图形模型空间中的所有打印区域进行完全预览<br/> Dim SSet As AcadSelectionSet<br/> '使用选择集获得对象集合<br/> Call SelectByLayer(strLayerName, SSet)<br/> <br/> Dim objCollection() As AcadEntity<br/> ReDim objCollection(SSet.count - 1)<br/> For j = 0 To SSet.count - 1<br/> Set objCollection(j) = SSet.Item(j)<br/> Next j<br/> <br/> ' 删除选择集<br/> SSet.Delete<br/> <br/> ' 设置图纸打印顺序<br/> If optSortZ.Value Then<br/> '按坐标对图框排序(左右，上下：y坐标从大到小,x坐标从小到大)<br/> Call SortZ(objCollection())<br/> Else<br/> '按坐标对图框排序(上下，左右：x坐标从小到大,y坐标从大到小)<br/> Call SortN(objCollection())<br/> End If<br/> <br/> ' 若选择倒序<br/> If chkSort.Value Then<br/> For j = 0 To UBound(objCollection) / 2<br/> Set ent = objCollection(j)<br/> Set objCollection(j) = objCollection(UBound(objCollection) - j)<br/> Set objCollection(UBound(objCollection) - j) = ent<br/> Next j<br/> End If<br/> <br/> '对选择集中每个对象进行打印或预览<br/> For j = 0 To UBound(objCollection)<br/> '获得每个对象最小包围框的两个角点<br/> objCollection(j).GetBoundingBox ptMin, ptMax<br/> '将世界坐标(WCS)转换为显示坐标(DCS)<br/> Dim PtMax_UCS As Variant<br/> Dim PtMin_UCS As Variant<br/> PtMax_UCS = ThisDrawing.Utility.TranslateCoordinates(ptMax, acWorld, acDisplayDCS, False)<br/> PtMin_UCS = ThisDrawing.Utility.TranslateCoordinates(ptMin, acWorld, acDisplayDCS, False)</p><p> '将三维点转化为二维点坐标<br/> ReDim Preserve PtMin_UCS(0 To 1)<br/> ReDim Preserve PtMax_UCS(0 To 1)<br/> <br/> ' 设置打印窗口(为显示坐标DCS)<br/> objLayout.SetWindowToPlot PtMax_UCS, PtMin_UCS</p><p> '完全预览当前的区域<br/> objPlot.DisplayPlotPreview acFullPreview<br/> n = n + 1<br/> If n > 1 Then<br/> '恢复原来的打印设置<br/> objLayout.CopyFrom objOriginalPC<br/> '显示对话框<br/> frmBatchPlot.Show<br/> Exit Sub<br/> End If<br/> Next j<br/> <br/> Next i<br/> <br/> '无打印区域时显示对话框<br/> MsgBox "选定图形中无打印区域！", vbCritical<br/> '恢复原来的打印设置<br/> objLayout.CopyFrom objOriginalPC<br/> '显示对话框<br/> frmBatchPlot.Show<br/> <br/>End Sub</p><p>Public Function ReturnFolder(lngHwnd As Long) As String<br/> Dim Browser As BrowseInfo<br/> Dim lngFolder As Long<br/> Dim strPath As String<br/> Dim strTemp As String<br/> <br/> With Browser<br/> .hOwner = lngHwnd<br/> .lpszTitle = "选择工作路径"<br/> .pszDisplayName = String(MAX_PATH, 0)<br/> End With<br/> <br/> '用空格填充字符串<br/> strPath = String(MAX_PATH, 0)<br/> '调用API函数显示文件夹列表<br/> lngFolder = SHBrowseForFolder(Browser)<br/> <br/> '使用API函数获取返回的路径<br/> If lngFolder Then<br/> SHGetPathFromIDList lngFolder, strPath<br/> strTemp = Left(strPath, InStr(strPath, vbNullChar) - 1)<br/> <br/> If (Right(strTemp, 1) <> "\") Then<br/> strTemp = strTemp & "\"<br/> End If<br/> <br/> ReturnFolder = strTemp<br/> End If<br/>End Function</p><p>Public Sub FindFile(ByRef files As Collection, strDir, strExt)<br/> '删除集合中所有的对象<br/> Dim i As Integer<br/> For i = 1 To files.count<br/> files.Remove 1<br/> Next i<br/> <br/> '查找dwg文件，并将其添加到集合中<br/> Dim strFileName As String<br/> <br/> If (Right(strDir, 1) <> "\") Then<br/> strDir = strDir & "\"<br/> End If<br/> strFileName = Dir(strDir & "*.*", vbDirectory)<br/> <br/> Do While (strFileName <> "")<br/> If (UCase(Right(strFileName, 3)) = UCase(strExt)) Then<br/> files.Add strDir & strFileName<br/> End If<br/> strFileName = Dir '返回下一个符合条件的文件<br/> Loop<br/>End Sub</p><p>Public Function AddToList(objBox As ListBox, Names As Collection) As Boolean<br/> Dim i As Integer<br/> On Error GoTo Error_Control<br/> <br/> objBox.Clear<br/> '将集合中的对象添加到列表框中<br/> For i = 1 To Names.count<br/> objBox.AddItem Names(i)<br/> Next i<br/> <br/>Exit_Here:<br/> AddToList = True<br/> Exit Function<br/> <br/>Error_Control:<br/> MsgBox "发生下面的错误：" & Err.Number<br/> AddToList = False<br/>End Function</p><p>Private Function HasItem(objBox As ListBox, strFlies As String) As Boolean<br/> <br/> '检查路径是否已经存在<br/> HasItem = False<br/> <br/> Dim i As Integer<br/> If objBox.ListCount > 0 Then<br/> For i = 0 To objBox.ListCount - 1<br/> If StrComp(objBox.List(i), strFlies, vbTextCompare) = 0 Then<br/> HasItem = True<br/> Exit Function<br/> End If<br/> Next i<br/> End If<br/>End Function</p><p>Private Function HasItem2(ByVal strPath As String) As Integer<br/> <br/> '检查路径是否已经存在<br/> HasItem2 = -1<br/> <br/> Dim i As Integer<br/> If cboPlotPath.ListCount > 0 Then<br/> For i = 0 To cboPlotPath.ListCount - 1<br/> If StrComp(cboPlotPath.List(i), strPath, vbTextCompare) = 0 Then<br/> HasItem2 = i<br/> Exit Function<br/> End If<br/> Next i<br/> End If<br/>End Function</p><p>'打开或激活文件<br/>Private Sub OpenFile(fileName As String)<br/> Dim dwgFile As AcadDocument<br/> Dim strFile As String<br/> For Each dwgFile In ThisDrawing.Application.Documents<br/> strFile = dwgFile.Path & "\" & dwgFile.name<br/> '若第i个图形文件已经被打开，则将其激活<br/> If strFile = fileName Then<br/> '若dwgFile尚未激活，则将其激活<br/> If dwgFile.Active = False Then<br/> ThisDrawing.Application.ActiveDocument = dwgFile<br/> End If<br/> Exit Sub<br/> End If<br/> Next<br/> '若第i个图形文件尚未被打开，则将其打开<br/> ThisDrawing.Application.Documents.Open fileName<br/> <br/>End Sub</p><p>' 显示AutoCAD中当前可用的打印机列表<br/>Public Sub ListPlotDeviceNames()<br/> '取得当前布局对象<br/> Set objLayout = ThisDrawing.ActiveLayout<br/> '取得当前打印机配置信息<br/> objPlotConfiguration.ConfigName = objLayout.ConfigName<br/> '刷新这个工作任务当前的打印信息<br/> objPlotConfiguration.RefreshPlotDeviceInfo<br/> '列出系统上所有有效的设备名称<br/> Dim plotDevices As Variant<br/> plotDevices = objPlotConfiguration.GetPlotDeviceNames<br/> '删除以前的打印机列表<br/> cboPrintersName.Clear<br/> '显示打印机列表<br/> Dim i As Integer<br/> For i = 0 To UBound(plotDevices)<br/> cboPrintersName.AddItem (plotDevices(i))<br/> '设置默认的显示项目<br/> If objPlotConfiguration.ConfigName = plotDevices(i) Then cboPrintersName.ListIndex = i<br/> Next i<br/> '设置组合框初始选项<br/> With cboPrintersName<br/> '使用下拉列表的形式<br/> .Style = fmStyleDropDownList<br/> '设置默认的显示项目<br/> If .ListIndex = -1 Then .ListIndex = 0<br/> End With<br/> <br/>End Sub</p><p>' 显示AutoCAD中当前可用的图纸尺寸<br/>Public Sub ListPaperSize()<br/> '取得当前布局对象<br/> Set objLayout = ThisDrawing.ActiveLayout<br/> If cboPrintersName.Text = objLayout.ConfigName Then<br/> '取得当用图纸尺寸<br/> objPlotConfiguration.CanonicalMediaName = objLayout.CanonicalMediaName<br/> End If<br/> '刷新打印设备信息<br/> objPlotConfiguration.RefreshPlotDeviceInfo<br/> '列出所有介质的名称以及它们的本地版本<br/> paperSizes = objPlotConfiguration.GetCanonicalMediaNames<br/> '删除以前的图纸尺寸列表<br/> cboPaperSize.Clear<br/> '显示图纸尺寸列表<br/> Dim i As Integer<br/> For i = 0 To UBound(paperSizes)<br/> cboPaperSize.AddItem objPlotConfiguration.GetLocaleMediaName(paperSizes(i))<br/> '设置默认的显示项目<br/> If objPlotConfiguration.CanonicalMediaName = paperSizes(i) Then cboPaperSize.ListIndex = i<br/> Next i<br/> <br/> '设置组合框初始选项<br/> With cboPaperSize<br/> '使用下拉列表的形式<br/> .Style = fmStyleDropDownList<br/> '设置默认的显示项目<br/> If .ListIndex = -1 Then .ListIndex = 0<br/> End With<br/> <br/>End Sub</p><p>' 显示AutoCAD中当前可用的打印样式<br/>Public Sub ListPlotStyleTableNames()<br/> '取得当前布局对象<br/> Set objLayout = ThisDrawing.ActiveLayout<br/> '取得当前打印样式<br/> objPlotConfiguration.StyleSheet = objLayout.StyleSheet<br/> '刷新打印设备信息<br/> objPlotConfiguration.RefreshPlotDeviceInfo<br/> ' 获得所有的可用打印样式<br/> Dim plotStyleTables As Variant<br/> plotStyleTables = objPlotConfiguration.GetPlotStyleTableNames<br/> <br/> ' 删除以前的打印样式列表<br/> cboPlotStyleTableNames.Clear<br/> ' 添加打印样式列表<br/> Dim i As Integer<br/> Dim str As String<br/> For i = 0 To UBound(plotStyleTables)<br/> str = plotStyleTables(i)<br/> Call AddSorted(cboPlotStyleTableNames, str)<br/> Next i<br/> <br/> '设置默认的显示项目<br/> For i = 0 To UBound(plotStyleTables)<br/> str = plotStyleTables(i)<br/> If cboPlotStyleTableNames.List(i) = objPlotConfiguration.StyleSheet Then<br/> cboPlotStyleTableNames.ListIndex = i<br/> Exit For<br/> End If<br/> Next i<br/> <br/> ' 设置组合框初始选项<br/> With cboPlotStyleTableNames<br/> '使用下拉列表的形式<br/> .Style = fmStyleDropDownList<br/> '设置默认的显示项目<br/> If .ListIndex = -1 Then .ListIndex = 0<br/> End With<br/> <br/>End Sub</p><p>' 显示AutoCAD中可以使用的打印比例<br/>Public Sub ListPlotScale()<br/> Dim i As Integer<br/> '定义图纸尺寸数组<br/> Dim P, Nu, De, Q1, Q2<br/> '定义图纸尺寸数组<br/> P = Array("自定义", "按图纸空间缩放", "1:1", "1:2", "1:4", "1:8", "1:10", "1:16", "1:20", "1:30", _<br/> "1:40", "1:50", "1:100", "2:1", "4:1", "8:1", "10:1", "100:1", "1/128""= 1'", "1/64""= 1'", _<br/> "1/32""= 1'", "1/16""= 1'", "3/32""= 1'", "1/8""= 1'", "3/16""= 1'", "1/4""= 1'", "3/8""= 1'", _<br/> "1/2""= 1'", "3/4""= 1'", "1""= 1'", "3""= 1'", "6""= 1'", "1'= 1'")<br/> '定义分子数组<br/> Nu = Array(" ", "", "1", "1", "1", "1", "1", "1", "1", "1", _<br/> "1", "1", "1", "1", "1", "1", "1", "1", "1", "1", _<br/> "1", "1", "1", "1", "1", "1", "1", "1", "1", "1", _<br/> "1", "1", "1")<br/> '定义分母数组<br/> De = Array(" ", "", "1", "2", "4", "8", "10", "16", "20", "30", _<br/> "40", "50", "100", "0.5", "0.25", "0.125", "0.1", "0.01", "1536", "768", _<br/> "384", "192", "128", "96", "64", "48", "32", "24", "16", "12", _<br/> "4", "2", "1")<br/> '定义组合框索引到打印比例枚举值的映射<br/> Q1 = Array(100, 0, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, _<br/> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15)<br/> '定义打印比例枚举值到组合框索引的映射<br/> Q2 = Array(1, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, _<br/> 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 100)<br/> <br/> '取得当前布局对象<br/> Set objLayout = ThisDrawing.ActiveLayout<br/> '取得当前打印比例<br/> objPlotConfiguration.UseStandardScale = objLayout.UseStandardScale<br/> ' 显示打印比例列表<br/> With cboPlotScale<br/> ' 清空打印比例列表<br/> .Clear<br/> For i = 0 To 32<br/> .AddItem P(i), i<br/> Next<br/> '使用下拉列表的形式<br/> .Style = fmStyleDropDownList<br/> '设置默认的显示项目<br/> If Not objPlotConfiguration.UseStandardScale Then<br/> '使用自定义比例<br/> .ListIndex = 0<br/> objLayout.GetCustomScale Numerator, Denominator<br/> objPlotConfiguration.SetCustomScale Numerator, Denominator<br/> '设置文本框文本<br/> txtNumerator.Text = Numerator<br/> txtDenominator.Text = Denominator<br/> Else<br/> '使用标准比例<br/> objPlotConfiguration.StandardScale = objLayout.StandardScale<br/> .ListIndex = Q2(objPlotConfiguration.StandardScale)<br/> If .ListIndex > 1 Then<br/> Numerator = Nu(cboPlotScale.ListIndex)<br/> Denominator = De(cboPlotScale.ListIndex)<br/> '设置文本框文本<br/> txtNumerator.Text = Numerator<br/> txtDenominator.Text = Denominator<br/> Else<br/> '计算缩放比例<br/> Call SetScaleToFit<br/> End If<br/> End If<br/> End With<br/> <br/>End Sub</p><p>Public Sub SetScaleToFit()<br/> Dim PaperWidth As Double, PaperHeight As Double, t As Double<br/> Dim PlotWidth As Double, PlotHeight As Double<br/> Dim WindowWidth As Double, WindowHeight As Double<br/> Dim MarginLowerLeft As Variant, MarginUpperRight As Variant<br/> Dim WindowLowerLeft As Variant, WindowUpperRight As Variant<br/> '刷新打印设备信息<br/> objPlotConfiguration.RefreshPlotDeviceInfo<br/> '取得图纸尺寸信息<br/> objPlotConfiguration.GetPaperSize PaperWidth, PaperHeight<br/> '取得图纸边界信息<br/> objPlotConfiguration.GetPaperMargins MarginLowerLeft, MarginUpperRight<br/> '计算打印区域<br/> PlotWidth = PaperWidth - (MarginUpperRight(0) + MarginLowerLeft(0))<br/> PlotHeight = PaperHeight - (MarginUpperRight(1) + MarginLowerLeft(1))<br/> '根据选择的图形方向调换宽高<br/> If optVertical.Value Then<br/> '图形方向为“纵向”时宽小于高<br/> If PlotWidth > PlotHeight Then<br/> t = PlotWidth<br/> PlotWidth = PlotHeight<br/> PlotHeight = t<br/> End If<br/> Else<br/> '图形方向为“横向”时宽大于高<br/> If PlotWidth < PlotHeight Then<br/> t = PlotWidth<br/> PlotWidth = PlotHeight<br/> PlotHeight = t<br/> End If<br/> End If<br/> '获得打印窗口<br/> objPlotConfiguration.GetWindowToPlot WindowLowerLeft, WindowUpperRight<br/> WindowWidth = WindowUpperRight(0) - WindowLowerLeft(0)<br/> WindowHeight = WindowUpperRight(1) - WindowLowerLeft(1)<br/> '计算所需比例<br/> Dim ScaleX As Double, ScaleY As Double<br/> ScaleX = WindowWidth / PlotWidth<br/> ScaleY = WindowHeight / PlotHeight<br/> Numerator = 1<br/> Denominator = IIf(ScaleX > ScaleY, ScaleX, ScaleY)<br/> Dim d As Double<br/> '单位由“毫米”转换为“英寸”<br/> d = IIf(optMillimeters.Value, Denominator, Denominator * 25.4)<br/> '设置文本框文本<br/> txtNumerator.Text = Numerator<br/> txtDenominator.Text = Format(d, "#########0.###")<br/> <br/>End Sub</p><p>' 显示AutoCAD中当前可用的图层<br/>Public Sub ListLayer()<br/> Dim LayerList As Collection<br/> '获得图形中存在的图层列表<br/> Set LayerList = GetLayerList()<br/> <br/> '刷新图层列表<br/> Call RefreshList(cboLayerName, LayerList)<br/> <br/> '选择图层列表中的第一个实体<br/> If cboLayerName.ListIndex = -1 Then<br/> cboLayerName.ListIndex = 0<br/> End If<br/> <br/>End Sub</p><p>'获得图形中存在的图层列表<br/>Private Function GetLayerList() As Collection<br/> Dim objLayer As AcadLayer<br/> Dim LayerList As New Collection<br/> <br/> Set objDoc = ThisDrawing.Application.ActiveDocument<br/> '获得可用的图层<br/> For Each objLayer In objDoc.Layers<br/> LayerList.Add objLayer.name, objLayer.name<br/> Next<br/> <br/> '返回图形中块参照的列表<br/> Set GetLayerList = LayerList<br/> <br/>End Function</p><p>' 显示AutoCAD中当前可用的图块<br/>Public Sub ListBlock()<br/> Dim BlockReferenceList As Collection<br/> '获得图形中存在的块参照列表<br/> Set BlockReferenceList = GetBlockReferences()<br/> <br/> '判断是否存在块参照<br/> If BlockReferenceList Is Nothing Then<br/> MsgBox "当前图形中不存在任何的块！", vbExclamation<br/> Exit Sub<br/> End If<br/> <br/> '刷新块参照列表<br/> Call RefreshList(cboBlockName, BlockReferenceList)<br/> <br/> '选择块参照列表中的第一个实体<br/> If cboBlockName.ListIndex = -1 Then<br/> cboBlockName.ListIndex = 0<br/> End If<br/> <br/>End Sub</p><p>'获得图形中存在的块参照列表<br/>Private Function GetBlockReferences() As Collection<br/> Dim BlockList As New Collection<br/> Dim AcadObject As AcadEntity<br/> <br/> Set objDoc = ThisDrawing.Application.ActiveDocument<br/> '获得可用的块参照<br/> For Each AcadObject In objDoc.ModelSpace<br/> If AcadObject.ObjectName = "AcDbBlockReference" Then<br/> '不将模型空间、图纸空间和匿名块添加到组合框中<br/> If StrComp(Left(AcadObject.name, 1), "*") <> 0 Then<br/> On Error Resume Next<br/> BlockList.Add AcadObject.name, AcadObject.name<br/> End If<br/> End If<br/> Next<br/> <br/> '返回图形中块参照的列表<br/> If BlockList.count > 0 Then<br/> Set GetBlockReferences = BlockList<br/> Else<br/> Set GetBlockReferences = Nothing<br/> End If<br/>End Function</p><p>'将组合对象中的元素写入列表框或组合框中<br/>Private Sub RefreshList(ByRef ListObject As Object, ByRef BlockList As Collection)<br/> Dim i As Long<br/> '清空列表框<br/> ListObject.Clear<br/> '向列表框中添加新的元素<br/> For i = 1 To BlockList.count<br/> AddSorted ListObject, BlockList(i)<br/> Next<br/> <br/>End Sub</p><p>Private Sub AddSorted(ListObject As Object, SItem As String)<br/> '将元素添加到组合框或列表框中，并且排序<br/> Dim i As Long<br/> <br/> '元素数目小于1，不进行排序<br/> If ListObject.ListCount = 0 Then<br/> ListObject.AddItem SItem<br/> Exit Sub<br/> End If<br/> <br/> '通过比较确定该元素的位置，类似于插入排序法<br/> For i = 0 To (ListObject.ListCount - 1)<br/> If StrComp(ListObject.List(i), SItem, vbTextCompare) = 1 Then<br/> ListObject.AddItem SItem, i<br/> Exit Sub<br/> End If<br/> Next<br/> <br/> '添加到列表框的最后<br/> ListObject.AddItem SItem</p><p>End Sub</p><p>Public Sub PaperRotationChange()<br/> ' 设置图纸打印方向<br/> If optVertical.Value = True Then<br/> If chkReverse.Value = False Then<br/> objPlotConfiguration.PlotRotation = ac0degrees<br/> Else<br/> objPlotConfiguration.PlotRotation = ac180degrees<br/> End If<br/> Else<br/> If chkReverse.Value = False Then<br/> objPlotConfiguration.PlotRotation = ac90degrees<br/> Else<br/> objPlotConfiguration.PlotRotation = ac270degrees<br/> End If<br/> End If<br/> ' 显示图纸大小<br/> Call SetPlotZone<br/>End Sub</p><p>' 设置图纸可打印区域大小<br/>Public Sub SetPlotZone()<br/> Dim PaperWidth As Double, PaperHeight As Double, t As Double<br/> Dim PlotWidth As Double, PlotHeight As Double<br/> Dim MarginLowerLeft As Variant, MarginUpperRight As Variant<br/> '刷新打印设备信息<br/> objPlotConfiguration.RefreshPlotDeviceInfo<br/> <br/> '取得图纸尺寸信息<br/> objPlotConfiguration.GetPaperSize PaperWidth, PaperHeight<br/> '取得图纸边界信息<br/> objPlotConfiguration.GetPaperMargins MarginLowerLeft, MarginUpperRight<br/> '计算打印区域<br/> PlotWidth = PaperWidth - (MarginUpperRight(0) + MarginLowerLeft(0))<br/> PlotHeight = PaperHeight - (MarginUpperRight(1) + MarginLowerLeft(1))<br/> '根据选择的图形方向调换宽高<br/> If optVertical.Value Then<br/> '图形方向为“纵向”时宽小于高<br/> If PlotWidth > PlotHeight Then<br/> t = PlotWidth<br/> PlotWidth = PlotHeight<br/> PlotHeight = t<br/> End If<br/> Else<br/> '图形方向为“横向”时宽大于高<br/> If PlotWidth < PlotHeight Then<br/> t = PlotWidth<br/> PlotWidth = PlotHeight<br/> PlotHeight = t<br/> End If<br/> End If<br/> <br/> '单位由“毫米”转换为“英寸”<br/> If optMillimeters.Value = False Then<br/> PlotWidth = PlotWidth / 25.4<br/> PlotHeight = PlotHeight / 25.4<br/> End If<br/> ' 显示图纸大小<br/> lbPaperSize.Caption = Format(PlotWidth, "#########0.00") & " × " & Format(PlotHeight, "#########0.00")<br/> <br/>End Sub</p><p>Private Sub OutputData(objBox As ComboBox, nFile As Integer)<br/> Dim i As Integer, count As Integer, index As Integer<br/> '获得组合框列表数目<br/> count = objBox.ListCount<br/> '获得组合框当前选项的的索引号<br/> index = objBox.ListIndex<br/> '输出组合框列表数目<br/> Write #nFile, count<br/> '输出组合框当前选项的的索引号<br/> Write #nFile, index<br/> '输出所有的组合框选项<br/> For i = 0 To count - 1<br/> Print #nFile, objBox.List(i)<br/> Next<br/> <br/>End Sub</p><p>Private Sub OutputData2(objBox As CheckBox, nFile As Integer)<br/> Dim strTemp As String<br/> '输出复选框选中状态<br/> If objBox.Value = True Then<br/> strTemp = "是"<br/> Else<br/> strTemp = "否"<br/> End If<br/> Print #nFile, strTemp<br/>End Sub</p><p>Private Sub OutputData3(objBox As ListBox, nFile As Integer)<br/> Dim i As Integer, count As Integer, index As Integer<br/> '获得列表框列表数目<br/> count = objBox.ListCount<br/> '获得列表框当前选项的的索引号<br/> index = objBox.ListIndex<br/> '输出列表框列表数目<br/> Write #nFile, count<br/> '输出列表框当前选项的的索引号<br/> Write #nFile, index<br/> '输出所有的列表框选项<br/> For i = 0 To count - 1<br/> Print #nFile, objBox.List(i)<br/> Next<br/> <br/>End Sub</p><p>Private Sub InputData(objBox As ComboBox, nFile As Integer)<br/> Dim i As Integer, count As Integer, index As Integer<br/> Dim strTemp As String<br/> '读入一行文本并存储在变量中<br/> Line Input #nFile, strTemp<br/> '读入组合框列表数目<br/> Input #nFile, count<br/> '读入组合框当前元素的的索引号<br/> Input #nFile, index<br/> '清空组合框所有元素<br/> objBox.Clear<br/> '读入组合框元素<br/> For i = 0 To count - 1<br/> Line Input #nFile, strTemp<br/> '将读入的列表添加到组合框中<br/> objBox.AddItem strTemp<br/> Next<br/> ' 设置组合框初始选项<br/> With objBox<br/> '使用下拉列表的形式<br/> .Style = fmStyleDropDownList<br/> '设置下拉列表的下标下限<br/> .BoundColumn = 0<br/> '设置默认的显示项目<br/> .ListIndex = index<br/> End With<br/> <br/>End Sub</p><p>Private Sub InputData2(objBox As CheckBox, nFile As Integer)<br/> Dim strTemp As String<br/> '读入一行文本并存储在变量中<br/> Line Input #nFile, strTemp<br/> '读入复选框选中状态<br/> Input #nFile, strTemp<br/> '设置复选按钮选择状态<br/> If strTemp = "是" Then<br/> objBox.Value = True<br/> Else<br/> objBox.Value = False<br/> End If<br/>End Sub</p><p>Private Sub InputData3(objBox As ListBox, nFile As Integer)<br/> Dim i As Integer, count As Integer, index As Integer<br/> Dim strTemp As String<br/> '读入一行文本并存储在变量中<br/> Line Input #nFile, strTemp<br/> '读入列表框列表数目<br/> Input #nFile, count<br/> '读入列表框当前元素的的索引号<br/> Input #nFile, index<br/> '清空列表框所有元素<br/> objBox.Clear<br/> '读入列表框元素<br/> For i = 0 To count - 1<br/> Line Input #nFile, strTemp<br/> '将读入的列表添加到列表框中<br/> objBox.AddItem strTemp<br/> Next<br/> ' 设置组合框初始选项<br/> With objBox<br/> '设置下拉列表的下标下限<br/> .BoundColumn = 0<br/> '设置默认的显示项目<br/> .ListIndex = index<br/> End With<br/> <br/>End Sub</p><p>Private Sub SetSelected(ListObject As Object, SItem As String)<br/> '将该元素在组合框中置为当前<br/> Dim i As Long<br/> <br/> '通过比较确定该元素的位置<br/> For i = 0 To (ListObject.ListCount - 1)<br/> If StrComp(ListObject.List(i), SItem, vbTextCompare) = 0 Then<br/> ListObject.ListIndex = i<br/> Exit Sub<br/> End If<br/> Next</p><p>End Sub</p><p>'使用选择集获得对象集合(按图层)<br/>Public Sub SelectByLayer(strLayerName As String, ByRef SSet As AcadSelectionSet)<br/> On Error Resume Next<br/> Dim strSSetName As String<br/> strSSetName = "打印区域选择集"<br/> ' 安全创建选择集<br/> If Not IsNull(ThisDrawing.SelectionSets.Item(strSSetName)) Then<br/> Set SSet = ThisDrawing.SelectionSets.Item(strSSetName)<br/> SSet.Delete<br/> End If<br/> Set SSet = ThisDrawing.SelectionSets.Add(strSSetName)<br/> ' 选择集过滤器<br/> Dim fType As Variant, fData As Variant<br/> ' 用CreateSSetFilter函数改进的过滤器<br/> Call CreateSSetFilter(fType, fData, 0, "LWPOLYLINE", 8, strLayerName)<br/> '选择指定图层的多段线<br/> SSet.Select acSelectionSetAll, , , fType, fData<br/> <br/>End Sub</p><p>'使用选择集获得对象集合(按块参照)<br/>Public Sub SelectByBlock(strBlockName As String, ByRef SSet As AcadSelectionSet)<br/> On Error Resume Next<br/> Dim strSSetName As String<br/> strSSetName = "打印区域选择集"<br/> ' 安全创建选择集<br/> If Not IsNull(ThisDrawing.SelectionSets.Item(strSSetName)) Then<br/> Set SSet = ThisDrawing.SelectionSets.Item(strSSetName)<br/> SSet.Delete<br/> End If<br/> Set SSet = ThisDrawing.SelectionSets.Add(strSSetName)<br/> ' 选择集过滤器<br/> Dim fType As Variant, fData As Variant<br/> ' 用CreateSSetFilter函数改进的过滤器<br/> Call CreateSSetFilter(fType, fData, 0, "INSERT", 2, strBlockName)<br/> '选择指定图层的多段线<br/> SSet.Select acSelectionSetAll, , , fType, fData<br/> <br/>End Sub</p><p>' 创建选择集过滤器<br/>Public Sub CreateSSetFilter(ByRef filterType As Variant, ByRef filterData As Variant, ParamArray filter())<br/> If UBound(filter) Mod 2 = 0 Then<br/> MsgBox "filter参数无效！"<br/> Exit Sub<br/> End If<br/> <br/> ' 过滤器规则<br/> Dim fType() As Integer<br/> ' 过滤器参数<br/> Dim fData() As Variant<br/> Dim count As Integer<br/> count = (UBound(filter) + 1) / 2<br/> ReDim fType(count - 1)<br/> ReDim fData(count - 1)<br/> <br/> Dim i As Integer<br/> For i = 0 To count - 1<br/> fType(i) = filter(2 * i)<br/> fData(i) = filter(2 * i + 1)<br/> Next i<br/> <br/> filterType = fType<br/> filterData = fData<br/>End Sub</p><p>'按坐标对图框排序(上下，左右：x坐标从小到大,y坐标从大到小)<br/>Public Function SortN(ByRef objCollection() As AcadEntity)</p><p>'选择集为空时退出函数<br/>If UBound(objCollection) = 0 Then<br/> Exit Function<br/>End If</p><p>Dim ent As AcadEntity<br/>Dim i As Integer, j As Integer<br/>Dim ptiMin As Variant, ptiMax As Variant<br/>Dim ptjMin As Variant, ptjMax As Variant</p><p>'容许误差<br/>Dim NumError As Double<br/>NumError = 0</p><p>'按x坐标排序<br/>For i = 0 To UBound(objCollection)<br/> For j = i + 1 To UBound(objCollection)<br/> '获得每个对象最小包围框的两个角点<br/> objCollection(i).GetBoundingBox ptiMin, ptiMax<br/> objCollection(j).GetBoundingBox ptjMin, ptjMax<br/> '将三维点转化为二维点坐标<br/> ReDim Preserve ptiMin(0 To 1)<br/> ReDim Preserve ptjMin(0 To 1)<br/> <br/> If ptiMin(0) - ptjMin(0) > NumError Then<br/> Set ent = objCollection(i)<br/> Set objCollection(i) = objCollection(j)<br/> Set objCollection(j) = ent<br/> End If<br/> Next j<br/>Next i</p><p>'对x坐标相等的进行y坐标排序<br/>For i = 0 To UBound(objCollection)<br/> For j = 0 To UBound(objCollection)<br/> '获得每个对象最小包围框的两个角点<br/> objCollection(i).GetBoundingBox ptiMin, ptiMax<br/> objCollection(j).GetBoundingBox ptjMin, ptjMax<br/> '将三维点转化为二维点坐标<br/> ReDim Preserve ptiMin(0 To 1)<br/> ReDim Preserve ptjMin(0 To 1)</p><p> If ptiMin(0) = ptjMin(0) Then<br/> If ptiMin(1) - ptjMin(1) > NumError Then<br/> Set ent = objCollection(i)<br/> Set objCollection(i) = objCollection(j)<br/> Set objCollection(j) = ent<br/> End If<br/> End If<br/> Next j<br/>Next i</p><p>End Function</p><p>'按坐标对图框排序(左右，上下：y坐标从大到小,x坐标从小到大)<br/>Public Function SortZ(ByRef objCollection() As AcadEntity)</p><p>'选择集为空时退出函数<br/>If UBound(objCollection) = 0 Then<br/> Exit Function<br/>End If</p><p>Dim ent As AcadEntity<br/>Dim i As Integer, j As Integer<br/>Dim ptiMin As Variant, ptiMax As Variant<br/>Dim ptjMin As Variant, ptjMax As Variant</p><p>'容许误差<br/>Dim NumError As Double<br/>NumError = 0</p><p>'按y坐标排序<br/>For i = 0 To UBound(objCollection)<br/> For j = i + 1 To UBound(objCollection)<br/> '获得每个对象最小包围框的两个角点<br/> objCollection(i).GetBoundingBox ptiMin, ptiMax<br/> objCollection(j).GetBoundingBox ptjMin, ptjMax<br/> '将三维点转化为二维点坐标<br/> ReDim Preserve ptiMin(0 To 1)<br/> ReDim Preserve ptjMin(0 To 1)<br/> <br/> If ptiMin(1) - ptjMin(1) < NumError Then<br/> Set ent = objCollection(i)<br/> Set objCollection(i) = objCollection(j)<br/> Set objCollection(j) = ent<br/> End If<br/> Next j<br/>Next i</p><p>'对y坐标相等的进行x坐标排序<br/>For i = 0 To UBound(objCollection)<br/> For j = 0 To UBound(objCollection)<br/> '获得每个对象最小包围框的两个角点<br/> objCollection(i).GetBoundingBox ptiMin, ptiMax<br/> objCollection(j).GetBoundingBox ptjMin, ptjMax<br/> '将三维点转化为二维点坐标<br/> ReDim Preserve ptiMin(0 To 1)<br/> ReDim Preserve ptjMin(0 To 1)</p><p> If ptiMin(1) = ptjMin(1) Then<br/> If ptiMin(0) - ptjMin(0) < NumError Then<br/> Set ent = objCollection(i)<br/> Set objCollection(i) = objCollection(j)<br/> Set objCollection(j) = ent<br/> End If<br/> End If<br/> Next j<br/>Next i</p><p>End Function</p>
页:
1
2
3
4
5
[6]
7
8
9
10
11
12
13