文本旋转
**** Hidden Message ***** 现在没有时间把它弄得很漂亮，也许在午餐的时候，但是这个Option Explicit
Public Sub FIX_ROTATION()
Dim objSelected As Object
Dim objTxt As AcadText
Dim objMTxt As AcadMText
Dim objSelSet As AcadSelectionSet
Dim dblRotDec As Double
Dim dblRotRad As Double
On Error GoTo ErrControl
Dim N As Integer
Dim pi
pi = 4 * Atn(1)
If ThisDrawing.SelectionSets.Count > 0 Then
For N = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(N).Name = "FIXTEXT" Then
ThisDrawing.SelectionSets("FIXTEXT").Delete
End If
Next N
End If
Set objSelSet = ThisDrawing.SelectionSets.Add("FIXTEXT")
objSelSet.SelectOnScreen
'objSelSet.Select acSelectionSetAll
For Each objSelected In objSelSet
If TypeOf objSelected Is AcadText Then
Set objTxt = objSelected
dblRotRad = objTxt.Rotation
dblRotDec = (dblRotRad * 180) / pi
If dblRotDec > 180 Then
dblRotDec = dblRotDec - 180
End If
If dblRotDec > 45 And dblRotDec0 Then
For Each objSelSet In ThisDrawing.SelectionSets
If objSelSet.Name = "FIXTEXT" Then
objSelSet.Delete
Exit For
End If
Next objSelSet
End If
intGrp(0) = -4: intGrp(1) = 0: intGrp(2) = 0: intGrp(3) = -4
varDat(0) = ""
Set objSelSet = ThisDrawing.SelectionSets.Add("FIXTEXT")
objSelSet.SelectOnScreen intGrp, varDat
For Each objSelected In objSelSet
If TypeOf objSelected Is AcadText Then
Set objTxt = objSelected
dblRot = objTxt.Rotation
objTxt.Rotation = Angulator(dblRot)
Else
Set objMTxt = objSelected
dblRot = objMTxt.Rotation
objMTxt.Rotation = Angulator(dblRot)
End If
Next
ThisDrawing.SelectionSets.Item("FIXTEXT").Delete
ThisDrawing.Application.Update
Exit_Here:
Exit Sub
ErrControl:
MsgBox Err.Description
ThisDrawing.SelectionSets.Item("FIXTEXT").Delete
End Sub
Function Angulator(dblRotRad As Double) As Double
Dim dblRotDec As Double
Dim PI As Double
PI = 4 * Atn(1)
dblRotDec = (dblRotRad * 180) / PI
If dblRotDec > 180 Then
dblRotDec = dblRotDec - 180
End If
If dblRotDec > 45 And dblRotDec < 135 Then
Angulator = (90 * PI) / 180
Else
Angulator = 0
End If
End Function
没问题。
页:
[1]