|
Option Explicit
'图形集合
Private colDwgs As New Collection
'文档对象
Dim objDoc As AcadDocument
'布局对象
Dim objLayout As AcadLayout
'打印对象
Dim objPlot As AcadPlot
Private Type BrowseInfo
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Const MAX_PATH = 260
'代表ESC键
Private Const VK_ESCAPE = &H1B
'API函数的声明
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal _
pidl As Long, ByVal pszPath As String) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
' 功能：判断用户是否按下某一个键
' 输入：代表键的常量（从API Viewer中获得）
' 调用：API函数GetAsyncKeyState
' 返回：如果用户按下了指定的键，返回True；否则返回False
' 示例：
' If CheckKey(&H1B) = True Then do sth
Private Function CheckKey(lngKey As Long) As Boolean
If GetAsyncKeyState(lngKey) Then
CheckKey = True
Else
CheckKey = False
End If
End Function
Private Sub cboPaperSize_Change()
'若组合框非空
If cboPaperSize.Text <> "" Then
' 设置图纸尺寸
objLayout.CanonicalMediaName = cboPaperSize.Text
' 显示图纸尺寸
Call SetPlotZone
End If
End Sub
Private Sub cboPlotScale_Click()
If cboPlotScale.Value Then
objLayout.UseStandardScale = True '使用标准打印比例
Else
objLayout.UseStandardScale = False '使用自定义打印比例
End If
Select Case cboPlotScale.Value
Case 0
'txtNumerator = 1
'txtDenominator = 1
Case 1
objLayout.StandardScale = acScaleToFit
txtNumerator = 1
txtDenominator = ""
Case 2
objLayout.StandardScale = ac1_1
txtNumerator = 1
txtDenominator = 1
Case 3
objLayout.StandardScale = ac1_2
txtNumerator = 1
txtDenominator = 2
Case 4
objLayout.StandardScale = ac1_4
txtNumerator = 1
txtDenominator = 4
Case 5
objLayout.StandardScale = ac1_8
txtNumerator = 1
txtDenominator = 8
Case 6
objLayout.StandardScale = ac1_10
txtNumerator = 1
txtDenominator = 10
Case 7
objLayout.StandardScale = ac1_16
txtNumerator = 1
txtDenominator = 16
Case 8
objLayout.StandardScale = ac1_20
txtNumerator = 1
txtDenominator = 20
Case 9
objLayout.StandardScale = ac1_30
txtNumerator = 1
txtDenominator = 30
Case 10
objLayout.StandardScale = ac1_40
txtNumerator = 1
txtDenominator = 40
Case 11
objLayout.StandardScale = ac1_50
txtNumerator = 1
txtDenominator = 50
Case 12
objLayout.StandardScale = ac1_100
txtNumerator = 1
txtDenominator = 100
Case 13
objLayout.StandardScale = ac2_1
txtNumerator = 2
txtDenominator = 1
Case 14
objLayout.StandardScale = ac4_1
txtNumerator = 4
txtDenominator = 1
Case 15
objLayout.StandardScale = ac8_1
txtNumerator = 8
txtDenominator = 1
Case 16
objLayout.StandardScale = ac10_1
txtNumerator = 10
txtDenominator = 1
Case 17
objLayout.StandardScale = ac100_1
txtNumerator = 100
txtDenominator = 1
End Select
End Sub
Private Sub cboPlotStyleTableNames_Change()
' 设置打印样式表
objLayout.StyleSheet = cboPlotStyleTableNames.Text
End Sub
Private Sub cboPrintersName_Change()
On Error Resume Next
' 设置打印机配置（对应AutoCAD中：打印>打印设备>打印机配置>"DWF6 ePlot.pc3"）
objLayout.ConfigName = cboPrintersName.Text
' 更新显示AutoCAD中当前可用的所有图纸尺寸
Call ListPaperSize
' 更新显示AutoCAD中当前可用的所有打印样式表
Call ListPlotStyleTableNames
End Sub
Private Sub chkCenterPlot_Change()
Dim PtOffset(0 To 1) As Double
' 设置图纸是否居中打印
If chkCenterPlot.Value Then
PtOffset(0) = 0
PtOffset(1) = 0
Else
PtOffset(0) = -5
PtOffset(1) = -5
End If
txtOffsetX.Value = PtOffset(0)
txtOffsetY.Value = PtOffset(1)
End Sub
Private Sub chkPlotHidden_Change()
'设置是否隐藏图纸空间对象
If chkPlotHidden.Value Then
'打印时隐藏图纸空间对象
objLayout.PlotHidden = True
Else
'打印时不隐藏图纸空间对象
objLayout.PlotHidden = False
End If
End Sub
Private Sub chkPlotToFile_Change()
'设置“打印到文件”组各控件激活状态
If chkPlotToFile.Value Then
lbPlotPath.Enabled = True
cboPlotPath.Enabled = True
cmdBrowse2.Enabled = True
Else
lbPlotPath.Enabled = False
cboPlotPath.Enabled = False
cmdBrowse2.Enabled = False
End If
End Sub
Private Sub chkPlotWithLineweights_Change()
'设置是否打印对象线宽
If chkPlotWithLineweights.Value Then
'打印时使用图形文件中的线宽
objLayout.PlotWithLineweights = True
Else
'打印时使用打印样式中的线宽
objLayout.PlotWithLineweights = False
End If
End Sub
Private Sub chkPlotWithPlotStyles_Change()
'设置是否应用打印样式
If chkPlotWithPlotStyles.Value Then
'打印时在对象中使用打印样式
objLayout.PlotWithPlotStyles = True
chkPlotWithLineweights.Enabled = False
Else
'打印时在对象中不使用打印样式
objLayout.PlotWithPlotStyles = False
chkPlotWithLineweights.Enabled = True
End If
End Sub
Private Sub chkReverse_Click()
' 设置图纸打印方向
Call PaperRotationChange
End Sub
Private Sub cmdAdd_Click()
'如果列表框中未存在任何元素
If lstCurFiles.ListCount = 0 Then
MsgBox "请先向列表框中添加文件！", vbCritical
Exit Sub
End If
Dim strFlies As String
Dim i As Integer
Dim n As Integer
n = 0
'将上面列表框中选中的对象添加到下面的列表框中
For i = 0 To lstCurFiles.ListCount - 1
If lstCurFiles.Selected(i) Then
strFlies = lstCurFiles.List(i)
n = n + 1
If Not HasItem(lstPlotFiles, strFlies) Then
lstPlotFiles.AddItem lstCurFiles.List(i) '
End If
End If
Next i
'如果列表框中未存在被选择的元素
If n = 0 Then
MsgBox "请选择要从列表中添加的元素！", vbCritical
Exit Sub
End If
End Sub
Private Sub cmdAddAll_Click()
'如果列表框中未存在任何元素
If lstCurFiles.ListCount = 0 Then
MsgBox "请先向列表框中添加文件！", vbCritical
Exit Sub
End If
Dim strFlies As String
Dim i As Integer
'将上面列表框中选中的对象添加到下面的列表框中
For i = 0 To lstCurFiles.ListCount - 1
strFlies = lstCurFiles.List(i)
If Not HasItem(lstPlotFiles, strFlies) Then
lstPlotFiles.AddItem lstCurFiles.List(i)
End If
Next i
End Sub
Private Sub cmdBrowse_Click()
'在文本框中显示获得的路径
txtCurPath.Text = ReturnFolder(0)
End Sub
Private Sub cmdBrowse2_Click()
Dim strPath As String
strPath = ReturnFolder(0)
'若返回文件夹路径非空
If strPath <> "" Then
'若组合框中未存在返回文件夹路径，则将其添加到组合框中
If HasItem2(strPath) < 0 Then
'在组合框中显示获得的路径
With cboPlotPath
.AddItem strPath, 0
'使用下拉列表的形式
.Style = fmStyleDropDownList
'设置下拉列表的下标下限
.BoundColumn = 0
'设置默认的显示项目
.ListIndex = 0
End With
'若组合框中已存在返回文件夹路径，则将返回文件夹路径置为选中
Else
With cboPlotPath
'设置默认的显示项目
.ListIndex = HasItem2(strPath)
End With
End If
End If
End Sub
Private Sub cmdClear_Click()
'如果列表框中未存在任何元素
If lstPlotFiles.ListCount = 0 Then
MsgBox "请先向列表框中添加文件！", vbCritical
Exit Sub
End If
Dim i As Integer, n As Integer, count As Integer
'列表框中元素的数量
count = lstPlotFiles.ListCount
n = 0
'将列表框中选中的对象删除
For i = 0 To count - 1
If lstPlotFiles.Selected(i) Then
n = n + 1
Else
'移动列表框中的元素
lstPlotFiles.List(i - n) = lstPlotFiles.List(i)
End If
Next i
'如果列表框中未存在被选择的元素
If n = 0 Then
MsgBox "请选择要从列表中清除的元素！", vbCritical
Exit Sub
End If
'删除最后n行的元素
For i = 1 To n
lstPlotFiles.RemoveItem (count - i)
Next i
End Sub
Private Sub cmdClearAll_Click()
'如果列表框中未存在任何元素
If lstPlotFiles.ListCount = 0 Then
MsgBox "请先向列表框中添加文件！", vbCritical
Exit Sub
End If
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "清除整个图形列表?"
Style = vbOKCancel + vbQuestion + vbDefaultButton2
Title = "Clear Files"
Response = MsgBox(Msg, Style, Title)
If Response = vbOK Then
txtCurPath.Text = ""
'清除列表框中所有元素
lstPlotFiles.Clear
End If
End Sub
Private Sub cmdExit_Click()
'退出
End
End Sub
Private Sub cmdInput_Click()
'导入打印设置
'设置标准对话框
With comDlg
'设置标准对话框标题
.DialogTitle = "导入打印设置"
'设置标准对话框类型列表中所显示的过滤器
.Filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
'设置标准对话框的起始目录
'.InDir = "C:\"
'显示[打开]对话框
.ShowOpen
End With
Dim strFileName As String
strFileName = comDlg.fileName
'strFileName = "F:\AutoCAD\丹通施工图\打印设置.txt"
'若返回文件名为空，不进行操作
If strFileName = "" Then
MsgBox "请重新选择文件位置！"
Exit Sub
End If
'读入文件的操作
Dim i As Integer, nFile As Integer
Dim x As Double, y As Double
Dim count As Integer, index As Integer
Dim strTemp As String
'获得下一个可供Open语句使用的文件号
nFile = FreeFile
'打开文件
Open strFileName For Input As #nFile
'读入当前路径
'读入一行文本并存储在变量中
Line Input #nFile, strTemp
'读入当前路径并设置文本框文字
Input #nFile, strTemp
txtCurPath.Text = strTemp
'读入打印文件列表并添加到列表框中
Call InputData3(lstPlotFiles, nFile)
'读入打印机配置列表并添加到组合框中
Call InputData(cboPrintersName, nFile)
'读入打印样式表并添加到组合框中
Call InputData(cboPlotStyleTableNames, nFile)
'读入图纸尺寸列表并添加到组合框中
Call InputData(cboPaperSize, nFile)
'读入图纸单位并设置单选按钮选择状态
'读入一行文本并存储在变量中
Line Input #nFile, strTemp
'读入图纸单位
Input #nFile, strTemp
'设置单选按钮选择状态
If strTemp = "毫米" Then
optMillimeters.Value = True
Else
optInches.Value = True
End If
'读入图纸方向并设置单选按钮选择状态
'读入一行文本并存储在变量中
Line Input #nFile, strTemp
'读入图纸方向
Input #nFile, strTemp
'设置单选按钮选择状态
If strTemp = "纵向" Then
optVertical.Value = True
Else
optHorizontal.Value = True
End If
'读入是否反向打印并设置复选按钮选择状态
Call InputData2(chkReverse, nFile)
'读入打印份数
'读入一行文本并存储在变量中
Line Input #nFile, strTemp
'读入打印份数
Input #nFile, count
'设置文本框文字
txtNumber.Text = count
'读入是否打印到文件并设置复选按钮选择状态
Call InputData2(chkPlotToFile, nFile)
'读入打印路径列表并添加到组合框中
Call InputData(cboPlotPath, nFile)
'读入打印比例列表并添加到组合框中
Call InputData(cboPlotScale, nFile)
'读入一行文本并存储在变量中
Line Input #nFile, strTemp
'读入当前打印比例并设置文本框文字
Input #nFile, x
Input #nFile, y
txtNumerator.Text = x
txtDenominator.Text = y
'读入是否居中打印并设置复选按钮选择状态
Call InputData2(chkCenterPlot, nFile)
'读入打印偏移
'读入一行文本并存储在变量中
Line Input #nFile, strTemp
'读入打印偏移并设置文本框文字
Input #nFile, x
Input #nFile, y
txtOffsetX.Text = x
txtOffsetY.Text = y
'读入是否打印对象线宽并设置复选按钮选择状态
Call InputData2(chkPlotWithLineweights, nFile)
'读入是否采用打印样式并设置复选按钮选择状态
Call InputData2(chkPlotWithPlotStyles, nFile)
'读入是否隐藏图纸空间对象并设置复选按钮选择状态
Call InputData2(chkPlotHidden, nFile)
'读入图框形式并设置单选按钮选择状态
'读入一行文本并存储在变量中
Line Input #nFile, strTemp
'读入图框形式
Input #nFile, strTemp
'设置单选按钮选择状态
If strTemp = "图块" Then
optBlock.Value = True
Else
optLayer.Value = True
End If
'读入图块名列表并添加到组合框中
Call InputData(cboBlockName, nFile)
'读入图层名列表并添加到组合框中
Call InputData(cboLayerName, nFile)
'关闭文件
Close #nFile
End Sub
Private Sub cmdListPrints_Click()
' 显示AutoCAD中当前可用的打印机列表
Call ListPrinters
End Sub
Private Sub cmdOutput_Click()
'导出打印设置
'设置标准对话框
With comDlg
'设置标准对话框标题
.DialogTitle = "导出打印设置"
'设置标准对话框类型列表中所显示的过滤器
.Filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
'设置标准对话框的起始目录
'.InDir = "C:\"
'设置[另存为]对话框的缺省扩展名
.DefaultExt = "txt"
'显示[另存为]对话框
.ShowSave
End With
Dim strFileName As String, strTemp As String
strFileName = comDlg.fileName
'strFileName = "F:\AutoCAD\丹通施工图\打印设置.txt"
'若返回文件名为空，不进行操作
If strFileName = "" Then
MsgBox "请重新选择保存位置！"
Exit Sub
End If
'保存文件的操作
Dim i As Integer
'打开文件
Open strFileName For Output As #1
'输出当前路径
Print #1, "当前路径："
Print #1, txtCurPath.Text
'输出打印文件列表
Print #1, "打印文件列表："
'输出打印机配置列表的信息
Call OutputData3(lstPlotFiles, 1)
'输出打印机配置
Print #1, "打印机配置："
'输出打印机配置列表的信息
Call OutputData(cboPrintersName, 1)
'输出打印样式表
Print #1, "打印样式表："
'输出打印样式表的信息
Call OutputData(cboPlotStyleTableNames, 1)
'输出图纸尺寸列表
Print #1, "图纸尺寸列表："
'输出图纸尺寸列表的信息
Call OutputData(cboPaperSize, 1)
'输出图纸单位
Print #1, "图纸单位："
'输出图纸单位信息
If optMillimeters.Value = True Then
strTemp = "毫米"
Else
strTemp = "英寸"
End If
Print #1, strTemp
'输出图纸方向
Print #1, "图纸方向："
'输出图纸方向信息
If optVertical.Value = True Then
strTemp = "纵向"
Else
strTemp = "横向"
End If
Print #1, strTemp
'输出是否反向打印
Print #1, "是否反向打印："
Call OutputData2(chkReverse, 1)
'输出打印份数
Print #1, "打印份数："
Print #1, txtNumber.Text
'输出是否打印到文件
Print #1, "是否打印到文件："
Call OutputData2(chkPlotToFile, 1)
'输出打印路径
Print #1, "打印路径："
'输出打印路径列表的信息
Call OutputData(cboPlotPath, 1)
'输出打印比例
Print #1, "打印比例："
'输出打印比例列表的信息
Call OutputData(cboPlotScale, 1)
'输出当前打印比例
Print #1, "当前打印比例："
Print #1, txtNumerator.Text
Print #1, txtDenominator.Text
'输出是否居中打印
Print #1, "是否居中打印："
Call OutputData2(chkCenterPlot, 1)
'输出打印偏移
Print #1, "打印偏移："
Print #1, txtOffsetX.Text
Print #1, txtOffsetY.Text
'输出是否打印对象线宽
Print #1, "是否打印对象线宽："
Call OutputData2(chkPlotWithLineweights, 1)
'输出是否采用打印样式
Print #1, "是否采用打印样式："
Call OutputData2(chkPlotWithPlotStyles, 1)
'输出是否隐藏图纸空间对象
Print #1, "是否隐藏图纸空间对象："
Call OutputData2(chkPlotHidden, 1)
'输出图框形式
Print #1, "图框形式："
'输出图框形式信息
If optBlock.Value = True Then
strTemp = "图块"
Else
strTemp = "图层"
End If
Print #1, strTemp
'输出图块名列表
Print #1, "图块名列表："
'输出图块名列表的信息
Call OutputData(cboBlockName, 1)
'输出图层名列表
Print #1, "图块名列表："
'输出图层名列表的信息
Call OutputData(cboLayerName, 1)
'关闭文件
Close 1
End Sub
Private Sub cmdPick_Click()
On Error Resume Next
Dim objSelect As AcadEntity
Dim ptPick As Variant
Dim strTemp As String
Set objDoc = ThisDrawing.Application.ActiveDocument
'将控制权交给AutoCAD
frmBatchPlot.Hide
'在AutoCAD中选择实体并判断类型
Retry:
objDoc.Utility.GetEntity objSelect, ptPick, vbCrLf & "请选择实体："
' 处理按下Esc键的错误
If objSelect Is Nothing Then
If CheckKey(VK_ESCAPE) = True Then
'显示对话框
frmBatchPlot.Show
Exit Sub
Else
GoTo Retry
End If
End If
' 处理未选择到实体的错误
If Err <> 0 Then
Err.Clear
GoTo Retry
End If
'若为指定图块
If optBlock.Value = True Then
'判断实体是否块参照
If TypeOf objSelect Is AcadBlockReference Then
'判断实体是否模型空间、图纸空间和匿名块
If StrComp(Left(objSelect.Name, 1), "*") <> 0 Then
'获得块参照名
strTemp = objSelect.Name
Else
MsgBox "您选择的是匿名块，请重新选择块参照！", vbCritical
'显示对话框
frmBatchPlot.Show
Exit Sub
End If
Else
MsgBox "您选择的不是块参照，请重新选择块参照！", vbCritical
'显示对话框
frmBatchPlot.Show
Exit Sub
End If
'刷新块参照列表
Call ListBlock
'将所选块参照在组合框中置为当前
Call SetSelected(cboBlockName, strTemp)
Else
'判断实体是否多段线
If TypeOf objSelect Is AcadLWPolyline Then
'获得多段线所在图层名
strTemp = objSelect.Layer
Else
MsgBox "您选择的不是轻量多段线，请重新选择轻量多段线！", vbCritical
'显示对话框
frmBatchPlot.Show
Exit Sub
End If
' 刷新图层列表
Call ListLayer
'将所选实体所在图层在组合框中置为当前
Call SetSelected(cboLayerName, strTemp)
End If
'显示对话框
frmBatchPlot.Show
End Sub
Private Sub SetSelected(ListObject As Object, SItem As String)
'将该元素在组合框中置为当前
Dim i As Long
'通过比较确定该元素的位置
For i = 0 To (ListObject.ListCount - 1)
If StrComp(ListObject.List(i), SItem, vbTextCompare) = 0 Then
ListObject.ListIndex = i
Exit Sub
End If
Next
End Sub
Private Sub cmdPreview_Click()
'若按图块进行批量打印
If optBlock.Value = True Then
If cboBlockName.ListCount = 0 Or cboBlockName.Text = "" Then
MsgBox "请先选择块参照！", vbCritical
Exit Sub
End If
Call PreviewByBlock(cboBlockName.Text)
'若按图层进行批量打印
Else
If cboLayerName.ListCount = 0 Or cboLayerName.Text = "" Then
MsgBox "请先选择块参照！", vbCritical
Exit Sub
End If
Call PreviewByLayer(cboLayerName.Text)
End If
End Sub
Private Sub cmdRefresh_Click()
'刷新块参照列表
Call ListBlock
' 刷新图层列表
Call ListLayer
End Sub
Private Sub cmdPlot_Click()
'若按图块进行批量打印
If optBlock.Value = True Then
If cboBlockName.ListCount = 0 Or cboBlockName.Text = "" Then
MsgBox "请先选择块参照！", vbCritical
Exit Sub
End If
Call BatchPlotByBlock(cboBlockName.Text)
'若按图层进行批量打印
Else
If cboLayerName.ListCount = 0 Or cboLayerName.Text = "" Then
MsgBox "请先选择块参照！", vbCritical
Exit Sub
End If
Call BatchPlotByLayer(cboLayerName.Text)
End If
End Sub
Private Sub cmdAbout_Click()
'显示关于对话框
frmAbout.Show
End Sub
Private Sub optBlock_Change()
'设置“图块与图层”组各控件激活状态
If optBlock.Value = True Then
lbBlockName.Enabled = True
cboBlockName.Enabled = True
lbLayerName.Enabled = False
cboLayerName.Enabled = False
Else
lbBlockName.Enabled = False
cboBlockName.Enabled = False
lbLayerName.Enabled = True
cboLayerName.Enabled = True
End If
End Sub
Private Sub optLayer_Change()
'设置“图块与图层”组各控件激活状态
If optBlock.Value = True Then
lbBlockName.Enabled = True
cboBlockName.Enabled = True
lbLayerName.Enabled = False
cboLayerName.Enabled = False
Else
lbBlockName.Enabled = False
cboBlockName.Enabled = False
lbLayerName.Enabled = True
cboLayerName.Enabled = True
End If
End Sub
Private Sub optMillimeters_Change()
' 设置图纸单位
If optMillimeters.Value = True Then
objLayout.PaperUnits = acMillimeters
lbUnit.Caption = "毫米 ＝"
lbUnitX.Caption = "毫米"
lbUnitY.Caption = "毫米"
lbPaperUnit.Caption = "毫米"
Else
objLayout.PaperUnits = acInches
lbUnit.Caption = "英寸 ＝"
lbUnitX.Caption = "英寸"
lbUnitY.Caption = "英寸"
lbPaperUnit.Caption = "英寸"
End If
' 显示图纸尺寸
Call SetPlotZone
End Sub
Private Sub OptVertical_Change()
' 设置图纸打印方向
Call PaperRotationChange
End Sub
Private Sub spnAngle_SpinDown()
If CInt(txtNumber.Text) > 1 Then
txtNumber.Text = CInt(txtNumber.Text) - 1
End If
End Sub
Private Sub spnAngle_SpinUp()
txtNumber.Text = CInt(txtNumber.Text) + 1
End Sub
Private Sub txtCurPath_Change()
'查找文件，向列表框中添加
If Len(Dir(txtCurPath.Text)) > 0 Then
FindFile colDwgs, txtCurPath.Text, "dwg"
If AddToList(lstCurFiles, colDwgs) Then
End If
End If
End Sub
Private Sub txtDenominator_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
' 设置自定义图纸尺寸
If IsNumeric(txtDenominator) Then
'设置组合框显示项目为“自定义”
cboPlotScale.ListIndex = 0
Else
MsgBox "请输入数字！", vbCritical
End If
End Sub
Private Sub txtNumber_Change()
' 设置图纸打印份数
'objPlot.NumberOfCopies = CDbl(txtNumber.Text)
'objPlot.NumberOfCopies = CInt(txtNumber.Text)
objPlot.NumberOfCopies = txtNumber.Value
End Sub
Private Sub txtNumerator_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
' 设置自定义图纸尺寸
If IsNumeric(txtNumerator) Then
'设置组合框显示项目为“自定义”
cboPlotScale.ListIndex = 0
Else
MsgBox "请输入数字！", vbCritical
End If
End Sub
Private Sub txtOffsetX_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
' 设置自定义图纸尺寸
If (KeyAscii >= Asc("0") And KeyAscii <= Asc("9")) Or KeyAscii = Asc(".") Or KeyAscii = Asc("-") Then
'取消“居中打印”复选框
chkCenterPlot.Value = False
Else
MsgBox "请输入数字！", vbCritical
End If
End Sub
Private Sub txtOffsetY_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
' 设置自定义图纸尺寸
If (KeyAscii >= Asc("0") And KeyAscii <= Asc("9")) Or KeyAscii = Asc(".") Or KeyAscii = Asc("-") Then
'取消“居中打印”复选框
chkCenterPlot.Value = False
Else
MsgBox "请输入数字！", vbCritical
End If
End Sub
Private Sub UserForm_Initialize()
Set objDoc = ThisDrawing.Application.ActiveDocument
Set objLayout = ThisDrawing.ActiveLayout
Set objPlot = ThisDrawing.Plot
'禁用“当前路径”文本框
txtCurPath.Enabled = False
'列出当前所有打印机
Call ListPrinters
' 显示AutoCAD中当前可用的打印比例列表
Call ListPlotScale
'设置“打印到文件”是否选中
chkPlotToFile.Value = False
'禁用“打印到文件”组各控件
lbPlotPath.Enabled = False
cboPlotPath.Enabled = False
cmdBrowse2.Enabled = False
' 显示AutoCAD中当前可用的图块
Call ListBlock
' 显示AutoCAD中当前可用的图层
Call ListLayer
End Sub
Public Function ReturnFolder(lngHwnd As Long) As String
Dim Browser As BrowseInfo
Dim lngFolder As Long
Dim strPath As String
Dim strTemp As String
With Browser
.hOwner = lngHwnd
.lpszTitle = "选择工作路径"
.pszDisplayName = String(MAX_PATH, 0)
End With
'用空格填充字符串
strPath = String(MAX_PATH, 0)
'调用API函数显示文件夹列表
lngFolder = SHBrowseForFolder(Browser)
'使用API函数获取返回的路径
If lngFolder Then
SHGetPathFromIDList lngFolder, strPath
strTemp = Left(strPath, InStr(strPath, vbNullChar) - 1)
If (Right(strTemp, 1) <> "\") Then
strTemp = strTemp & "\"
End If
ReturnFolder = strTemp
End If
End Function
Public Sub FindFile(ByRef files As Collection, strDir, strExt)
'删除集合中所有的对象
Dim i As Integer
For i = 1 To files.count
files.Remove 1
Next i
'查找dwg文件，并将其添加到集合中
Dim strFileName As String
If (Right(strDir, 1) <> "\") Then
strDir = strDir & "\"
End If
strFileName = Dir(strDir & "*.*", vbDirectory)
Do While (strFileName <> "")
If (UCase(Right(strFileName, 3)) = UCase(strExt)) Then
files.Add strDir & strFileName
End If
strFileName = Dir '返回下一个符合条件的文件
Loop
End Sub
Public Function AddToList(objBox As ListBox, Names As Collection) As Boolean
Dim i As Integer
On Error GoTo Error_Control
objBox.Clear
'将集合中的对象添加到列表框中
For i = 1 To Names.count
objBox.AddItem Names(i)
Next i
Exit_Here:
AddToList = True
Exit Function
Error_Control:
MsgBox "发生下面的错误：" & Err.Number
AddToList = False
End Function
Private Function HasItem(objBox As ListBox, strFlies As String) As Boolean
'检查路径是否已经存在
HasItem = False
Dim i As Integer
If objBox.ListCount > 0 Then
For i = 0 To objBox.ListCount - 1
If StrComp(objBox.List(i), strFlies, vbTextCompare) = 0 Then
HasItem = True
Exit Function
End If
Next i
End If
End Function
Private Function HasItem2(ByVal strPath As String) As Integer
'检查路径是否已经存在
HasItem2 = -1
Dim i As Integer
If cboPlotPath.ListCount > 0 Then
For i = 0 To cboPlotPath.ListCount - 1
If StrComp(cboPlotPath.List(i), strPath, vbTextCompare) = 0 Then
HasItem2 = i
Exit Function
End If
Next i
End If
End Function
'打开或激活文件
Private Sub OpenFile(fileName As String)
Dim dwgFile As AcadDocument
Dim strFile As String
For Each dwgFile In ThisDrawing.Application.Documents
strFile = dwgFile.Path & "\" & dwgFile.Name
'若第i个图形文件已经被打开，则将其激活
If strFile = fileName Then
'若dwgFile尚未激活，则将其激活
If dwgFile.Active = False Then
ThisDrawing.Application.ActiveDocument = dwgFile
End If
Exit Sub
End If
Next
'若第i个图形文件尚未被打开，则将其打开
ThisDrawing.Application.Documents.Open fileName
End Sub
' 显示AutoCAD中当前可用的打印机列表
Public Sub ListPrinters()
objLayout.RefreshPlotDeviceInfo
' 获得所有的可用打印机
Dim plotDevices As Variant
plotDevices = objLayout.GetPlotDeviceNames
' 删除以前的打印机列表
cboPrintersName.Clear
' 显示打印机列表
Dim i As Integer
For i = 0 To UBound(plotDevices)
cboPrintersName.AddItem (plotDevices(i))
Next i
' 设置组合框初始选项
With cboPrintersName
'使用下拉列表的形式
.Style = fmStyleDropDownList
'设置下拉列表的下标下限
.BoundColumn = 0
'设置默认的显示项目
.ListIndex = 1
End With
End Sub
' 显示AutoCAD中当前可用的打印样式
Public Sub ListPlotStyleTableNames()
Set objLayout = ThisDrawing.ActiveLayout
objLayout.RefreshPlotDeviceInfo
' 获得所有的可用打印样式
Dim plotStyleTables As Variant
plotStyleTables = objLayout.GetPlotStyleTableNames
' 删除以前的打印样式列表
cboPlotStyleTableNames.Clear
' 显打印样式列表
Dim i As Integer
For i = 0 To UBound(plotStyleTables)
cboPlotStyleTableNames.AddItem (plotStyleTables(i))
Next i
' 设置组合框初始选项
With cboPlotStyleTableNames
'使用下拉列表的形式
.Style = fmStyleDropDownList
'设置下拉列表的下标下限
.BoundColumn = 0
'设置默认的显示项目
.ListIndex = 0
End With
End Sub
' 显示AutoCAD中当前可用的图纸尺寸
Public Sub ListPaperSize()
objLayout.RefreshPlotDeviceInfo
' 获得所有当前可用可用图纸尺寸列表
Dim paperSizes As Variant
paperSizes = objLayout.GetCanonicalMediaNames
' 删除以前的图纸尺寸列表
cboPaperSize.Clear
' 显示图纸尺寸列表
Dim i As Integer
For i = 0 To UBound(paperSizes)
cboPaperSize.AddItem (paperSizes(i))
Next i
' 设置组合框初始选项
With cboPaperSize
'使用下拉列表的形式
.Style = fmStyleDropDownList
'设置下拉列表的下标下限
.BoundColumn = 0
'设置默认的显示项目
.ListIndex = 0
End With
End Sub
' 显示AutoCAD中可以使用的打印比例
Public Sub ListPlotScale()
' 显打印比例列表
With cboPlotScale
.AddItem ("自定义"), 0
.AddItem ("按图纸空间缩放"), 1
.AddItem ("1:1"), 2
.AddItem ("1:2"), 3
.AddItem ("1:4"), 4
.AddItem ("1:8"), 5
.AddItem ("1:10"), 6
.AddItem ("1:16"), 7
.AddItem ("1:20"), 8
.AddItem ("1:30"), 9
.AddItem ("1:40"), 10
.AddItem ("1:50"), 11
.AddItem ("1:100"), 12
.AddItem ("2:1"), 13
.AddItem ("4:1"), 14
.AddItem ("8:1"), 15
.AddItem ("10:1"), 16
.AddItem ("100:1"), 17
'使用下拉列表的形式
.Style = fmStyleDropDownList
'设置下拉列表的下标下限
.BoundColumn = 0
'设置默认的显示项目
.ListIndex = 2
End With
txtNumerator = 1
txtDenominator = 1
End Sub
' 显示AutoCAD中当前可用的图层
Public Sub ListLayer()
Dim LayerList As Collection
'获得图形中存在的图层列表
Set LayerList = GetLayerList()
'刷新图层列表
Call RefreshList(cboLayerName, LayerList)
'选择图层列表中的第一个实体
If cboLayerName.ListIndex = -1 Then
cboLayerName.ListIndex = 0
End If
End Sub
'获得图形中存在的图层列表
Private Function GetLayerList() As Collection
Dim objLayer As AcadLayer
Dim LayerList As New Collection
Set objDoc = ThisDrawing.Application.ActiveDocument
'获得可用的图层
For Each objLayer In objDoc.Layers
LayerList.Add objLayer.Name, objLayer.Name
Next
'返回图形中块参照的列表
Set GetLayerList = LayerList
End Function
' 显示AutoCAD中当前可用的图块
Public Sub ListBlock()
Dim BlockReferenceList As Collection
'获得图形中存在的块参照列表
Set BlockReferenceList = GetBlockReferences()
'判断是否存在块参照
If BlockReferenceList Is Nothing Then
MsgBox "当前图形中不存在任何的块！", vbExclamation
Exit Sub
End If
'刷新块参照列表
Call RefreshList(cboBlockName, BlockReferenceList)
'选择块参照列表中的第一个实体
If cboBlockName.ListIndex = -1 Then
cboBlockName.ListIndex = 0
End If
End Sub
'获得图形中存在的块参照列表
Private Function GetBlockReferences() As Collection
Dim BlockList As New Collection
Dim AcadObject As AcadEntity
Set objDoc = ThisDrawing.Application.ActiveDocument
'获得可用的块参照
For Each AcadObject In objDoc.ModelSpace
If AcadObject.ObjectName = "AcDbBlockReference" Then
'不将模型空间、图纸空间和匿名块添加到组合框中
If StrComp(Left(AcadObject.Name, 1), "*") <> 0 Then
On Error Resume Next
BlockList.Add AcadObject.Name, AcadObject.Name
End If
End If
Next
'返回图形中块参照的列表
If BlockList.count > 0 Then
Set GetBlockReferences = BlockList
Else
Set GetBlockReferences = Nothing
End If
End Function
'将组合对象中的元素写入列表框或组合框中
Private Sub RefreshList(ByRef ListObject As Object, ByRef BlockList As Collection)
Dim i As Long
'清空列表框
ListObject.Clear
'向列表框中添加新的元素
For i = 1 To BlockList.count
AddSorted ListObject, BlockList(i)
Next
End Sub
Private Sub AddSorted(ListObject As Object, SItem As String)
'将元素添加到组合框或列表框中，并且排序
Dim i As Long
'元素数目小于1，不进行排序
If ListObject.ListCount = 0 Then
ListObject.AddItem SItem
Exit Sub
End If
'通过比较确定该元素的位置，类似于插入排序法
For i = 0 To (ListObject.ListCount - 1)
If StrComp(ListObject.List(i), SItem, vbTextCompare) = 1 Then
ListObject.AddItem SItem, i
Exit Sub
End If
Next
'添加到列表框的最后
ListObject.AddItem SItem
End Sub
Public Sub PaperRotationChange()
' 设置图纸打印方向
If optVertical.Value = True Then
If chkReverse.Value = False Then
objLayout.PlotRotation = ac0degrees
Else
objLayout.PlotRotation = ac180degrees
End If
Else
If chkReverse.Value = False Then
objLayout.PlotRotation = ac90degrees
Else
objLayout.PlotRotation = ac270degrees
End If
End If
' 显示图纸大小
Call SetPlotZone
End Sub
' 设置图纸可打印区域大小
Public Sub SetPlotZone()
Dim Width As Double, Height As Double, t As Double
' 获得图纸大小
objLayout.GetPaperSize Width, Height
'图形方向为“横向”时宽高互调
If optVertical.Value = False Then
t = Width
Width = Height
Height = t
End If
'单位由“毫米”转换为“英寸”
If optMillimeters.Value = False Then
Width = Width / 25.393
Height = Height / 25.393
End If
' 显示图纸大小
lbPaperSize.Caption = Round(Width, 2) & " × " & Round(Height, 2)
End Sub
Private Sub OutputData(objBox As ComboBox, nFile As Integer)
Dim i As Integer, count As Integer, index As Integer
'获得组合框列表数目
count = objBox.ListCount
'获得组合框当前选项的的索引号
index = objBox.ListIndex
'输出组合框列表数目
Write #nFile, count
'输出组合框当前选项的的索引号
Write #nFile, index
'输出所有的组合框选项
For i = 0 To count - 1
Print #nFile, objBox.List(i)
Next
End Sub
Private Sub OutputData2(objBox As CheckBox, nFile As Integer)
Dim strTemp As String
'输出复选框选中状态
If objBox.Value = True Then
strTemp = "是"
Else
strTemp = "否"
End If
Print #nFile, strTemp
End Sub
Private Sub OutputData3(objBox As ListBox, nFile As Integer)
Dim i As Integer, count As Integer, index As Integer
'获得列表框列表数目
count = objBox.ListCount
'获得列表框当前选项的的索引号
index = objBox.ListIndex
'输出列表框列表数目
Write #nFile, count
'输出列表框当前选项的的索引号
Write #nFile, index
'输出所有的列表框选项
For i = 0 To count - 1
Print #nFile, objBox.List(i)
Next
End Sub
Private Sub InputData(objBox As ComboBox, nFile As Integer)
Dim i As Integer, count As Integer, index As Integer
Dim strTemp As String
'读入一行文本并存储在变量中
Line Input #nFile, strTemp
'读入组合框列表数目
Input #nFile, count
'读入组合框当前元素的的索引号
Input #nFile, index
'清空组合框所有元素
objBox.Clear
'读入组合框元素
For i = 0 To count - 1
Line Input #nFile, strTemp
'将读入的列表添加到组合框中
objBox.AddItem strTemp
Next
' 设置组合框初始选项
With objBox
'使用下拉列表的形式
.Style = fmStyleDropDownList
'设置下拉列表的下标下限
.BoundColumn = 0
'设置默认的显示项目
.ListIndex = index
End With
End Sub
Private Sub InputData2(objBox As CheckBox, nFile As Integer)
Dim strTemp As String
'读入一行文本并存储在变量中
Line Input #nFile, strTemp
'读入复选框选中状态
Input #nFile, strTemp
'设置复选按钮选择状态
If strTemp = "是" Then
objBox.Value = True
Else
objBox.Value = False
End If
End Sub
Private Sub InputData3(objBox As ListBox, nFile As Integer)
Dim i As Integer, count As Integer, index As Integer
Dim strTemp As String
'读入一行文本并存储在变量中
Line Input #nFile, strTemp
'读入列表框列表数目
Input #nFile, count
'读入列表框当前元素的的索引号
Input #nFile, index
'清空列表框所有元素
objBox.Clear
'读入列表框元素
For i = 0 To count - 1
Line Input #nFile, strTemp
'将读入的列表添加到列表框中
objBox.AddItem strTemp
Next
' 设置组合框初始选项
With objBox
'设置下拉列表的下标下限
.BoundColumn = 0
'设置默认的显示项目
.ListIndex = index
End With
End Sub
Public Sub SetPrinter()
' 设置打印机配置
objLayout.ConfigName = cboPrintersName.Text
' 设置打印样式表
objLayout.StyleSheet = cboPlotStyleTableNames.Text
' 设置图纸尺寸
objLayout.CanonicalMediaName = cboPaperSize.Text
' 设置图纸单位
If optMillimeters.Value = True Then
objLayout.PaperUnits = acMillimeters
Else
objLayout.PaperUnits = acInches
End If
' 设置图纸打印方向
If optVertical.Value = True Then
If chkReverse.Value = False Then
objLayout.PlotRotation = ac0degrees
Else
objLayout.PlotRotation = ac180degrees
End If
Else
If chkReverse.Value = False Then
objLayout.PlotRotation = ac90degrees
Else
objLayout.PlotRotation = ac270degrees
End If
End If
' 设置图纸打印比例
If cboPlotScale.Value Then
objLayout.UseStandardScale = True '使用标准打印比例
Else
objLayout.UseStandardScale = False '使用自定义打印比例
End If
Select Case cboPlotScale.Value
Case 0
'设置自定义打印比例
objLayout.SetCustomScale txtNumerator.Value, txtDenominator.Value
Case 1
objLayout.StandardScale = acScaleToFit
Case 2
objLayout.StandardScale = ac1_1
Case 3
objLayout.StandardScale = ac1_2
Case 4
objLayout.StandardScale = ac1_4
Case 5
objLayout.StandardScale = ac1_8
Case 6
objLayout.StandardScale = ac1_10
Case 7
objLayout.StandardScale = ac1_16
Case 8
objLayout.StandardScale = ac1_20
Case 9
objLayout.StandardScale = ac1_30
Case 10
objLayout.StandardScale = ac1_40
Case 11
objLayout.StandardScale = ac1_50
Case 12
objLayout.StandardScale = ac1_100
Case 13
objLayout.StandardScale = ac2_1
Case 14
objLayout.StandardScale = ac4_1
Case 15
objLayout.StandardScale = ac8_1
Case 16
objLayout.StandardScale = ac10_1
Case 17
objLayout.StandardScale = ac100_1
End Select
' 设置图纸是否居中打印
If chkCenterPlot.Value Then
objLayout.CenterPlot = True
Else
' 设置自定义打印偏移
Dim PtOffset(0 To 1) As Double
PtOffset(0) = txtOffsetX.Value
PtOffset(1) = txtOffsetY.Value
objLayout.CenterPlot = False
objLayout.PlotOrigin = PtOffset
End If
'设置是否打印对象线宽
If chkPlotWithLineweights.Enabled = True Then
If chkPlotWithLineweights.Value Then
'打印时使用图形文件中的线宽
objLayout.PlotWithLineweights = True
Else
'打印时使用打印样式中的线宽
objLayout.PlotWithLineweights = False
End If
End If
'设置是否应用打印样式
If chkPlotWithPlotStyles.Value Then
'打印时在对象中使用打印样式
objLayout.PlotWithPlotStyles = True
chkPlotWithLineweights.Enabled = False
Else
'打印时在对象中不使用打印样式
objLayout.PlotWithPlotStyles = False
chkPlotWithLineweights.Enabled = True
End If
If chkPlotHidden.Enabled = True Then
'设置是否隐藏图纸空间对象
If chkPlotHidden.Value Then
'打印时隐藏图纸空间对象
objLayout.PlotHidden = True
Else
'打印时不隐藏图纸空间对象
objLayout.PlotHidden = False
End If
End If
' 设置打印类型（对应AutoCAD中：打印>打印设置>打印区域>窗口）
objLayout.PlotType = acWindow
' 设置图纸打印份数
objPlot.NumberOfCopies = txtNumber.Value
' 将打印错误报告切换为静默错误模式，以便不间断地执行打印任务
objPlot.QuietErrorMode = True
End Sub
Private Sub BatchPlotByBlock(strBlockReferenceName As String)
On Error Resume Next
'如果列表框中未存在任何元素
If lstPlotFiles.ListCount = 0 Then
MsgBox "请先向列表框中添加文件！", vbCritical
Exit Sub
End If
'将控制权交给AutoCAD
frmBatchPlot.Hide
' 对第i个图形的每一个打印区域进行打印
Dim ptMin As Variant, ptMax As Variant
Dim ent As AcadEntity
Dim i As Integer, n As Integer
For i = 0 To lstPlotFiles.ListCount - 1
n = 1
'检查文件是否存在
If Len(Dir(lstPlotFiles.List(i))) = 0 Then
MsgBox "文件" & lstPlotFiles.List(i) & "不存在！"
End If
'打开或激活第i个图形文件
Call OpenFile(lstPlotFiles.List(i))
Set objDoc = ThisDrawing.Application.ActiveDocument
'实现范围缩放
ThisDrawing.Application.ZoomExtents
' 确保当前布局是模型空间
Set objLayout = objDoc.Layouts.Item("Model")
Set objPlot = objDoc.Plot
' 设置打印选项
Call SetPrinter
'重新生成当前图形
objDoc.Regen acAllViewports
' 确保AutoCAD在前台进行打印，这样后一次打印会在前一次打印完成之后才开始
' 避免出现错误
objDoc.SetVariable "BACKGROUNDPLOT", 0
'对当前图形模型空间中的所有打印区域进行打印
For Each ent In objDoc.ModelSpace
If TypeOf ent Is AcadBlockReference Then
If StrComp(ent.Name, strBlockReferenceName, vbTextCompare) = 0 Then
ent.GetBoundingBox ptMin, ptMax
' 将三维点转化为二维点坐标
ReDim Preserve ptMin(0 To 1)
ReDim Preserve ptMax(0 To 1)
' 设置打印窗口
objLayout.SetWindowToPlot ptMin, ptMax
' 打印当前的区域
'若选中“打印到文件”
If chkPlotToFile.Value Then
objPlot.PlotToFile cboPlotPath.Text & objDoc.Name & "-" & n & ".dwf"
n = n + 1
Else
objPlot.PlotToDevice objLayout.ConfigName
End If
End If
End If
Next ent
' 恢复系统变量的值
objDoc.SetVariable "BACKGROUNDPLOT", 2
'保存当前图形
'objDoc.Save
'关闭但不保存当前图形
'保证至少一个文件打开
If ThisDrawing.Application.Documents.count > 1 Then
objDoc.Close False
End If
Next i
'显示对话框
frmBatchPlot.Show
End Sub
Private Sub BatchPlotByLayer(strLayerName As String)
On Error Resume Next
'如果列表框中未存在任何元素
If lstPlotFiles.ListCount = 0 Then
MsgBox "请先向列表框中添加文件！", vbCritical
Exit Sub
End If
'将控制权交给AutoCAD
frmBatchPlot.Hide
' 对第i个图形的每一个打印区域进行打印
Dim ptMin As Variant, ptMax As Variant
Dim ent As AcadEntity
Dim i As Integer, n As Integer
For i = 0 To lstPlotFiles.ListCount - 1
n = 1
'检查文件是否存在
If Len(Dir(lstPlotFiles.List(i))) = 0 Then
MsgBox "文件" & lstPlotFiles.List(i) & "不存在！"
End If
'打开或激活第i个图形文件
Call OpenFile(lstPlotFiles.List(i))
Set objDoc = ThisDrawing.Application.ActiveDocument
'实现范围缩放
ThisDrawing.Application.ZoomExtents
' 确保当前布局是模型空间
Set objLayout = objDoc.Layouts.Item("Model")
Set objPlot = objDoc.Plot
' 设置打印选项
Call SetPrinter
'重新生成当前图形
objDoc.Regen acAllViewports
' 确保AutoCAD在前台进行打印，这样后一次打印会在前一次打印完成之后才开始
' 避免出现错误
objDoc.SetVariable "BACKGROUNDPLOT", 0
'对当前图形模型空间中的所有打印区域进行打印
For Each ent In objDoc.ModelSpace
If StrComp(ent.Layer, strLayerName, vbTextCompare) = 0 Then
If TypeOf ent Is AcadLWPolyline Then
ent.GetBoundingBox ptMin, ptMax
' 将三维点转化为二维点坐标
ReDim Preserve ptMin(0 To 1)
ReDim Preserve ptMax(0 To 1)
' 设置打印窗口
objLayout.SetWindowToPlot ptMin, ptMax
' 打印当前的区域
'若选中“打印到文件”
If chkPlotToFile.Value Then
objPlot.PlotToFile cboPlotPath.Text & objDoc.Name & "-" & n & ".dwf"
n = n + 1
Else
objPlot.PlotToDevice objLayout.ConfigName
End If
End If
End If
Next ent
' 恢复系统变量的值
objDoc.SetVariable "BACKGROUNDPLOT", 2
'保存当前图形
'objDoc.Save
'关闭但不保存当前图形
'保证至少一个文件打开
If ThisDrawing.Application.Documents.count > 1 Then
objDoc.Close False
End If
Next i
'显示对话框
frmBatchPlot.Show
End Sub
Private Sub PreviewByBlock(strBlockReferenceName As String)
'如果列表框中未存在任何元素
If lstPlotFiles.ListCount = 0 Then
MsgBox "请先向列表框中添加文件！", vbCritical
Exit Sub
End If
'将控制权交给AutoCAD
frmBatchPlot.Hide
' 对第一个图形的第一个打印区域进行完全预览
Dim ptMin As Variant, ptMax As Variant
Dim ent As AcadEntity
Dim i As Integer, n As Integer
For i = 0 To lstPlotFiles.ListCount - 1
n = 1
'检查文件是否存在
If Len(Dir(lstPlotFiles.List(i))) = 0 Then
MsgBox "文件" & lstPlotFiles.List(i) & "不存在！"
End If
'打开或激活第i个图形文件
Call OpenFile(lstPlotFiles.List(i))
Set objDoc = ThisDrawing.Application.ActiveDocument
'实现范围缩放
ThisDrawing.Application.ZoomExtents
' 确保当前布局是模型空间
Set objLayout = objDoc.Layouts.Item("Model")
Set objPlot = objDoc.Plot
' 设置打印选项
Call SetPrinter
'重新生成当前图形
objDoc.Regen acAllViewports
' 确保AutoCAD在前台进行打印，这样后一次打印会在前一次打印完成之后才开始
' 避免出现错误
'ThisDrawing.SetVariable "BACKGROUNDPLOT", 0
'对当前图形模型空间中的所有打印区域进行打印
For Each ent In objDoc.ModelSpace
If TypeOf ent Is AcadBlockReference Then
If StrComp(ent.Name, strBlockReferenceName, vbTextCompare) = 0 Then
ent.GetBoundingBox ptMin, ptMax
' 将三维点转化为二维点坐标
ReDim Preserve ptMin(0 To 1)
ReDim Preserve ptMax(0 To 1)
' 设置打印窗口
ThisDrawing.ActiveLayout.SetWindowToPlot ptMin, ptMax
'完全预览当前的区域
objPlot.DisplayPlotPreview acFullPreview
n = n + 1
If n > 1 Then
'显示对话框
frmBatchPlot.Show
Exit Sub
End If
End If
End If
Next ent
'保存当前图形
'objDoc.Save
'关闭但不保存当前图形
'保证至少一个文件打开
If ThisDrawing.Application.Documents.count > 1 Then
objDoc.Close False
End If
Next i
End Sub
Private Sub PreviewByLayer(strLayerName As String)
'如果列表框中未存在任何元素
If lstPlotFiles.ListCount = 0 Then
MsgBox "请先向列表框中添加文件！", vbCritical
Exit Sub
End If
'将控制权交给AutoCAD
frmBatchPlot.Hide
' 对第一个图形的第一个打印区域进行完全预览
Dim ptMin As Variant, ptMax As Variant
Dim ent As AcadEntity
Dim i As Integer, n As Integer
For i = 0 To lstPlotFiles.ListCount - 1
n = 1
'检查文件是否存在
If Len(Dir(lstPlotFiles.List(i))) = 0 Then
MsgBox "文件" & lstPlotFiles.List(i) & "不存在！"
End If
'打开或激活第i个图形文件
Call OpenFile(lstPlotFiles.List(i))
Set objDoc = ThisDrawing.Application.ActiveDocument
'实现范围缩放
ThisDrawing.Application.ZoomExtents
' 确保当前布局是模型空间
Set objLayout = objDoc.Layouts.Item("Model")
Set objPlot = objDoc.Plot
' 设置打印选项
Call SetPrinter
'重新生成当前图形
objDoc.Regen acAllViewports
' 确保AutoCAD在前台进行打印，这样后一次打印会在前一次打印完成之后才开始
' 避免出现错误
'ThisDrawing.SetVariable "BACKGROUNDPLOT", 0
'对当前图形模型空间中的所有打印区域进行完全预览
For Each ent In ThisDrawing.ModelSpace
If StrComp(ent.Layer, strLayerName, vbTextCompare) = 0 Then
If TypeOf ent Is AcadLWPolyline Then
ent.GetBoundingBox ptMin, ptMax
' 将三维点转化为二维点坐标
ReDim Preserve ptMin(0 To 1)
ReDim Preserve ptMax(0 To 1)
' 设置打印窗口
ThisDrawing.ActiveLayout.SetWindowToPlot ptMin, ptMax
'完全预览当前的区域
objPlot.DisplayPlotPreview acFullPreview
n = n + 1
If n > 1 Then
'显示对话框
frmBatchPlot.Show
Exit Sub
End If
End If
End If
Next ent
'保存当前图形
'objDoc.Save
'关闭但不保存当前图形
'保证至少一个文件打开
If ThisDrawing.Application.Documents.count > 1 Then
objDoc.Close False
End If
Next i
End Sub
| 
[复制链接]
发表于 2006-11-28 22:07
置顶卡
变色卡
显身卡
楼主
发表于 2006-11-29 09:13