AutoCAD VBA文字自动对齐操作

AutoCAD VBA文字自动对齐，代码如下。

Public Type TextWithPnt
Index As Long
TextObj As AcadText
PntIntX As Double
PntIntY As Double
PntLeftX As Double
PntMidX As Double
PntRigX As Double
End Type
Public OrgTexts() As TextWithPnt
Public Function CreateSSet(Optional SS As String = "mjtd") As AcadSelectionSet
On Error Resume Next
ThisDrawing.SelectionSets(SS).Delete
Set CreateSSet = ThisDrawing.SelectionSets.Add(SS)
End Function
Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())
Dim fType() As Integer, fData()
Dim Index As Long, i As Long
Index = LBound(gCodes) - 1
For i = LBound(gCodes) To UBound(gCodes) Step 2
Index = Index + 1
ReDim Preserve fType(0 To Index)
ReDim Preserve fData(0 To Index)
fType(Index) = CInt(gCodes(i))
fData(Index) = gCodes(i + 1)
Next
End Sub
Public Function ssExtents(SS As AcadSelectionSet) As Variant
Dim Points(), C As Long
Dim Min As Variant, Max As Variant
Dim i As Long, j As Long
C = 0
For i = 0 To SS.count - 1
SS.Item(i).GetBoundingBox Min, Max
ReDim Preserve Points(0 To C + 1)
Points(C) = Min: Points(C + 1) = Max
C = C + 2
Next
ssExtents = Extents(Points)
End Function
Public Function Extents(Points)
Dim Min As Variant, Max As Variant
Dim i As Long, j As Long, Pt, RetVal(0 To 1)
Min = Points(LBound(Points))
Max = Points(LBound(Points))
For i = LBound(Points) To UBound(Points)
Pt = Points(i)
For j = LBound(Pt) To UBound(Pt)
If Pt(j) < Min(j) Then Min(j) = Pt(j)
If Pt(j) > Max(j) Then Max(j) = Pt(j)
Next
Next
RetVal(0) = Min: RetVal(1) = Max
Extents = RetVal
End Function

代码完。