（批量）让框格里的文本对齐_整理材料表
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过渡
敬礼，学习了 是自动还是提示用户选择啊，先下载下来看看
页:
[1]