how to get the position coordinates of a dynamic block

[victorctti]

Hello, I'm developing code in VBA that takes information from a block and fills a table and I'm not able to get the x y z coordinates, if anyone could help I would be very grateful and thank you very much for your attention. attached code

Public NumNCE As Single
Public TagBl As String
Public NumNDT As String
Public NumNDC As String

Public props() As AcadDynamicBlockReferenceProperty

'Public CordXYZ As AcadBlockReference
'Public InsertionPoint() As Double
'Public CodXYZ As Double







Sub CONT_BOX_ESGOTO_COM_TAB()
Dim FilterData(0 To 1) As Variant 'cria a variavel filtro data
Dim FilterType(0 To 1) As Integer 'cria a variavel filtro type
Dim FlagTCdAnt As Boolean

Dim ModelSpecObj As AcadModelSpace
Dim NCirc As Integer
Dim NCol As Integer, NLin As Integer
Dim NOrig As Integer
Dim NumLinsTCd As Variant
Dim PtoInsTCd As Variant
Dim PtoLL As Variant, PtoUR As Variant
Dim PtoMR(0 To 2) As Double
Dim TabEnt As AcadTable
Dim TCCdEnt As AcadTable
Dim Verde As AcadAcCmColor
Dim Dad() As String
Dim TagShf As String
Dim LrgShf As Single
Dim PrfShf As Single
Dim dados As String
'Dim InsertedBlock As AcadBlockReference
'Dim IP(0 To 2) As Double

'Dim props() As AcadDynamicBlockReferenceProperty
'Dim Cod As Double


Key = 0
col = 8
LrgShf = 1
PrfShf = 1

'lin = NumNCE + 2


FlagOsnap = ThisDrawing.ObjectSnapMode
If FlagOsnap Then
    ThisDrawing.ObjectSnapMode = True
End If

'MENSAGEM DO inputbox
NumNCE = InputBox("Entre o numero inicial para numeração de caixas de esgoto", "Numero de caixas de esgoto")
TagBl = InputBox("Defina o código inicial da tag (3 caracteres)", "Tag do bloco")

For Each SSet In ThisDrawing.SelectionSets
    If SSet.Name = "CDI" Then
        ThisDrawing.SelectionSets.Item("CDI").Delete ' elemina outro selection set chamado cdi
        Exit For
    End If
Next SSet

Set SelCDI = ThisDrawing.SelectionSets.Add("CDI") 'seta um selection set chamado cdi

Set BlkCol = ThisDrawing.Blocks ' setar o bloco a ser modificado

FilterType(0) = 0
FilterData(0) = "Insert" 'tudo que é inserido
FilterType(1) = 8 ' vai precisar acrescentar desenhos 3d
FilterData(1) = "AHD" ' preciso trocar o shf

FimSel = 1 ' chave para entrar no while
Do While FimSel <> 0
    SelCDI.SelectOnScreen FilterType, FilterData ' cria o selection set chamado cdi com um filtro de busca 0,
    'inserido, bloco dinamico, layer AHD
    
    If SelCDI.Count = 1 Then ' se tiver uma seleção entra no if
        Set BlkEnt = SelCDI(0) ' se a caixa de esgoto estiver no selection set
        AtribCol = BlkEnt.GetAttributes 'pega o atributo da caixa de esgoto
      '  Insert = BlkEnt.GetBlockProperties()
        
