（批量）让框格里的文本对齐_整理材料表

yrgui

Sub TText()
    Dim text As Variant
    Dim box As Variant
    Dim key As String
   
    Dim sSetText As AcadSelectionSet
    Dim sSetBox As AcadSelectionSet
   
    Dim tblp As Variant
    Dim ttrp As Variant
    Dim tcp(2) As Double
    Dim tmlp(2) As Double
    Dim bblp As Variant
    Dim btrp As Variant
    Dim bcp(2) As Double
    Dim bmlp(2) As Double
    Dim tnblp As Variant
    Dim tntrp As Variant
    Dim tncp(2) As Double
    Dim tnmlp(2) As Double
   
    Dim fType() As Integer
    Dim fData()
    ReDim fData(3)
    ReDim fType(3)
    fType(0) = -4: fData(0) = "<OR"
    fType(1) = 0: fData(1) = "TEXT"
    fType(2) = 0: fData(2) = "MTEXT"
    fType(3) = -4: fData(3) = "OR>"
   
    On Error Resume Next
    ThisDrawing.SelectionSets.Item("_Gas_Text").Delete
    ThisDrawing.SelectionSets.Item("_Gas_Box").Delete
    On Error GoTo 0
    Err.Clear
   
    Set sSetText = ThisDrawing.SelectionSets.Add("_Gas_Text")
    sSetText.SelectOnScreen fType, fData
   
    With ThisDrawing.Utility
        .InitializeUserInput 0, "M L"
        key = .GetKeyword(vbCr & "文本对齐于 [正中(M)/左中(L)]:<M> ")
        If key = "" Then key = "M"
    End With
   
    Dim i As Long
    Dim oText As AcadText
    Dim oMText As AcadMText
   
    For i = 0 To sSetText.Count - 1
        '*****************************************************
        If sSetText.Item(i).ObjectName = "AcDbText" Then
            Set oText = sSetText.Item(i)
            oText.GetBoundingBox tblp, ttrp
            tcp(0) = (tblp(0) + ttrp(0)) / 2
            tcp(1) = (tblp(1) + ttrp(1)) / 2
            tcp(2) = (tblp(2) + ttrp(2)) / 2
            
            ThisDrawing.SendCommand "_-Boundary" & "" & tcp(0) & "," & tcp(1) & "" & ""
'            ThisDrawing.SendCommand "_-Boundary" & vbCr & tcp(0) & "," & tcp(1) & "," & tcp(2) & vbCr & vbCr
            
            Set sSetBox = ThisDrawing.SelectionSets.Add("_Gas_Box")
            sSetBox.Select acSelectionSetLast
            sSetBox.Item(0).GetBoundingBox bblp, btrp
            sSetBox.Item(0).Delete
            ThisDrawing.SelectionSets.Item("_Gas_Box").Delete
        
            bcp(0) = (bblp(0) + btrp(0)) / 2
            bcp(1) = (bblp(1) + btrp(1)) / 2
            bcp(2) = (bblp(2) + btrp(2)) / 2
            
            bmlp(0) = bblp(0)
            bmlp(1) = (bblp(1) + btrp(1)) / 2
            bmlp(2) = (bblp(2) + btrp(2)) / 2
            
            If key = "L" Then
                oText.Alignment = acAlignmentMiddleLeft
                oText.GetBoundingBox tnblp, tntrp
               
                tnmlp(0) = tnblp(0)
                tnmlp(1) = (tnblp(1) + tntrp(1)) / 2
                tnmlp(2) = (tnblp(2) + tntrp(2)) / 2
                oText.Move tnmlp, bmlp
            Else
                oText.Alignment = acAlignmentMiddleCenter
                oText.GetBoundingBox tnblp, tntrp
               
                tncp(0) = (tnblp(0) + tntrp(0)) / 2
                tncp(1) = (tnblp(1) + tntrp(1)) / 2
                tncp(2) = (tnblp(2) + tntrp(2)) / 2
                oText.Move tncp, bcp
            End If
            '*****************************************************
        Else
            Set oMText = sSetText.Item(i)
            oMText.Width = 0
            
            oMText.GetBoundingBox tblp, ttrp
            tcp(0) = (tblp(0) + ttrp(0)) / 2
            tcp(1) = (tblp(1) + ttrp(1)) / 2
            tcp(2) = (tblp(2) + ttrp(2)) / 2
            
            ThisDrawing.SendCommand "_-Boundary" & "" & tcp(0) & "," & tcp(1) & "" & ""
'            ThisDrawing.SendCommand "_-Boundary" & vbCr & tcp(0) & "," & tcp(1) & vbCr & vbCr
            Set sSetBox = ThisDrawing.SelectionSets.Add("_Gas_Box")
            sSetBox.Select acSelectionSetLast
            sSetBox.Item(0).GetBoundingBox bblp, btrp
            sSetBox.Item(0).Delete
            ThisDrawing.SelectionSets.Item("_Gas_Box").Delete
        
            bcp(0) = (bblp(0) + btrp(0)) / 2
            bcp(1) = (bblp(1) + btrp(1)) / 2
            bcp(2) = (bblp(2) + btrp(2)) / 2
            
            bmlp(0) = bblp(0)
            bmlp(1) = (bblp(1) + btrp(1)) / 2
            bmlp(2) = (bblp(2) + btrp(2)) / 2
            
            If key = "L" Then
                oMText.AttachmentPoint = acAttachmentPointMiddleLeft
                oMText.GetBoundingBox tnblp, tntrp
               
                tnmlp(0) = tnblp(0)
                tnmlp(1) = (tnblp(1) + tntrp(1)) / 2
                tnmlp(2) = (tnblp(2) + tntrp(2)) / 2
                oMText.Move tnmlp, bmlp
            Else
                oMText.AttachmentPoint = acAttachmentPointMiddleCenter
                oMText.GetBoundingBox tnblp, tntrp
               
                tncp(0) = (tnblp(0) + tntrp(0)) / 2
                tncp(1) = (tnblp(1) + tntrp(1)) / 2
                tncp(2) = (tnblp(2) + tntrp(2)) / 2
                oMText.Move tncp, bcp
            End If
        End If
    Next
End Sub

LISP不好理解，VBA比较符合正常思维，自己尝试着写的代码，好像还有问题？请指教
PS：VBA还方便向VB.NET过渡

yanyanjun999

敬礼，学习了

yxh1202

是自动还是提示用户选择啊，先下载下来看看