这是一个调整全局比例的源码,看看改改
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:
这来了,^_^