'**********************************************************************************************
'文字双下划线************************************************************************************
'   调 BuildFilter
Sub Text_SXHX()

    Dim M1  As Variant, M2  As Variant, M3(0 To 2) As Double
    Dim A As Double
    Dim SelectedObj As AcadSelectionSet
    
    On Error Resume Next
    
    Set SelectedObj = CreateSelectionSet("xxx")
    Dim FType, FData
    
    BuildFilter FType, FData, 0, "text"

    SelectedObj.SelectOnScreen FType, FData

    ActiveDocument.Utility.Prompt "共选择文本：" & SelectedObj.Count & "个" & vbCrLf
    
    For i = 0 To SelectedObj.Count - 1
        
        Dim TEXT As AcadText
        Set TEXT = SelectedObj.item(i)
        A = TEXT.Rotation                                                   '现获得文字角度
        TEXT.Rotate TEXT.insertionPoint, -A                          '将文字旋转到水平方向
        
        TEXT.GetBoundingBox M1, M2                                  '得到文字两角点的坐标
        
        M3(0) = M2(0): M3(1) = M1(1): M3(2) = 0                 '计算矩形右下角点坐标
        
        TEXT.Rotate M1, A                                                  '将文字转回原位
        Dim L1 As AcadLine, L2 As AcadLine                           '文字双下划线
        
        Dim H As Double
        H = TEXT.height                                                     '返回文字高度，下划线间距参照此值
        M1(1) = M1(1) - 0.05 * H                                         '第一道下划线距文字最下端0.05H
        M3(1) = M1(1)

        Set L1 = ThisDrawing.ModelSpace.AddLine(M1, M3)      '水平方向的下划线
        L1.Rotate M1, A                                                       '将单下划线旋转到文字下方。
        L1.color = acGreen
        L1.Lineweight = acLnWt050                                      '第一道线宽为0.5mm
        
        M1(1) = M1(1) - 0.15 * H                                          '第二道线和第一道线间距0.15H
        M3(1) = M1(1)

        Set L2 = ThisDrawing.ModelSpace.AddLine(M1, M3)
        L2.Rotate M1, A                                                      '将下划线旋转到文字下方。
        L2.color = acGreen
   
    Next i
    SelectedObj.Delete
End Sub

'***********************************************************************************************
'选择集过滤器************************************************************************************
'       这个过滤器也是引用别人的，说实话我也没有看懂。
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) '改变数组上线，用可选参数preserve保持原数组不变。
        ReDim Preserve FData(0 To Index)
        FType(Index) = CInt(gCodes(i))
        FData(Index) = gCodes(i + 1)
    Next
    typeArray = FType: dataArray = FData
    
End Sub