'        Cood = BlkEnt.Coordinates
        'props = BlkEnt.GetDynamicBlockProperties

        NumAtribs = UBoundAtributes 'define o valor do atributo
        NumAtribs = UBound(AtribCol) + 1 ' acrescenta o valor ao atributo da caixa de esgoto
        AtribCol(0).TextString = TagBl & NumNCE ' re-escreve o valor do atributo
        NumNDT = AtribCol(1).TextString
        NumNDC = AtribCol(2).TextString
        'CodX = Cood.Coordinates(0).TextString
        'CodY = Cood.InsertionPoint(1)
        'NumNDT = InputBox("Identifique o nivel da tampa", "Nivel da tampa")
        'AtribCol(1).TextString = NumNDT
        'NumNDC = InputBox("Identifique o nivel do fundo", "Nivel do fundo")
        'AtribCol(2).TextString = NumNDC
        Application.Update ' atualiza o desenho
 
        NumNCE = NumNCE + 1
        SelCDI.Clear ' limpa o selection set
        
        NumCarTagShf = Len(BlkEnt.Name)
        TagShf = Right(BlkEnt.Name, NumCarTagShf) ' - 3)
        Set BlkDef = BlkCol.Item(BlkEnt.Name)
        NumEntsShf = BlkDef.Count
    
        PtInsShf = BlkEnt.InsertionPoint
        AngTab = BlkEnt.Rotation
        XSFac = BlkEnt.XScaleFactor
    
        AtribColShf = BlkEnt.GetAttributes
         For NEnt = 0 To NumEntsShf - 1
            Set EntBlkCol = BlkDef.Item(NEnt)
            If EntBlkCol.ObjectName = "AcDbBlockReference" Then
                If Left(EntBlkCol.Name, 6) = "HD§COL" Then
                    NumColShf = NumColShf + 1
                    AtribColCol = EntBlkCol.GetAttributes
                    For Each AtribCol In AtribColCol
                        Select Case AtribCol.TagString
                        Case "TAG"
                            Dad(NumColShf, 1) = AtribCol.TextString
                        Case "DIA"
                            Dad(NumColShf, 2) = AtribCol.TextString
                        End Select
                    Next AtribCol
                End If
            End If
        Next NEnt
    
        HTab = (NumColsShf * 4 + 5) * Esc ' preciso redimencionar tudo isso para o meu objetivo
        DistP1 = Sqr((LrgShf / 2) ^ 2 + PrfShf ^ 2)
        AngP1 = Atn(PrfShf / LrgShf * 2)
        XInsTab = LrgShf / 2 - HTab / 2
        YInsTab = PrfShf * SFac + 10 * Esc
        DistPtTab = Sqr(XInsTab ^ 2 + YInsTab ^ 2)
        AngPtTab = Atn(YInsTab / XInsTab) + Pi
    
       PtTab = ThisDrawing.Utility.PolarPoint(PtInsShf, AngPtTab + AngTab, DistPtTab)
        PtP1 = ThisDrawing.Utility.PolarPoint(PtInsShf, AngP1 + AngTab, DistP1)
        PtP2 = ThisDrawing.Utility.PolarPoint(PtTab, AngTab, HTab / 2)
    
        If XSFac = -1 Then
            CorAng = Pi
        Else
            CorAng = 0
        End If
        
        DesTCol PtTab, AngTab + CorAng + Pi / 2, Val(NumColShf), TagShf, Dad
        Set LineObj = ThisDrawing.ModelSpace.AddLine(PtP1, PtP2)
            LineObj.Layer = "AHD"
    'End If
    'Next BlkEnt
    
        'ThisDrawing.ModelSpace.AddTable(3, col + 1, 3, 4, 10)
    Else
        FimSel = 0 ' libera do while
    End If
Loop
'NumNCE +2 IGUAL NUMERO DE LINHAS

        
End Sub

Sub DesTCol(PtInsTC As Variant, AngTC, NumCols As Integer, TagShf, Dad() As String)

Dim NCol As Integer, NLin As Integer
Dim TColsEnt As AcadTable
Dim DimeA As Single
Dim DimeB As Single
Dim AZI As Single
Dim Key As Single

DimeA = props(0).Value + props(2).Value
DimeB = props(4).Value + props(8).Value
AZI = props(10).Value


Set Verd = AcadApplication.GetInterfaceObject("AutoCAD.acCmColor.20") ' talvez trocar as cores
Set Cyan = AcadApplication.GetInterfaceObject("AutoCAD.acCmColor.20")
Verd.ColorIndex = acGreen
Cyan.ColorIndex = acCyan

Set TColsEnt = ThisDrawing.ModelSpace.AddTable(PtInsTC, 3, 8, 4, 10) 'o 8 é a posição das colunas, NumCols +1 são as linhas
With TColsEnt

.AllowManualHeights = True
'.SetColumnWidth 1, 8
'.SetColumnWidth 2, 8
.MergeCells 0, 0, 0, 0
.SetRowHeight 0, 3
.SetCellContentColor 0, 0, Verd
.SetCellTextHeight 0, 0, 2
.SetCellTextHeight 1, 0, 1
.SetCellTextHeight 1, 1, 1
.SetCellTextHeight 1, 2, 1
.SetCellTextHeight 1, 3, 1
.SetCellTextHeight 1, 4, 1
.SetCellTextHeight 1, 5, 1
.SetCellTextHeight 1, 6, 1
.SetCellTextHeight 1, 7, 1

.SetCellAlignment 0, 0, acMiddleCenter
.SetCellGridColor 0, 0, AcCellEdgeMask.acLeftMask, Cyan
.SetCellGridColor 0, 2, AcCellEdgeMask.acRightMask, Cyan
.SetCellGridColor 0, 0, AcCellEdgeMask.acBottomMask, Verd
.SetCellGridColor 0, 1, AcCellEdgeMask.acBottomMask, Verd
.SetCellGridColor 0, 2, AcCellEdgeMask.acBottomMask, Verd
.SetCellGridColor 0, 3, AcCellEdgeMask.acBottomMask, Verd
.SetCellGridColor 0, 4, AcCellEdgeMask.acBottomMask, Verd
.SetCellGridColor 0, 5, AcCellEdgeMask.acBottomMask, Verd
.SetCellGridColor 0, 6, AcCellEdgeMask.acBottomMask, Verd
.SetCellGridColor 0, 7, AcCellEdgeMask.acBottomMask, Verd

'For NLin = 1 To NumCols
    'For NCol = 0 To 2
'        .SetCellAlignment NLin, NCol, acMiddleCenter
'        .SetCellTextStyle NLin, NCol, "SIMPLEX"
   ' Next NCol
'Next NLin
    
