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