这是一个调整全局比例的源码，看看改改
Sub scale_print()
Dim scalefactor As Double
Dim scaletype As Integer
scaletype = acZoomScaledRelativePSpace
Dim ssetObj As AcadSelectionSet
Dim aa As AcadObject
Dim text As Integer
Dim m1 As String
Dim l1 As String
Dim starttext As String
Dim dimstyless As AcadDimStyle
Dim styless As Boolean
Dim dim_s As Boolean
On Error GoTo ass:
For i = 0 To ThisDrawing.SelectionSets.count - 1
'If thisdrawing.SelectionSets.Item(i).Name = "TEST_SSET" Then
ThisDrawing.SelectionSets.Item(i).Delete
'End If
Next i
Dim abc As AcadDimAligned
'abc.StyleName
Set ssetObj = ThisDrawing.SelectionSets.add("TEST_SSET")
' Add entities to a selection set by prompting user to select on the screen
ssetObj.SelectOnScreen
'If ssetObj.count = 0 Then
'Exit Sub
'End If
text = ThisDrawing.Utility.GetInteger(vbCrLf & "输入一个比例:")
If text = 0 Then
Exit Sub
End If
For Each aa In ssetObj
'MsgBox aa.ObjectName
'MsgBox aa.scalefactor
'MsgBox aa.ScaleEntity
If aa.ObjectName = "AcDbRotatedDimension" Or aa.ObjectName = "AcDbAlignedDimension" Then
aa.scalefactor = text
End If
'If aa.ObjectName = "AcDbMText" Or aa.ObjectName = "AcDbText" Then
'aa.height = text / 30 * 80
'End If
Next
scalefactor = 1 / text
ZoomScaled scalefactor, scaletype
Exit Sub
ass:
If InStr(ThisDrawing.GetVariable("lastprompt"), "*取消*") Then
End
Else
Resume Next
End If
'thisdrawing.Utility.Prompt "小易提醒你，程序运行错误:" & Err.Description
End Sub
to yicol
For i = 0 To ThisDrawing.SelectionSets.count - 1
'If thisdrawing.SelectionSets.Item(i).Name = "TEST_SSET" Then
ThisDrawing.SelectionSets.Item(i).Delete
'End If
Next i
这里有误，你的程序一运行就跑到ass:
这来了，^_^
置顶卡
