[编程交流] 文本对齐点问题

Sub getAttProps()
   Dim BlockRef As AcadBlockReference
   Dim varPt As Variant
   Dim subEnt As Object
   Dim oAttRef As AcadAttributeReference
   Dim insPt As Variant
   Dim algnPt As Variant
   Dim align As Integer
   Dim tmax, cxdata
   ThisDrawing.Utility.GetSubEntity subEnt, varPt, tmax, cxdata, vbLf & "Select a block subentity"
   If TypeOf subEnt Is AcadAttributeReference Then
       Set oAttRef = subEnt
       insPt = oAttRef.InsertionPoint
       algnPt = oAttRef.TextAlignmentPoint
       align = oAttRef.Alignment
       MsgBox "Alignment: " & align & vbCr & _
              "Insertion Point: " & CStr(Round(insPt(0), 2)) & "," & CStr(Round(insPt(1), 2)) & "," & CStr(Round(insPt(2), 2)) & vbCr & _
              "TextAlignmentPoint Point: " & CStr(Round(algnPt(0), 2)) & "," & CStr(Round(algnPt(1), 2)) & "," & CStr(Round(algnPt(2), 2))
   End If
End Sub

 
For Each oLayout In adoc.Layouts
   For Each oEnt In oLayout.Block
       If TypeOf oEnt Is AcadBlockReference Then
       Set blkRefObj = oEnt
           If StrComp(blkRefObj.Name, OriginalTitleblock, vbTextCompare) = 0 Then
           attArr = blkRefObj.GetAttributes
               For k = 0 To UBound(attArr)
               Set attObj = attArr(k)
               ka = Left(attObj.TextAlignmentPoint(0), 11)
               kb = Left(attObj.TextAlignmentPoint(1), 10)
               kc = attObj.TextAlignmentPoint(2)
               kx = Left(attObj.InsertionPoint(0), 11)
               ky = Left(attObj.InsertionPoint(1), 10)
               kz = attObj.InsertionPoint(2)
               k_TextAlignmentPoint = ka & "," & kb & "," & kc
               k_InsertionPoint = kx & "," & ky & "," & kz
                   If StrComp(k_TextAlignmentPoint, OriginalTextAlignmentPoint_1, vbTextCompare) = 0 Then
                       a1 = attObj.TextString