.SetCellGridColor NumCols, 0, AcCellEdgeMask.acBottomMask, Cyan
.SetCellGridColor NumCols, 1, AcCellEdgeMask.acBottomMask, Cyan
.SetCellGridColor NumCols, 2, AcCellEdgeMask.acBottomMask, Cyan
.SetCellGridColor NumCols, 3, AcCellEdgeMask.acBottomMask, Cyan
.SetCellGridColor NumCols, 4, AcCellEdgeMask.acBottomMask, Cyan
.SetCellGridColor NumCols, 5, AcCellEdgeMask.acBottomMask, Cyan
.SetCellGridColor NumCols, 6, AcCellEdgeMask.acBottomMask, Cyan
.SetCellGridColor NumCols, 7, AcCellEdgeMask.acBottomMask, Cyan

 If Key = 0 Then
    Key = 1
    .SetText 0, 0, "TABELA DE DADOS - CAIXA DE ESGOTO" '& TagShf
    .SetText 1, 0, "CAIXA"
    .SetText 1, 1, "NIVEL TAMPA (m)"
    .SetText 1, 2, "NIVEL FUNDO (m)"
    .SetText 1, 3, "DIMENS A (m)"
    .SetText 1, 4, "DIMENS B (m)"
    .SetText 1, 5, "COORD X (m)"
    .SetText 1, 6, "COORD Y (m)"
    .SetText 1, 7, "AZIMUTE (graus)"
    
    .SetText 2, 0, TagBl & NumNCE - 1
    .SetText 2, 1, NumNDT
    .SetText 2, 2, NumNDC
    .SetText 2, 3, DimeA
    .SetText 2, 4, DimeB
    .SetText 2, 5, "COORD X (m)"
    .SetText 2, 6, "COORD Y (m)"
    .SetText 2, 7, AZI
    
Else
    .SetText 0, 0, TagBl & NumNCE
    .SetText 0, 1, NumNDT
    .SetText 0, 2, NumNDC
    .SetText 0, 3, DimeA
    .SetText 0, 4, DimeB
    .SetText 0, 5, "COORD X (m)"
    .SetText 0, 6, "COORD Y (m)"
    .SetText 0, 7, AZI
End If



'For NLin = 1 To NumCols
    '.SetText NLin, 0, Dad(NLin, 1) ' 'PRENCHE A COLUNA 1
    '.SetText NLin, 2, Dad(NLin, 2) ''PRENCHE A COLUNA 3
'Next NLin

'.StyleName = "TABCOLS"
'    .ScaleEntity PtInsTC, 1 * Esc
 '   .Rotate PtInsTC, AngTC
    .Layer = "AHD"
End With

End Sub

*Moderator Edit* Changed code language to VB

[Ed__Jobe]

You have all the pieces of information you need. The BlockReference.InsertionPoint property is a variant consisting of an array of 3 doubles. You already have the block ref as BlkEnt, then you get the insertion point as PtInsShf. Now you just need to access the elements of the array. 0 is the X value, 1 is the Y value and 2 is the Z value.

Dim X As Double
Dim Y As Double
Dim Z As Double
X = InsPtShf(0)
Y = InsPtShf(1)
Z = InsPtShf(2)

[Ed__Jobe · Accepted solution]

Here's a helper class to use when working with points.

Save this code as a class module in your project.

Option Explicit

Private m_point(0 To 2) As Variant


Private Sub Class_Initialize()
        m_point(0) = 0#
        m_point(1) = 0#
        m_point(2) = 0#
End Sub

Public Sub Assign(point3D As Variant)
    If UBound(point3D) > 2 Then
        Err.Raise 1, "Pnt3D.Initialize", "Array out of bounds"
    ElseIf UBound(point3D) < 2 Then
        Err.Raise 2, "Pnt3D.Initialize", "Not a 3D point"
    ElseIf UBound(point3D) = 2 Then
        m_point(0) = point3D(0)
        m_point(1) = point3D(1)
        m_point(2) = point3D(2)
    End If
End Sub

Public Property Get x() As Double
    x = m_point(0)
End Property

Public Property Let x(x As Double)
    m_point(0) = x
End Property

Public Property Get Y() As Double
    Y = m_point(1)
End Property

Public Property Let Y(Y As Double)
    m_point(1) = Y
End Property

Public Property Get Z() As Double
    Z = m_point(2)
End Property

Public Property Let Z(Z As Double)
    m_point(2) = Z
End Property

Public Function ToArray() As Variant
    ToArray = m_point
End Function

Public Function ToString() As String
    ToString = "X:" & m_point(0) & ", Y:" & m_point(1) & ", Z:" & m_point(2)
End Function

Here's a sample of how to use it.

Public Sub pointTest2()
    Dim pnt As New Pnt3D
    
    pnt.x = 1.1
    pnt.Y = 2.2
    pnt.Z = 0#
    Debug.Print pnt.ToString
    
    Dim arr(0 To 2) As Double
    arr(0) = 3.3
    arr(1) = 6.6
    arr(2) = 0#
    pnt.Assign arr
    Debug.Print pnt.ToString   
End Sub

'you can also do things like
pnt.Assign BlkRef.InsertionPoint