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