cad打印代码

Option Explicit '图形集合

Private colDwgs As New Collection '文档对象

Private objDoc As AcadDocument '布局对象

Private objLayout As AcadLayout '打印配置集合

Private objPlotConfigurations As AcadPlotConfigurations '打印配置

Private objPlotConfiguration As AcadPlotConfiguration Private objOriginalPC As AcadPlotConfiguration '打印对象

Private objPlot As AcadPlot '图纸尺寸名称数组

Private paperSizes As Variant

Private Numerator As Double, Denominator As Double Private OffsetX As Double, OffsetY As Double Private ms As Boolean

Private Type BrowseInfo hOwner As Long pidlRoot As Long

pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type

Private Const MAX_PATH = 260 '代表ESC键

Private Const VK_ESCAPE = &H1B

'API函数的声明

Private Declare Function SHBrowseForFolder Lib \

Alias \

Private Declare Function FindWindow Lib \Alias \(ByVal lpClassName As String, _

ByVal lpWindowName As String) As Long

Private Declare Function SHGetPathFromIDList Lib \Alias \

pidl As Long, ByVal pszPath As String) As Long

Private Declare Function GetAsyncKeyState Lib \(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 <> \ ' 设置图纸尺寸 objPlotConfiguration.CanonicalMediaName = paperSizes(cboPaperSize.ListIndex) ' 显示图纸尺寸 Call SetPlotZone

' 当居中打印时重新计算打印偏移

If chkCenterPlot.Value Then Call SetOffset End If End Sub

Private Sub cboPlotScale_Click() '定义图纸尺寸数组 Dim Nu, De '定义分子数组

Nu = Array(\ \ \ \ '定义分母数组

De = Array(\

\_

\ \

'设置默认的显示项目

If cboPlotScale.ListIndex = 0 Then '使用自定义比例 Numerator = 1 Denominator = 1

txtNumerator.Text = Numerator

txtDenominator.Text = Denominator Else

If cboPlotScale.ListIndex > 1 Then

Numerator = Nu(cboPlotScale.ListIndex) Denominator = De(cboPlotScale.ListIndex) txtNumerator.Text = Numerator

txtDenominator.Text = Denominator Else

'计算缩放比例

Call SetScaleToFit End If End If Dim Q1

'定义组合框索引到打印比例枚举值的映射

Q1 = Array(100, 0, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, _

1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15) ' 设置图纸打印比例

If cboPlotScale.ListIndex <> 0 Then '使用标准打印比例

objPlotConfiguration.UseStandardScale = True '设置标准打印比例

objPlotConfiguration.StandardScale = Q1(cboPlotScale.ListIndex) Else

'使用自定义打印比例

objPlotConfiguration.UseStandardScale = False '设置自定义打印比例

objPlotConfiguration.SetCustomScale Numerator, Denominator End If

' 当居中打印时重新计算打印偏移

If chkCenterPlot.Value Then Call SetOffset

End Sub

Private Sub cboPlotStyleTableNames_Change() ' 设置打印样式表

objPlotConfiguration.StyleSheet = cboPlotStyleTableNames.Text

End Sub

Private Sub cboPrintersName_Click() '设置打印机配置

objPlotConfiguration.ConfigName = cboPrintersName.Text '更新显示AutoCAD中当前可用的所有图纸尺寸 Call ListPaperSize End Sub

Private Sub chkCenterPlot_Click() On Error Resume Next

If chkCenterPlot.Value Then ' 设置图纸是否居中打印

objPlotConfiguration.CenterPlot = True '计算打印偏移 Call SetOffset Else

' 设置图纸是否居中打印

objPlotConfiguration.CenterPlot = False OffsetX = 0 OffsetY = 0 '设置文本框文本

txtOffsetX.Text = \ txtOffsetY.Text = \ End If

End Sub

Public Sub SetOffset()

'On Error Resume Next

Dim PaperWidth As Double, PaperHeight As Double, t As Double Dim PlotWidth As Double, PlotHeight As Double

Dim WindowWidth As Double, WindowHeight As Double

Dim MarginLowerLeft As Variant, MarginUpperRight As Variant Dim WindowLowerLeft As Variant, WindowUpperRight As Variant '刷新打印设备信息

objPlotConfiguration.RefreshPlotDeviceInfo '取得图纸尺寸信息

objPlotConfiguration.GetPaperSize PaperWidth, PaperHeight '取得图纸边界信息 objPlotConfiguration.GetPaperMargins MarginLowerLeft, MarginUpperRight '计算打印区域

PlotWidth = PaperWidth - (MarginUpperRight(0) + MarginLowerLeft(0))

PlotHeight = PaperHeight - (MarginUpperRight(1) + MarginLowerLeft(1)) '根据选择的图形方向调换宽高 If optVertical.Value Then

'图形方向为“纵向”时宽小于高

If PlotWidth > PlotHeight Then t = PlotWidth

PlotWidth = PlotHeight PlotHeight = t End If Else

'图形方向为“横向”时宽大于高

If PlotWidth < PlotHeight Then t = PlotWidth

PlotWidth = PlotHeight PlotHeight = t End If End If

'单位由“英寸”转换为“毫米”的比例因子 Dim scaleUnit As Double

scaleUnit = IIf(optMillimeters.Value, 1, 25.4) '获得打印窗口尺寸 objPlotConfiguration.GetWindowToPlot WindowLowerLeft, WindowUpperRight

WindowWidth = WindowUpperRight(0) - WindowLowerLeft(0) WindowHeight = WindowUpperRight(1) - WindowLowerLeft(1) '获得缩放后的打印窗口尺寸

WindowWidth = WindowWidth * Numerator / Denominator * scaleUnit WindowHeight = WindowHeight * Numerator / Denominator * scaleUnit '计算打印偏移

OffsetX = (PlotWidth - WindowWidth) / 2 OffsetY = (PlotHeight - WindowHeight) / 2 Dim X As Double, Y As Double '单位由“毫米”转换为“英寸”

X = IIf(optMillimeters.Value, OffsetX, OffsetX / 25.4) Y = IIf(optMillimeters.Value, OffsetY, OffsetY / 25.4) '设置文本框文本

txtOffsetX.Text = Format(X, \ txtOffsetY.Text = Format(Y, \

End Sub

Private Sub chkOnlyPlotThis_Change() '设置“打印到文件”组各控件激活状态

If chkOnlyPlotThis.Value Then '清除列表框中所有元素 lstPlotFiles.Clear '获得当前图形名

Dim strTemp As String

strTemp = ThisDrawing.Application.ActiveDocument.Path & \& ThisDrawing.Application.ActiveDocument.name '向列表框添加当前图形

lstPlotFiles.AddItem strTemp cmdBrowse.Enabled = False cmdAdd.Enabled = False cmdAddAll.Enabled = False cmdClear.Enabled = False cmdClearAll.Enabled = False lstCurFiles.Enabled = False lstPlotFiles.Enabled = False Else

cmdBrowse.Enabled = True cmdAdd.Enabled = True cmdAddAll.Enabled = True cmdClear.Enabled = True cmdClearAll.Enabled = True lstCurFiles.Enabled = True lstPlotFiles.Enabled = True End If

End Sub

Private Sub chkPlotHidden_Change() '设置是否隐藏图纸空间对象

If Not objPlotConfiguration.ModelType Then _

objPlotConfiguration.PlotHidden = chkPlotHidden.Value End Sub

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

lbPlotPath.Enabled = False cboPlotPath.Enabled = False cmdBrowse2.Enabled = False

End If End Sub

Private Sub chkPlotWithLineweights_Change() '设置是否打印对象线宽

If Not chkPlotWithPlotStyles.Value Then _ objPlotConfiguration.PlotWithLineweights = chkPlotWithLineweights.Value End Sub

Private Sub chkPlotWithPlotStyles_Change() '设置是否应用打印样式

objPlotConfiguration.PlotWithPlotStyles = chkPlotWithPlotStyles.Value chkPlotWithLineweights.Enabled = Not (chkPlotWithPlotStyles.Value) End Sub

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

Call PaperRotationChange End Sub

Private Sub cmdAdd_Click() '如果列表框中未存在任何元素

If lstCurFiles.ListCount = 0 Then

MsgBox \请先向列表框中添加文件！\ 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 \请选择要从列表中添加的元素！\ Exit Sub End If End Sub

Private Sub cmdAddAll_Click() '如果列表框中未存在任何元素

If lstCurFiles.ListCount = 0 Then

MsgBox \请先向列表框中添加文件！\ 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 <> \

'若组合框中未存在返回文件夹路径，则将其添加到组合框中 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 \请先向列表框中添加文件！\ 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 \请选择要从列表中清除的元素！\ 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 \请先向列表框中添加文件！\ Exit Sub End If

Dim Msg, Style, Title, Help, Ctxt, Response, MyString Msg = \清除整个图形列表?\

Style = vbOKCancel + vbQuestion + vbDefaultButton2 Title = \

Response = MsgBox(Msg, Style, Title) If Response = vbOK Then txtCurPath.Text = \ '清除列表框中所有元素 lstPlotFiles.Clear End If

End Sub

Private Sub cmdExit_Click() '退出 End End Sub

Private Sub cmdInput_Click() '导入打印设置 '设置标准对话框 With comDlg

'设置标准对话框标题

.DialogTitle = \导入打印设置\

'设置标准对话框类型列表中所显示的过滤器

.filter = \文本文件(*.txt)|*.txt|所有文件(*.*)|*.*\ '显示[打开]对话框 .ShowOpen End With

Dim strFileName As String

strFileName = comDlg.fileName '若返回文件名为空，不进行操作 If strFileName = \

MsgBox \请重新选择文件位置！\

Exit Sub End If

'读入文件的操作

Dim i As Integer, nFile As Integer Dim X As Double, Y As Double

Dim count As Integer, index As Integer Dim strTemp As String

'获得下一个可供Open语句使用的文件号 nFile = FreeFile '打开文件

Open strFileName For Input As #nFile

'读入当前路径

'读入一行文本并存储在变量中 Line Input #nFile, strTemp '读入当前路径并设置文本框文字 Input #nFile, strTemp

txtCurPath.Text = strTemp

'读入打印文件列表并添加到列表框中 Call InputData3(lstPlotFiles, nFile)

'读入是否仅打印当前图形并设置复选按钮选择状态 Call InputData2(chkOnlyPlotThis, nFile)

'读入打印机配置列表并添加到组合框中

Call InputData(cboPrintersName, nFile)

'读入打印样式表并添加到组合框中

Call InputData(cboPlotStyleTableNames, nFile)

'读入图纸尺寸列表并添加到组合框中 Call InputData(cboPaperSize, nFile)

'读入图纸单位并设置单选按钮选择状态 '读入一行文本并存储在变量中 Line Input #nFile, strTemp '读入图纸单位

Input #nFile, strTemp '设置单选按钮选择状态

If strTemp = \毫米\

optMillimeters.Value = True Else

optInches.Value = True End If

'读入图纸方向并设置单选按钮选择状态 '读入一行文本并存储在变量中 Line Input #nFile, strTemp '读入图纸方向

Input #nFile, strTemp '设置单选按钮选择状态

If strTemp = \纵向\ 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 = \图块\ optBlock.Value = True Else

optLayer.Value = True End If

'读入图块名列表并添加到组合框中

Call InputData(cboBlockName, nFile)

'读入图层名列表并添加到组合框中

Call InputData(cboLayerName, nFile)

'关闭文件 Close #nFile

End Sub

Private Sub cmdListPrints_Click()

' 显示AutoCAD中当前可用的打印机列表 Call ListPlotDeviceNames

End Sub

Private Sub cmdOutput_Click() '导出打印设置 '设置标准对话框 With comDlg

'设置标准对话框标题

.DialogTitle = \导出打印设置\

'设置标准对话框类型列表中所显示的过滤器

.filter = \文本文件(*.txt)|*.txt|所有文件(*.*)|*.*\ '设置[另存为]对话框的缺省扩展名 .DefaultExt = \ '显示[另存为]对话框 .ShowSave End With

Dim strFileName As String, strTemp As String strFileName = comDlg.fileName '若返回文件名为空，不进行操作 If strFileName = \

MsgBox \请重新选择保存位置！\ Exit Sub End If

'保存文件的操作 Dim i As Integer '打开文件

Open strFileName For Output As #1

'输出当前路径

Print #1, \当前路径：\ Print #1, txtCurPath.Text

'输出打印文件列表

Print #1, \打印文件列表：\ '输出打印机配置列表的信息

Call OutputData3(lstPlotFiles, 1)

'输出是否仅打印当前图形

Print #1, \是否仅打印当前图形\

Call OutputData2(chkOnlyPlotThis, 1)

'输出打印机配置

Print #1, \打印机配置：\

'输出打印机配置列表的信息

Call OutputData(cboPrintersName, 1)

'输出打印样式表

Print #1, \打印样式表：\ '输出打印样式表的信息

Call OutputData(cboPlotStyleTableNames, 1)

'输出图纸尺寸列表

Print #1, \图纸尺寸列表：\ '输出图纸尺寸列表的信息

Call OutputData(cboPaperSize, 1)

'输出图纸单位

Print #1, \图纸单位：\ '输出图纸单位信息

If optMillimeters.Value = True Then strTemp = \毫米\ Else

strTemp = \英寸\ End If

Print #1, strTemp

'输出图纸方向

Print #1, \图纸方向：\ '输出图纸方向信息

If optVertical.Value = True Then strTemp = \纵向\ Else

strTemp = \横向\ End If

Print #1, strTemp

'输出是否反向打印

Print #1, \是否反向打印：\

Call OutputData2(chkReverse, 1)

'输出打印份数

Print #1, \打印份数：\ Print #1, txtNumber.Text

'输出是否打印到文件

Print #1, \是否打印到文件：\ Call OutputData2(chkPlotToFile, 1)

'输出打印路径

Print #1, \打印路径：\ '输出打印路径列表的信息

Call OutputData(cboPlotPath, 1)

'输出打印比例

Print #1, \打印比例：\ '输出打印比例列表的信息

Call OutputData(cboPlotScale, 1)

'输出当前打印比例

Print #1, \当前打印比例：\ Print #1, txtNumerator.Text Print #1, txtDenominator.Text

'输出是否居中打印

Print #1, \是否居中打印：\

Call OutputData2(chkCenterPlot, 1)

'输出打印偏移

Print #1, \打印偏移：\ Print #1, txtOffsetX.Text Print #1, txtOffsetY.Text

'输出是否打印对象线宽

Print #1, \是否打印对象线宽：\

Call OutputData2(chkPlotWithLineweights, 1) '输出是否采用打印样式

Print #1, \是否采用打印样式：\

Call OutputData2(chkPlotWithPlotStyles, 1) '输出是否隐藏图纸空间对象

Print #1, \是否隐藏图纸空间对象：\ Call OutputData2(chkPlotHidden, 1)

'输出图框形式

Print #1, \图框形式：\ '输出图框形式信息

If optBlock.Value = True Then strTemp = \图块\ Else

strTemp = \图层\ End If

Print #1, strTemp

'输出图块名列表

Print #1, \图块名列表：\ '输出图块名列表的信息

Call OutputData(cboBlockName, 1)

'输出图层名列表

Print #1, \图块名列表：\ '输出图层名列表的信息

Call OutputData(cboLayerName, 1)

'关闭文件 Close 1

End Sub

Private Sub cmdPick_Click() On Error Resume Next

Dim objSelect As AcadEntity Dim ptPick As Variant Dim strTemp As String

Set objDoc = ThisDrawing.Application.ActiveDocument '将控制权交给AutoCAD frmBatchPlot.Hide

'在AutoCAD中选择实体并判断类型 Retry:

objDoc.Utility.GetEntity objSelect, ptPick, vbCrLf & \请选择实体：\ ' 处理按下Esc键的错误

If objSelect Is Nothing Then

If CheckKey(VK_ESCAPE) = True Then '显示对话框

frmBatchPlot.Show Exit Sub Else GoTo Retry End If End If

' 处理未选择到实体的错误 If Err <> 0 Then Err.Clear GoTo Retry End If

'若为指定图块

If optBlock.Value = True Then '判断实体是否块参照

If TypeOf objSelect Is AcadBlockReference Then '判断实体是否模型空间、图纸空间和匿名块

If StrComp(Left(objSelect.name, 1), \ '获得块参照名

strTemp = objSelect.name Else

MsgBox \您选择的是匿名块，请重新选择块参照！\ '显示对话框

frmBatchPlot.Show Exit Sub End If Else

MsgBox \您选择的不是块参照，请重新选择块参照！\ '显示对话框

frmBatchPlot.Show Exit Sub End If

'刷新块参照列表 Call ListBlock

'将所选块参照在组合框中置为当前

Call SetSelected(cboBlockName, strTemp) Else

'判断实体是否多段线

If TypeOf objSelect Is AcadLWPolyline Then '获得多段线所在图层名

strTemp = objSelect.Layer Else

MsgBox \您选择的不是轻量多段线，请重新选择轻量多段线！\ '显示对话框

frmBatchPlot.Show Exit Sub End If

' 刷新图层列表 Call ListLayer

'将所选实体所在图层在组合框中置为当前

Call SetSelected(cboLayerName, strTemp) End If

'显示对话框

frmBatchPlot.Show

End Sub

Private Sub cmdPreview_Click() '若按图块进行批量打印

If optBlock.Value = True Then

If cboBlockName.ListCount = 0 Or cboBlockName.Text = \ MsgBox \请先选择块参照！\ Exit Sub End If

Call PreviewByBlock(cboBlockName.Text) '若按图层进行批量打印 Else

If cboLayerName.ListCount = 0 Or cboLayerName.Text = \ MsgBox \请先选择块参照！\ 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 = \ MsgBox \请先选择块参照！\ Exit Sub End If

Call BatchPlotByBlock(cboBlockName.Text) '若按图层进行批量打印 Else

If cboLayerName.ListCount = 0 Or cboLayerName.Text = \ MsgBox \请先选择块参照！\ 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 And ms = False) Then '设置图纸单位

objPlotConfiguration.PaperUnits = acMillimeters '修改标签

lbUnit.Caption = \毫米 ＝\

lbUnitX.Caption = \毫米\ lbUnitY.Caption = \毫米\

lbPaperUnit.Caption = \毫米\

Denominator = Denominator / 25.4

txtDenominator.Text = Format(Denominator, \ txtOffsetX.Text = Format(OffsetX, \ txtOffsetY.Text = Format(OffsetY, \ ElseIf (optMillimeters.Value = False And ms = True) Then '设置图纸单位

objPlotConfiguration.PaperUnits = acInches '修改标签

lbUnit.Caption = \英寸 ＝\ lbUnitX.Caption = \英寸\ lbUnitY.Caption = \英寸\

lbPaperUnit.Caption = \英寸\

Denominator = Denominator * 25.4

txtDenominator.Text = Format(Denominator, \ txtOffsetX.Text = Format(OffsetX / 25.4, \ txtOffsetY.Text = Format(OffsetY / 25.4, \ End If

'非“按图纸空间缩放”时由标准比例变为自定义比例

If cboPlotScale.ListIndex > 1 Then cboPlotScale.ListIndex = 0

'显示图纸尺寸 Call SetPlotZone

ms = optMillimeters.Value End Sub

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

Call PaperRotationChange

'当图纸比例选项为“按图纸空间缩放”时重新计算缩放比例 If cboPlotScale.ListIndex = 1 Then Call SetScaleToFit ' 当居中打印时重新计算打印偏移

If chkCenterPlot.Value Then Call SetOffset

End Sub

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

txtNumber.Text = CInt(txtNumber.Text) - 1 End If

End Sub

Private Sub spnAngle_SpinUp()

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

Private Sub txtCurPath_Change() '查找文件，向列表框中添加

If Len(Dir(txtCurPath.Text)) > 0 Then

FindFile colDwgs, txtCurPath.Text, \ If AddToList(lstCurFiles, colDwgs) Then End If End If End Sub

Private Sub txtDenominator_KeyUp(ByVal KeyCode MSForms.ReturnInteger, ByVal Shift As Integer) ' 设置自定义图纸尺寸

If IsNumeric(CDbl(txtDenominator.Text)) Then Dim strTemp As String '记住文本框文本

strTemp = txtDenominator.Text '设置组合框显示项目为“自定义” cboPlotScale.ListIndex = 0

'恢复文本框文字（上步操作有时会导致文本框值归1） txtDenominator.Text = strTemp '将文本框文本转换为实数

Denominator = CDbl(txtDenominator.Text) '使用自定义打印比例

objPlotConfiguration.UseStandardScale = False '设置自定义打印比例

objPlotConfiguration.SetCustomScale Numerator, Denominator ' 当居中打印时重新计算打印偏移

If chkCenterPlot.Value Then Call SetOffset Else

MsgBox \请输入数字！\ End If End Sub

Private Sub txtNumerator_KeyUp(ByVal KeyCode MSForms.ReturnInteger, ByVal Shift As Integer) ' 设置自定义图纸尺寸

If IsNumeric(CDbl(txtNumerator.Text)) Then Dim strTemp As String

As

As

'记住文本框文本

strTemp = txtNumerator.Text '设置组合框显示项目为“自定义” cboPlotScale.ListIndex = 0

'恢复文本框文字（上步操作有时会导致文本框值归1） txtNumerator.Text = strTemp '将文本框文本转换为实数

Numerator = CDbl(txtNumerator.Text) '使用自定义打印比例

objPlotConfiguration.UseStandardScale = False '设置自定义打印比例

objPlotConfiguration.SetCustomScale Numerator, Denominator ' 当居中打印时重新计算打印偏移

If chkCenterPlot.Value Then Call SetOffset Else

MsgBox \请输入数字！\ End If End Sub

Private Sub txtOffsetX_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) ' 输入检查

If Not ((KeyAscii >= Asc(\Asc(\ MsgBox \请输入数字！\ End If End Sub

Private Sub txtOffsetX_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) On Error Resume Next ' 设置自定义图纸尺寸

If IsNumeric(CDbl(txtOffsetX.Text)) Then Dim strTemp As String '记住文本框文本

strTemp = txtOffsetX.Text '将文本框文本转换为实数

OffsetX = CDbl(txtOffsetX.Text) '取消“居中打印”复选框

chkCenterPlot.Value = False

'恢复文本框文字（上步操作有时会导致文本框值归零） txtOffsetX.Text = strTemp

Dim ptPlotOrigin(0 To 1) As Double '设置自定义打印偏移

'图形方向为“横向”时宽高互调

ptPlotOrigin(0) = IIf(optVertical.Value, OffsetX, OffsetY) ptPlotOrigin(1) = IIf(optVertical.Value, OffsetY, OffsetX) objPlotConfiguration.CenterPlot = False

objPlotConfiguration.PlotOrigin = ptPlotOrigin Else

MsgBox \请输入数字！\ End If End Sub

Private Sub txtOffsetY_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) ' 输入检查

If Not ((KeyAscii >= Asc(\Asc(\ MsgBox \请输入数字！\ End If End Sub

Private Sub txtOffsetY_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) On Error Resume Next ' 设置自定义图纸尺寸

If IsNumeric(CDbl(txtOffsetY.Text)) Then Dim strTemp As String '记住文本框文本

strTemp = txtOffsetY.Text '将文本框文本转换为实数

OffsetY = CDbl(txtOffsetY.Text) '取消“居中打印”复选框

chkCenterPlot.Value = False

'恢复文本框文字（上步操作有时会导致文本框值归零） txtOffsetY.Text = strTemp

Dim ptPlotOrigin(0 To 1) As Double '设置自定义打印偏移

'图形方向为“横向”时宽高互调

ptPlotOrigin(0) = IIf(optVertical.Value, OffsetX, OffsetY) ptPlotOrigin(1) = IIf(optVertical.Value, OffsetY, OffsetX) objPlotConfiguration.CenterPlot = False

objPlotConfiguration.PlotOrigin = ptPlotOrigin Else

MsgBox \请输入数字！\ End If End Sub

Private Sub UserForm_Initialize()

On Error Resume Next '取得当前文档对象

Set objDoc = ThisDrawing.Application.ActiveDocument '取得当前布局对象

Set objLayout = ThisDrawing.ActiveLayout '取得当前打印对象

Set objPlot = ThisDrawing.Plot '从文件对象取得打印配置集合

Set objPlotConfigurations = ThisDrawing.PlotConfigurations '清空以前的打印配置集合

For Each objPlotConfiguration In objPlotConfigurations objPlotConfiguration.Delete Next

'添加打印配置

Set objOriginalPC = objPlotConfigurations.Add(\原来的打印配置\ Set objPlotConfiguration = objPlotConfigurations.Add(\我的打印配置\True)

'复制打印配置

objOriginalPC.CopyFrom objLayout

objPlotConfiguration.CopyFrom objLayout '重命名打印配置

objOriginalPC.name = \原来的打印配置\

objPlotConfiguration.name = \我的打印配置\

'禁用“当前路径”文本框

txtCurPath.Enabled = False

'设置图纸单位

If objOriginalPC.PaperUnits = acInches Then optInches.Value = True Else

optMillimeters.Value = True End If

'记录上次的图纸单位设置 ms = optMillimeters.Value

'设置图纸方向

Call GetPlotRotation '刷新打印机列表

Call ListPlotDeviceNames '刷新打印样式表

Call ListPlotStyleTableNames '刷新打印比例列表 Call ListPlotScale

'设置是否居中打印

chkCenterPlot.Value = objOriginalPC.CenterPlot '设置打印偏移

If Not chkCenterPlot.Value Then Dim ptPlotOrigin As Variant '读取打印偏移

ptPlotOrigin = objOriginalPC.PlotOrigin '设置打印偏移

'图形方向为“横向”时宽高互调

OffsetX = IIf(optVertical.Value, ptPlotOrigin(0), ptPlotOrigin(1)) OffsetY = IIf(optVertical.Value, ptPlotOrigin(1), ptPlotOrigin(0)) txtOffsetX.Text = OffsetX txtOffsetY.Text = OffsetY End If

'设置图纸打印份数

txtNumber.Text = objPlot.NumberOfCopies

'设置“打印到文件”是否选中 chkPlotToFile.Value = False '禁用“打印到文件”组各控件 lbPlotPath.Enabled = False cboPlotPath.Enabled = False cmdBrowse2.Enabled = False

'设置打印选项

chkPlotWithPlotStyles.Value = objOriginalPC.PlotWithPlotStyles

chkPlotWithLineweights.Enabled = Not (chkPlotWithPlotStyles.Value) chkPlotWithLineweights.Value = objOriginalPC.PlotWithLineweights chkPlotHidden.Value = objOriginalPC.PlotHidden

' 显示AutoCAD中当前可用的图块 Call ListBlock

' 显示AutoCAD中当前可用的图层 Call ListLayer

End Sub

Public Sub GetPlotRotation()

Dim PaperWidth As Double, PaperHeight As Double, t As Double '取得图纸尺寸信息

objOriginalPC.GetPaperSize PaperWidth, PaperHeight '设置图纸方向

If PaperWidth < PaperHeight Then

Select Case objOriginalPC.PlotRotation Case ac0degrees

optVertical.Value = True chkReverse.Value = False Case ac90degrees

optHorizontal.Value = True chkReverse.Value = False Case ac180degrees

optVertical.Value = True chkReverse.Value = True Case ac270degrees

optHorizontal.Value = True chkReverse.Value = True End Select Else

Select Case objOriginalPC.PlotRotation Case ac0degrees

optHorizontal.Value = True chkReverse.Value = False Case ac90degrees

optVertical.Value = True chkReverse.Value = False Case ac180degrees

optHorizontal.Value = True chkReverse.Value = True Case ac270degrees

optVertical.Value = True chkReverse.Value = True End Select End If

End Sub

Public Sub SetPlotRotation()

Dim PaperWidth As Double, PaperHeight As Double, t As Double '取得图纸尺寸信息

objPlotConfiguration.GetPaperSize PaperWidth, PaperHeight ' 设置图纸打印方向

If PaperWidth < PaperHeight Then If optVertical.Value = True Then

If chkReverse.Value = False Then

objPlotConfiguration.PlotRotation = ac0degrees Else

objPlotConfiguration.PlotRotation = ac180degrees End If Else

If chkReverse.Value = False Then

objPlotConfiguration.PlotRotation = ac90degrees Else

objPlotConfiguration.PlotRotation = ac270degrees End If End If Else

If optVertical.Value = True Then

If chkReverse.Value = False Then

objPlotConfiguration.PlotRotation = ac90degrees Else

objPlotConfiguration.PlotRotation = ac270degrees End If Else

If chkReverse.Value = False Then

objPlotConfiguration.PlotRotation = ac0degrees Else

objPlotConfiguration.PlotRotation = ac180degrees End If End If End If

End Sub

Public Sub SetPlotConfiguration()

'因有些选项会相互影响，打印前再应用一次打印配置以确保打印成功 '设置打印机配置

objPlotConfiguration.ConfigName = cboPrintersName.Text ' 设置打印样式表

objPlotConfiguration.StyleSheet = cboPlotStyleTableNames.Text ' 设置图纸尺寸 objPlotConfiguration.CanonicalMediaName = paperSizes(cboPaperSize.ListIndex) '设置图纸单位 objPlotConfiguration.PaperUnits = IIf(optMillimeters.Value, acMillimeters, acInches)

Dim Q1

'定义组合框索引到打印比例枚举值的映射

Q1 = Array(100, 0, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, _

1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15) ' 设置图纸打印比例

If cboPlotScale.ListIndex <> 0 Then '使用标准打印比例

objPlotConfiguration.UseStandardScale = True '设置标准打印比例

objPlotConfiguration.StandardScale = Q1(cboPlotScale.ListIndex) Else

'使用自定义打印比例

objPlotConfiguration.UseStandardScale = False '设置自定义打印比例

objPlotConfiguration.SetCustomScale Numerator, Denominator End If

' 设置图纸打印方向 Call SetPlotRotation

' 设置图纸是否居中打印

If chkCenterPlot.Value Then

objPlotConfiguration.CenterPlot = True Else

'设置自定义打印偏移

Dim ptPlotOrigin(0 To 1) As Double '图形方向为“横向”时宽高互调

ptPlotOrigin(0) = IIf(optVertical.Value, OffsetX, OffsetY) ptPlotOrigin(1) = IIf(optVertical.Value, OffsetY, OffsetX) objPlotConfiguration.CenterPlot = False

objPlotConfiguration.PlotOrigin = ptPlotOrigin End If

'设置是否应用打印样式

objPlotConfiguration.PlotWithPlotStyles = chkPlotWithPlotStyles.Value chkPlotWithLineweights.Enabled = Not (chkPlotWithPlotStyles.Value) '设置是否打印对象线宽

If Not objPlotConfiguration.PlotWithPlotStyles Then _ objPlotConfiguration.PlotWithLineweights = chkPlotWithLineweights.Value '设置是否隐藏图纸空间对象 If Not objPlotConfiguration.ModelType Then objPlotConfiguration.PlotHidden = chkPlotHidden.Value

'设置打印类型

objPlotConfiguration.PlotType = acWindow

'设置图纸打印份数

objPlot.NumberOfCopies = txtNumber.Value

'将打印错误报告切换为静默错误模式，以便不间断地执行打印任务 objPlot.QuietErrorMode = True

End Sub

Private Sub BatchPlotByBlock(strBlockReferenceName As String) On Error Resume Next '如果列表框中未存在任何元素

If lstPlotFiles.ListCount = 0 Then

MsgBox \请先向列表框中添加文件！\ 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 \文件\不存在！\ End If

'打开或激活第i个图形文件

Call OpenFile(lstPlotFiles.List(i))

Set objDoc = ThisDrawing.Application.ActiveDocument '实现范围缩放

ThisDrawing.Application.ZoomExtents ' 确保当前布局是模型空间

Set objLayout = objDoc.Layouts.Item(\ Set objPlot = objDoc.Plot ' 设置打印选项

Call SetPlotConfiguration ' 将打印设置应用到当前图形

objLayout.CopyFrom objPlotConfiguration '重新生成当前图形

objDoc.Regen acAllViewports

' 确保AutoCAD在前台进行打印，这样后一次打印会在前一次打印完成之后才开始,避免出现错误

objDoc.SetVariable \

'对当前图形模型空间中的所有打印区域进行打印 Dim SSet As AcadSelectionSet '使用选择集获得对象集合

Call SelectByBlock(strBlockReferenceName, SSet)

'对选择集中每个对象进行打印或预览 For Each ent In SSet

'获得每个对象最小包围框的两个角点 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 = n + 1 Else

objPlot.PlotToDevice objLayout.ConfigName End If Next ent ' 删除选择集 SSet.Delete

' 恢复系统变量的值

objDoc.SetVariable \ '保存当前图形 '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 \请先向列表框中添加文件！\ 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 \文件\不存在！\ End If

'打开或激活第i个图形文件

Call OpenFile(lstPlotFiles.List(i))

Set objDoc = ThisDrawing.Application.ActiveDocument '实现范围缩放

ThisDrawing.Application.ZoomExtents ' 确保当前布局是模型空间

Set objLayout = objDoc.Layouts.Item(\ Set objPlot = objDoc.Plot ' 设置打印选项

Call SetPlotConfiguration ' 将打印设置应用到当前图形

objLayout.CopyFrom objPlotConfiguration '重新生成当前图形

objDoc.Regen acAllViewports

' 确保AutoCAD在前台进行打印，这样后一次打印会在前一次打印完成之后才开始,避免出现错误

objDoc.SetVariable \

'对当前图形模型空间中的所有打印区域进行打印 Dim SSet As AcadSelectionSet '使用选择集获得对象集合

Call SelectByLayer(strLayerName, SSet)

'对选择集中每个对象进行打印或预览 For Each ent In SSet

'获得每个对象最小包围框的两个角点

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 = n + 1 Else

objPlot.PlotToDevice objLayout.ConfigName End If Next ent ' 删除选择集 SSet.Delete

' 恢复系统变量的值

objDoc.SetVariable \ '保存当前图形 'objDoc.Save

'关闭但不保存当前图形 '保证至少一个文件打开

If ThisDrawing.Application.Documents.count > 1 Then objDoc.Close False End If Next i

'显示对话框

frmBatchPlot.Show End Sub

Private Sub PreviewByBlock(strBlockReferenceName As String) On Error Resume Next '如果列表框中未存在任何元素

If lstPlotFiles.ListCount = 0 Then

MsgBox \请先向列表框中添加文件！\ 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 \文件\不存在！\ End If

'打开或激活第i个图形文件

Call OpenFile(lstPlotFiles.List(i))

Set objDoc = ThisDrawing.Application.ActiveDocument '实现范围缩放

ThisDrawing.Application.ZoomExtents ' 确保当前布局是模型空间

Set objLayout = objDoc.Layouts.Item(\ Set objPlot = objDoc.Plot ' 设置打印选项

Call SetPlotConfiguration ' 将打印设置应用到当前图形

objLayout.CopyFrom objPlotConfiguration '重新生成当前图形

objDoc.Regen acAllViewports

'对当前图形模型空间中的所有打印区域进行完全预览 Dim SSet As AcadSelectionSet '使用选择集获得对象集合

Call SelectByBlock(strBlockReferenceName, SSet) '对选择集中每个对象进行打印或预览 For Each ent In SSet

'获得每个对象最小包围框的两个角点 ent.GetBoundingBox ptMin, ptMax '将三维点转化为二维点坐标

ReDim Preserve ptMin(0 To 1) ReDim Preserve ptMax(0 To 1) '设置打印窗口

objLayout.SetWindowToPlot ptMin, ptMax '完全预览当前的区域

objPlot.DisplayPlotPreview acFullPreview n = n + 1 If n > 1 Then

'恢复原来的打印设置

objLayout.CopyFrom objOriginalPC '显示对话框

frmBatchPlot.Show Exit Sub End If Next ent ' 删除选择集 SSet.Delete Next i

'无打印区域时显示对话框

MsgBox \选定图形中无打印区域！\ '恢复原来的打印设置

objLayout.CopyFrom objOriginalPC '显示对话框

frmBatchPlot.Show

End Sub

Private Sub PreviewByLayer(strLayerName As String) On Error Resume Next '如果列表框中未存在任何元素

If lstPlotFiles.ListCount = 0 Then

MsgBox \请先向列表框中添加文件！\ 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 \文件\不存在！\ End If

'打开或激活第i个图形文件

Call OpenFile(lstPlotFiles.List(i))

Set objDoc = ThisDrawing.Application.ActiveDocument '实现范围缩放

ThisDrawing.Application.ZoomExtents ' 确保当前布局是模型空间

Set objLayout = objDoc.Layouts.Item(\

Set objPlot = objDoc.Plot ' 设置打印选项

Call SetPlotConfiguration ' 将打印设置应用到当前图形

objLayout.CopyFrom objPlotConfiguration '重新生成当前图形

objDoc.Regen acAllViewports

'对当前图形模型空间中的所有打印区域进行完全预览 Dim SSet As AcadSelectionSet '使用选择集获得对象集合

Call SelectByLayer(strLayerName, SSet)

'对选择集中每个对象进行打印或预览 For Each ent In SSet

'获得每个对象最小包围框的两个角点 ent.GetBoundingBox ptMin, ptMax '将三维点转化为二维点坐标

ReDim Preserve ptMin(0 To 1) ReDim Preserve ptMax(0 To 1) '设置打印窗口

objLayout.SetWindowToPlot ptMin, ptMax '完全预览当前的区域

objPlot.DisplayPlotPreview acFullPreview n = n + 1 If n > 1 Then

'恢复原来的打印设置

objLayout.CopyFrom objOriginalPC '显示对话框

frmBatchPlot.Show Exit Sub End If Next ent ' 删除选择集 SSet.Delete Next i

'无打印区域时显示对话框

MsgBox \选定图形中无打印区域！\ '恢复原来的打印设置

objLayout.CopyFrom objOriginalPC '显示对话框

frmBatchPlot.Show

End Sub

Public Function ReturnFolder(lngHwnd As Long) As String Dim Browser As BrowseInfo Dim lngFolder As Long Dim strPath As String Dim strTemp As String

With Browser

.hOwner = lngHwnd

.lpszTitle = \选择工作路径\

.pszDisplayName = String(MAX_PATH, 0) End With

'用空格填充字符串

strPath = String(MAX_PATH, 0) '调用API函数显示文件夹列表

lngFolder = SHBrowseForFolder(Browser)

'使用API函数获取返回的路径 If lngFolder Then

SHGetPathFromIDList lngFolder, strPath

strTemp = Left(strPath, InStr(strPath, vbNullChar) - 1)

If (Right(strTemp, 1) <> \ 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) <> \ strDir = strDir & \

End If

strFileName = Dir(strDir & \

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 \发生下面的错误：\.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 & \ '若第i个图形文件已经被打开，则将其激活 If strFile = fileName Then

'若dwgFile尚未激活，则将其激活 If dwgFile.Active = False Then

ThisDrawing.Application.ActiveDocument = dwgFile End If Exit Sub End If Next

'若第i个图形文件尚未被打开，则将其打开

ThisDrawing.Application.Documents.Open fileName

End Sub

' 显示AutoCAD中当前可用的打印机列表 Public Sub ListPlotDeviceNames() '取得当前布局对象

Set objLayout = ThisDrawing.ActiveLayout '取得当前打印机配置信息

objPlotConfiguration.ConfigName = objLayout.ConfigName '刷新这个工作任务当前的打印信息

objPlotConfiguration.RefreshPlotDeviceInfo '列出系统上所有有效的设备名称 Dim plotDevices As Variant

plotDevices = objPlotConfiguration.GetPlotDeviceNames '删除以前的打印机列表 cboPrintersName.Clear '显示打印机列表 Dim i As Integer

For i = 0 To UBound(plotDevices)

cboPrintersName.AddItem (plotDevices(i)) '设置默认的显示项目

If objPlotConfiguration.ConfigName = plotDevices(i) cboPrintersName.ListIndex = i Next i

'设置组合框初始选项 With cboPrintersName '使用下拉列表的形式

.Style = fmStyleDropDownList '设置默认的显示项目

If .ListIndex = -1 Then .ListIndex = 0 End With

End Sub

' 显示AutoCAD中当前可用的图纸尺寸 Public Sub ListPaperSize() '取得当前布局对象

Set objLayout = ThisDrawing.ActiveLayout

If cboPrintersName.Text = objLayout.ConfigName Then '取得当用图纸尺寸 objPlotConfiguration.CanonicalMediaName objLayout.CanonicalMediaName End If

'刷新打印设备信息

objPlotConfiguration.RefreshPlotDeviceInfo '列出所有介质的名称以及它们的本地版本

paperSizes = objPlotConfiguration.GetCanonicalMediaNames '删除以前的图纸尺寸列表 cboPaperSize.Clear '显示图纸尺寸列表 Dim i As Integer

For i = 0 To UBound(paperSizes)

Then =

cboPaperSize.AddItem objPlotConfiguration.GetLocaleMediaName(paperSizes(i)) '设置默认的显示项目

If objPlotConfiguration.CanonicalMediaName = paperSizes(i) Then cboPaperSize.ListIndex = i Next i

'设置组合框初始选项 With cboPaperSize '使用下拉列表的形式

.Style = fmStyleDropDownList '设置默认的显示项目

If .ListIndex = -1 Then .ListIndex = 0 End With

End Sub

' 显示AutoCAD中当前可用的打印样式 Public Sub ListPlotStyleTableNames() '取得当前布局对象

Set objLayout = ThisDrawing.ActiveLayout '取得当前打印样式

objPlotConfiguration.StyleSheet = objLayout.StyleSheet '刷新打印设备信息

objPlotConfiguration.RefreshPlotDeviceInfo ' 获得所有的可用打印样式

Dim plotStyleTables As Variant

plotStyleTables = objPlotConfiguration.GetPlotStyleTableNames

' 删除以前的打印样式列表

cboPlotStyleTableNames.Clear ' 添加打印样式列表 Dim i As Integer Dim str As String

For i = 0 To UBound(plotStyleTables) str = plotStyleTables(i)

Call AddSorted(cboPlotStyleTableNames, str) Next i

'设置默认的显示项目

For i = 0 To UBound(plotStyleTables) str = plotStyleTables(i)

If cboPlotStyleTableNames.List(i) = objPlotConfiguration.StyleSheet Then

cboPlotStyleTableNames.ListIndex = i Exit For End If Next i

' 设置组合框初始选项

With cboPlotStyleTableNames '使用下拉列表的形式

.Style = fmStyleDropDownList '设置默认的显示项目

If .ListIndex = -1 Then .ListIndex = 0 End With

End Sub

' 显示AutoCAD中可以使用的打印比例 Public Sub ListPlotScale() Dim i As Integer '定义图纸尺寸数组

Dim P, Nu, De, Q1, Q2 '定义图纸尺寸数组

P = Array(\自定义\按图纸空间缩放\\

\\\\\\\\\

\\

\ '定义分子数组

Nu = Array(\ \ \ \ '定义分母数组

De = Array(\

\_

\ \

'定义组合框索引到打印比例枚举值的映射

Q1 = Array(100, 0, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, _

1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15) '定义打印比例枚举值到组合框索引的映射

Q2 = Array(1, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, _

2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 100)

'取得当前布局对象

Set objLayout = ThisDrawing.ActiveLayout '取得当前打印比例

objPlotConfiguration.UseStandardScale = objLayout.UseStandardScale ' 显示打印比例列表 With cboPlotScale ' 清空打印比例列表 .Clear

For i = 0 To 32

.AddItem P(i), i Next

'使用下拉列表的形式

.Style = fmStyleDropDownList '设置默认的显示项目

If Not objPlotConfiguration.UseStandardScale Then '使用自定义比例 .ListIndex = 0

objLayout.GetCustomScale Numerator, Denominator

objPlotConfiguration.SetCustomScale Numerator, Denominator '设置文本框文本

txtNumerator.Text = Numerator

txtDenominator.Text = Denominator Else

'使用标准比例

objPlotConfiguration.StandardScale = objLayout.StandardScale .ListIndex = Q2(objPlotConfiguration.StandardScale) If .ListIndex > 1 Then

Numerator = Nu(cboPlotScale.ListIndex) Denominator = De(cboPlotScale.ListIndex) '设置文本框文本

txtNumerator.Text = Numerator

txtDenominator.Text = Denominator Else

'计算缩放比例

Call SetScaleToFit End If End If End With

End Sub

Public Sub SetScaleToFit()

Dim PaperWidth As Double, PaperHeight As Double, t As Double Dim PlotWidth As Double, PlotHeight As Double

Dim WindowWidth As Double, WindowHeight As Double

Dim MarginLowerLeft As Variant, MarginUpperRight As Variant Dim WindowLowerLeft As Variant, WindowUpperRight As Variant '刷新打印设备信息

objPlotConfiguration.RefreshPlotDeviceInfo '取得图纸尺寸信息

objPlotConfiguration.GetPaperSize PaperWidth, PaperHeight '取得图纸边界信息 objPlotConfiguration.GetPaperMargins MarginLowerLeft, MarginUpperRight '计算打印区域

PlotWidth = PaperWidth - (MarginUpperRight(0) + MarginLowerLeft(0)) PlotHeight = PaperHeight - (MarginUpperRight(1) + MarginLowerLeft(1)) '根据选择的图形方向调换宽高 If optVertical.Value Then

'图形方向为“纵向”时宽小于高

If PlotWidth > PlotHeight Then t = PlotWidth

PlotWidth = PlotHeight PlotHeight = t End If Else

'图形方向为“横向”时宽大于高

If PlotWidth < PlotHeight Then t = PlotWidth

PlotWidth = PlotHeight PlotHeight = t End If End If

'获得打印窗口 objPlotConfiguration.GetWindowToPlot WindowLowerLeft, WindowUpperRight

WindowWidth = WindowUpperRight(0) - WindowLowerLeft(0) WindowHeight = WindowUpperRight(1) - WindowLowerLeft(1) '计算所需比例

Dim ScaleX As Double, ScaleY As Double ScaleX = WindowWidth / PlotWidth ScaleY = WindowHeight / PlotHeight Numerator = 1

Denominator = IIf(ScaleX > ScaleY, ScaleX, ScaleY)

Dim d As Double

'单位由“毫米”转换为“英寸”

d = IIf(optMillimeters.Value, Denominator, Denominator * 25.4) '设置文本框文本

txtNumerator.Text = Numerator

txtDenominator.Text = Format(d, \

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 \当前图形中不存在任何的块！\ 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 = \ '不将模型空间、图纸空间和匿名块添加到组合框中

If StrComp(Left(AcadObject.name, 1), \ On Error Resume Next

BlockList.Add AcadObject.name, AcadObject.name End If End If Next

'返回图形中块参照的列表

If BlockList.count > 0 Then

Set GetBlockReferences = BlockList Else

Set GetBlockReferences = Nothing End If End Function

'将组合对象中的元素写入列表框或组合框中

Private Sub RefreshList(ByRef ListObject As Object, ByRef BlockList As Collection)

Dim i As Long '清空列表框

ListObject.Clear

'向列表框中添加新的元素

For i = 1 To BlockList.count

AddSorted ListObject, BlockList(i) Next

End Sub

Private Sub AddSorted(ListObject As Object, SItem As String) '将元素添加到组合框或列表框中，并且排序 Dim i As Long

'元素数目小于1，不进行排序

If ListObject.ListCount = 0 Then ListObject.AddItem SItem Exit Sub End If

'通过比较确定该元素的位置，类似于插入排序法 For i = 0 To (ListObject.ListCount - 1)

If StrComp(ListObject.List(i), SItem, vbTextCompare) = 1 Then ListObject.AddItem SItem, i Exit Sub End If Next

'添加到列表框的最后

ListObject.AddItem SItem

End Sub

Public Sub PaperRotationChange() ' 设置图纸打印方向

If optVertical.Value = True Then

If chkReverse.Value = False Then

objPlotConfiguration.PlotRotation = ac0degrees Else

objPlotConfiguration.PlotRotation = ac180degrees End If

Else

If chkReverse.Value = False Then

objPlotConfiguration.PlotRotation = ac90degrees Else

objPlotConfiguration.PlotRotation = ac270degrees End If End If

' 显示图纸大小 Call SetPlotZone End Sub

' 设置图纸可打印区域大小 Public Sub SetPlotZone()

Dim PaperWidth As Double, PaperHeight As Double, t As Double Dim PlotWidth As Double, PlotHeight As Double

Dim MarginLowerLeft As Variant, MarginUpperRight As Variant '刷新打印设备信息

objPlotConfiguration.RefreshPlotDeviceInfo

'取得图纸尺寸信息

objPlotConfiguration.GetPaperSize PaperWidth, PaperHeight '取得图纸边界信息 objPlotConfiguration.GetPaperMargins MarginLowerLeft, MarginUpperRight '计算打印区域

PlotWidth = PaperWidth - (MarginUpperRight(0) + MarginLowerLeft(0)) PlotHeight = PaperHeight - (MarginUpperRight(1) + MarginLowerLeft(1)) '根据选择的图形方向调换宽高 If optVertical.Value Then

'图形方向为“纵向”时宽小于高

If PlotWidth > PlotHeight Then t = PlotWidth

PlotWidth = PlotHeight PlotHeight = t End If Else

'图形方向为“横向”时宽大于高

If PlotWidth < PlotHeight Then t = PlotWidth

PlotWidth = PlotHeight PlotHeight = t End If End If

'单位由“毫米”转换为“英寸”

If optMillimeters.Value = False Then PlotWidth = PlotWidth / 25.4 PlotHeight = PlotHeight / 25.4 End If

' 显示图纸大小

lbPaperSize.Caption = Format(PlotWidth, \ \& Format(PlotHeight, \

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 '读入一行文本并存储在变量中

本文来源：https://www.bwwdw.com/article/54eo.html