Pulling coordinate entity of multiple objects

Hello everybody,

I have written a code to receive all 12 coordinates of 3dface object in to a single array.

First I added object id's in to a single array by this code.

Code:

---

For i = 0 To ss.Count - 1
If ss.Item(i).ObjectName = "AcDbFace" Then
ReDim Preserve xucgenmodel(w)
xucgenmodel(w) = ss(i).ObjectID
w = w + 1
End If

---

And then by using objectid's I am trying to pull all coordinates into single array by this code;

Code:

---

For i = 0 To UBound(xucgenmodel)


ReDim Preserve Ucgencoords(11 * (i + 1))


Ucgencoords = ActiveDocument.ObjectIdToObject(xucgenmodel(i)).Coordinates


Next i

---

But here I have a problem each time it loops it resets the previous numbers and doesnt continue. Any help is appreciated.

NOTES: 1 3DFACE HAS 12 COORDİNATES (starting from item(0) to item(11). So if I have 10 3DFACE's I should have 10*12= 120 rows array.

Quote:

---

Originally Posted by hasanyanizm

Hello everybody,

I have written a code to receive all 12 coordinates of 3dface object in to a single array.

First I added object id's in to a single array by this code.
For i = 0 To ss.Count - 1
If ss.Item(i).ObjectName = "AcDbFace" Then
ReDim Preserve xucgenmodel(w)
xucgenmodel(w) = ss(i).ObjectID
w = w + 1
End If

And then by using objectid's I am trying to pull all coordinates into single array by this code;

For i = 0 To UBound(xucgenmodel)


ReDim Preserve Ucgencoords(11 * (i + 1))


Ucgencoords = ActiveDocument.ObjectIdToObject(xucgenmodel(i)).Coordinates


Next i

But here I have a problem each time it loops it resets the previous numbers and doesnt continue. Any help is appreciated.

NOTES: 1 3DFACE HAS 12 COORDİNATES (starting from item(0) to item(11). So if I have 10 3DFACE's I should have 10*12= 120 rows array.

---

At every iteration you must add new coordinates starting from the array item right after the last one added in the previuous iteration
you could do something like

Code:

---

For i = 0 To UBound(xucgenmodel)

ReDim Preserve Ucgencoords(12*(i+1)-1)
for w = 0 to 11
  Ucgencoords (12*i + w)= ActiveDocument.ObjectIdToObject(xucgenmodel(i)).Coordinates(w)
next w

Next i

---

where I also modfied your Ucgencoords redimming, since your "ReDim Preserve Ucgencoords(11 * (i + 1))" would lead to a [0 to 22] array at the second iteration (i=1) whereas there you would need a [0 to 23] array (i.e. a 12*2 = 24 elements array)
Finally I didn't test it, and may be it needs some type variables tuning

The Get3DFace will obtain all 3dface entities in the current open drawing, then extract all the coordinates to MyCords

Code:

---

Sub Get3DFace()    Dim I As Long, N As Long
    Dim MyCords() As Double
    Dim NewCords() As Double
    Dim MyFace As Acad3DFace
    Dim txtset As AcadSelectionSet
    Dim intCode(0) As Integer
    Dim varData(0) As Variant
    Set txtset = Aset("TextSet")
    intCode(0) = 0: varData(0) = "3DFACE"
    txtset.Select acSelectionSetAll, , , intCode, varData
    For I = 0 To txtset.Count - 1
        'Debug.Print TxtSet(I).TextString
        If txtset(I).ObjectName = "AcDbFace" Then
            Set MyFace = txtset(I)
            If I = 0 Then
                MyCords = MyFace.Coordinates
            Else
                N = UBound(MyCords, 1) + 1
                ReDim Preserve MyCords(UBound(MyCords, 1) + 12)
                'MyCords(N) = MyFace.Coordinates
                NewCords = MyFace.Coordinates
                Call AddElements(MyCords, NewCords, N, N + 11)
            End If
        End If
     
    Next
End Sub
'
' This will add the elements of one array to another single line array
'
Private Sub AddElements(iAddArray() As Double, iAddToArray() As Double, iStr As Long, iEnd As Long)
    Dim I As Long, N As Long
    N = 0
    For I = iStr To iEnd
        iAddArray(I) = iAddToArray(N)
        If N < 12 Then
            N = N + 1
        End If
    Next
End Sub
'
' This gets a selecton set, it helps a lot in debugging, it will delete the existing selection set without doing anything to the members of the existing selection set.
'
Public Function Aset(iSSetName As String) As AcadSelectionSet
    Dim ssetA As AcadSelectionSet
    On Error Resume Next
    Set ssetA = ThisDrawing.SelectionSets.Add(iSSetName)
    If Err.Number <> 0 Then
        Set ssetA = ThisDrawing.SelectionSets(iSSetName)
        ssetA.Delete
        Set ssetA = ThisDrawing.SelectionSets.Add(iSSetName)
        Err.Clear
    End If
    On Error GoTo 0
    Set Aset = ssetA
End Function

---