Getting coordinates of a text object storing in collection

Hi,

Is it possible to get coordinates of any text object that assigned to collection?

First I add some of texts from selectionset to collection. And then I want to sort these members of collection according to the their coordinates X and Y. But I can not able to get coordinates of a member of collection. Here is my collection:

For Each oObj In oSset

If TypeOf oObj Is AcadText Then

Set oText = oObj

If InStr(1, oText.TextString, "Km =") > 0 Then

collection_km.Add oText

End If

End If

Next oObj

I try this but it gives an error

collection_km.Item(i).InsertionPoint(0)

Thanks for your advice

Perhaps try:

Set oText = collection_km.Item(i)

dim dblX as Double

dblX = oText.InsertionPoint(0)

Try from my codes, slightly edited

Public Sub TestCollectTextPoints()
Dim ent As AcadEntity
Dim objSSet As AcadSelectionSet
Dim setObj As AcadSelectionSet
Dim oText As AcadText
Dim oMText As AcadMText
Dim intFilterType(0 To 0) As Integer
Dim varFilterData(0 To 0) As Variant
Dim dxfCode, dxfValue
intFilterType(0) = 0: varFilterData(0) = "TEXT,MTEXT" 'to select texts and mtexts

  ' Creates an empty selection set.
      Dim setColl As AcadSelectionSets
    With ThisDrawing
         Set setColl = .SelectionSets
         For Each setObj In setColl
              If setObj.Name = "mySelSet" Then
                   .SelectionSets.item("mySelSet").Delete
                   Exit For
              End If
         Next
         Set objSSet = .SelectionSets.Add("mySelSet")
    End With
objSSet.SelectOnScreen intFilterType, varFilterData
If objSSet.Count = 0 Then
Exit Sub
End If
Dim txtColl As New Collection
Dim n As Long
n = 0
Dim textArr(0 To 3) As Variant
For Each ent In objSSet
If TypeOf ent Is AcadText Then
Set oText = ent
 'store text record in array
textArr(0) = oText.handle
textArr(1) = oText.InsertionPoint(0)
textArr(2) = oText.InsertionPoint(1)
textArr(3) = oText.TextString
txtColl.Add textArr
End If
If TypeOf ent Is AcadMText Then
Set oMText = ent
' 'store mtextrecord in array
textArr(0) = oMText.handle
textArr(1) = oMText.InsertionPoint(0)
textArr(2) = oMText.InsertionPoint(1)
textArr(3) = oMText.TextString
txtColl.Add textArr
End If
Next ent
' write collection to comma delimited file,
' You can use .csv extension instead of .txt
Call ahha("C:\Test\MyTextCollection.txt", txtColl)
'release collection at the end
Set txtColl = Nothing
End Sub

fixo Thanks for your interest. I edit my codes according to yours, but can not use the coordinates of members.

When I try to compare them in "If ... Else If" loop it gives an error again.

Can you explain it with an example please?

For example :

I have three textArr arrays in my collection.

Each of these textArr arrays have three properties like this (textArr(0)=oText.InsertionPoint(0),textArr(1)=oText.InsertionPoint(1),textArr(2)=oText.TextString)

Is it possible to compare and reordering these textArrs in collection according to their insertionpoints with loop?

Thanks.

habakay, I think there is enough to use 2 decimal array

instead of collection, again, this one is from my oldies, sorry,

havent have a time to explain good

Option Explicit
Sub TestTextSort()
    Dim ss As AcadSelectionSet
    Dim ftype(0) As Integer
    Dim fdata(0) As Variant
    Dim ent As AcadEntity

    Dim hndl As String
    Dim xcoord As Double
    Dim ycoord As Double
    Dim i As Integer
    Dim j As Integer
    Dim tmp As Variant
    Dim otext As AcadText
    Dim txtstring As String
    ftype(0) = 0:
    fdata(0) = "TEXT":
         With ThisDrawing.SelectionSets
              While .Count > 0
                   .Item(0).Delete
              Wend
         End With
    With ThisDrawing.SelectionSets
         Set ss = .Add("SortText")
         End With
 ss.SelectOnScreen ftype, fdata
 If ss.Count = 0 Then
 MsgBox "Nothing selected"
 Exit Sub
 Else
 ' collect text handles and Y-coordinates of block for sorting them
 ' below by Y-coordinate from top to bottom:
 ReDim txtdata(0 To ss.Count - 1, 0 To 3)
 i = 0
 For Each ent In ss
 Set otext = ent
 hndl = otext.Handle
 xcoord = otext.InsertionPoint(0)
 ycoord = otext.InsertionPoint(1)
 txtstring = otext.TextString
 txtdata(i, 0) = ycoord: txtdata(i, 1) = ycoord: txtdata(i, 2) = txtstring: txtdata(i, 3) = hndl
 i = i + 1
 Next ent
 'sort blocks by X
  txtdata = CoolSort(txtdata, 1) ' by Y would be txtdata = CoolSort(txtdata, 2)
  ' iterate through array and return text reference object
  ' check if sorting algorithm is right
  For i = 0 To UBound(txtdata, 1)
  Set otext = ThisDrawing.HandleToObject(txtdata(i, 3))
  Debug.Print otext.TextString
  Next i
End If
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' written by Fatty T.O.H. () 2006 * all rights removed '
' SourceArr - two dimensional array '
' iPos - "column" number (starting from 1) '
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Public Function CoolSort(SourceArr As Variant, iPos As Integer) As Variant
Dim Check As Boolean
ReDim tmpArr(UBound(SourceArr, 2)) As Variant
Dim iCount As Integer
Dim jCount As Integer
Dim nCount As Integer
iPos = iPos - 1
Check = False
Do Until Check
Check = True
For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1
If SourceArr(iCount, iPos) < SourceArr(iCount + 1, iPos) Then
For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)
tmpArr(jCount) = SourceArr(iCount, jCount)
SourceArr(iCount, jCount) = SourceArr(iCount + 1, jCount)
SourceArr(iCount + 1, jCount) = tmpArr(jCount)
Check = False
Next
End If
Next
Loop
CoolSort = SourceArr
End Function

Thanks for your interest.

habakay, I think there is enough to use 2 decimal array

instead of collection, again, this one is from my oldies, sorry,

havent have a time to explain good

fixo thanks for your codes. I make use of your codes and fix my codes. But still I have error. The arrays gives "Type mismatch" error.

Can you take a look?

Here is my codes

Option Explicit
Const xlFileName As String = "C:\Users\halil.abakay\Desktop\AutoCAD.xlsx" '<--change existing file name here
Public Sub Text_to_Excel()
Dim SS As AcadSelectionSet
Dim ftype(0) As Integer
Dim fdata(0) As Variant
Dim obj As AcadObject
Dim otext As AcadText
Dim txtdata_km
Dim txtdata_srbst
Dim txtdata_dolgu
Dim txtdata_yarma
Dim counter1 As Long
Dim counter2 As Long
Dim counter3 As Long
Dim counter4 As Long
Dim counterveri As Integer
Dim k As Integer
Dim xcoord As Double
Dim ycoord As Double
Dim txtstring As String
Dim xlApp As Object
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim lngRow As Long, lngCol As Long

On Error Resume Next
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   Set xlApp = GetObject(, "Excel.Application")
   
   If Err <> 0 Then
       Err.Clear
       Set xlApp = CreateObject("Excel.Application")
   If Err <> 0 Then
       MsgBox "Impossible to run Excel.", vbExclamation
       End
   End If
   End If

   xlApp.Visible = True
   
   Set xlBook = xlApp.Workbooks.Open(xlFileName)
   
   Set xlSheet = xlBook.Sheets(1)
   
   xlApp.ScreenUpdating = True

   If xlSheet.Range("A1") = "" Then
       lngRow = 1: lngCol = 1
   Else
       lngRow = xlSheet.Range("a65536").End(3).Offset(1, 0).Row: lngCol = 1
   End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

   ftype(0) = 0:
   fdata(0) = "TEXT":
   With ThisDrawing.SelectionSets
       While .Count > 0
           .Item(0).Delete
       Wend
   End With
   
   With ThisDrawing.SelectionSets
       Set SS = .Add("Textkubaj")
   End With
   SS.SelectOnScreen ftype, fdata
   
   
   If SS.Count = 0 Then
       MsgBox "Nothing selected"
       Exit Sub
   Else
       counter1 = 0
       counter2 = 0
       counter3 = 0
       counter4 = 0
       counterveri = 0
       For Each obj In SS
               
               Set otext = obj
               
               If InStr(1, otext.TextString, "Km =") > 0 Then
                   counter1 = counter1 + 1
                   ReDim Preserve txtdata_km(0 To 2, counter1 - 1)
                   xcoord = otext.InsertionPoint(0)
                   ycoord = otext.InsertionPoint(1)
                   txtstring = otext.TextString
                   txtdata_km(0, counter1 - 1) = xcoord: txtdata_km(1, counter1 - 1) = ycoord: txtdata_km(2, counter1 - 1) = txtstring
                   counterveri = counterveri + 1
                   
               ElseIf InStr(1, otext.TextString, "Serbest Kazı=") > 0 Then
                   counter2 = counter2 + 1
                   ReDim Preserve txtdata_srbst(0 To 2, 0 To counter2 - 1)
                   xcoord = otext.InsertionPoint(0)
                   ycoord = otext.InsertionPoint(1)
                   txtstring = otext.TextString
                   txtdata_srbst(0, counter2 - 1) = xcoord: txtdata_srbst(1, counter2 - 1) = ycoord: txtdata_srbst(2, counter2 - 1) = txtstring
                   counterveri = counterveri + 1
               
               ElseIf InStr(1, otext.TextString, "Dolgu =") > 0 Then
                   counter3 = counter3 + 1
                   ReDim Preserve txtdata_dolgu(0 To 2, 0 To counter3 - 1)
                   xcoord = otext.InsertionPoint(0)
                   ycoord = otext.InsertionPoint(1)
                   txtstring = otext.TextString
                   txtdata_dolgu(0, counter3 - 1) = xcoord: txtdata_dolgu(1, counter3 - 1) = ycoord: txtdata_dolgu(2, counter3 - 1) = txtstring
                   counterveri = counterveri + 1
               
               ElseIf InStr(1, otext.TextString, "Yarma =") > 0 Then
                   counter4 = counter4 + 1
                   ReDim Preserve txtdata_yarma(0 To 2, 0 To counter4 - 1)
                   xcoord = otext.InsertionPoint(0)
                   ycoord = otext.InsertionPoint(1)
                   txtstring = otext.TextString
                   txtdata_yarma(0, counter4 - 1) = xcoord: txtdata_yarma(1, counter4 - 1) = ycoord: txtdata_yarma(2, counter4 - 1) = txtstring
                   counterveri = counterveri + 1
               
               Else: GoTo devam
               End If
               
devam:
       Next obj
   
   End If
               
               
For k = 0 To counter1 - 1
           MsgBox txtdata_km(k, 0)
           xlSheet.Cells(lngRow, lngCol + 1).Value = txtdata_km(k, 0)
           xlSheet.Cells(lngRow, lngCol + 2).Value = txtdata_km(k, 1)
           xlSheet.Cells(lngRow, lngCol).Value = Replace(Replace(txtdata_km(k, 2).TextString, "Km =", ""), ".", ",")
           lngRow = lngRow + 1
Next k
   


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
xlSheet.Columns.HorizontalAlignment = xlHAlignLeft
xlSheet.Columns.AutoFit
xlApp.ScreenUpdating = True
xlBook.Save
xlBook.Close
xlApp.Quit
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
counter1 = Empty
counter2 = Empty
counter3 = Empty
counter4 = Empty
counterveri = Empty
k = Empty
Set txtdata_km = Nothing
Set txtdata_srbst = Nothing
Set txtdata_dolgu = Nothing
Set txtdata_yarma = Nothing
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
MsgBox "Done"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Err_Control:
If Err.Number <> 0 Then
   MsgBox Err.Description
End If

End Sub

Thanks.

here you can find my proposals, along with some comments (they're all preceeded by "

Option Explicit
Const xlFileName As String = "C:\Users\halil.abakay\Desktop\AutoCAD.xlsx" ' <-- change existing file name here
Public Sub Text_to_Excel()
Dim SS As AcadSelectionSet
Dim ftype(0) As Integer
Dim fdata(0) As Variant
Dim obj As AcadObject
Dim otext As AcadText
Dim txtdata_km ' <---  RICVBA:  this way you declare this object as Variant. here it works. you may want to delcare it ina more specific manner: "Dim txtdata_km() As Variant" so as to better control what you actually need it for
Dim txtdata_srbst ' <--- see what above
Dim txtdata_dolgu ' <--- see what above
Dim txtdata_yarma ' <--- see what above
Dim counter1 As Long
Dim counter2 As Long
Dim counter3 As Long
Dim counter4 As Long
Dim counterveri As Integer
'Dim k As Integer' <---
Dim k As Long ' <--- I'd recommend using same variable type you use for "counter1", "counter2", ... since you're going to add K to them
Dim xcoord As Double
Dim ycoord As Double
Dim txtstring As String
Dim xlApp As Object
Dim xlBook As Excel.Workbook ' <---  RICVBA: - I'd recommend using "Excel." object specifier. have you addede Microsoft Excel Object 14.0 (or whatever is your installed version) Library to your references?
Dim xlSheet As Excel.Worksheet ' <---  RICVBA: - I'd recommend using "Excel." object specifier
Dim lngRow As Long, lngCol As Long
ReDim txtdata_km(0 To 2, 0 To 0)    ' <---  RICVBA:  dim your variant array the first time. so as to allow for following statements like "ReDim Preserve ..."
ReDim txtdata_srbst(0 To 2, 0 To 0) ' <---  RICVBA:  dim your variant array the first time. so as to allow for following statements like "ReDim Preserve ..."
ReDim txtdata_dolgu(0 To 2, 0 To 0) ' <---  RICVBA:  dim your variant array the first time. so as to allow for following statements like "ReDim Preserve ..."
ReDim txtdata_yarma(0 To 2, 0 To 0) ' <---  RICVBA:  dim your variant array the first time. so as to allow for following statements like "ReDim Preserve ..."
'On Error Resume Next ' <---  RICVBA: I'D RECOMMEND NEVER TO USE THIS STATEMENT!!! So as to always be able see which problems arise and where
'On Error GoTo Err_Control ' <---  RICVBA: this was missing. while you defined this label (see near the end of your code. but while debugging I'd recommend not to make this active so as to be able to see exactly where problems arise. afte you're quite sure your code runs neatly than you can activate this statement to have a proper error treatment from the user's point of view
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   Set xlApp = GetObject(, "Excel.Application")

   If Err <> 0 Then
       Err.Clear
       Set xlApp = CreateObject("Excel.Application")
   If Err <> 0 Then
       MsgBox "Impossible to run Excel.", vbExclamation
       End
   End If
   End If
   xlApp.Visible = True

   Set xlBook = xlApp.Workbooks.Open(xlFileName)

   Set xlSheet = xlBook.Sheets(1)

   xlApp.ScreenUpdating = True
   If xlSheet.Range("A1") = "" Then
       lngRow = 1: lngCol = 1
   Else
       lngRow = xlSheet.Range("a65536").End(3).Offset(1, 0).Row: lngCol = 1
   End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   ftype(0) = 0:
   fdata(0) = "TEXT":
   With ThisDrawing.SelectionSets
       While .Count > 0
           .Item(0).Delete
       Wend
   End With

   With ThisDrawing.SelectionSets
       Set SS = .Add("Textkubaj")
   End With
   SS.SelectOnScreen ftype, fdata


   If SS.Count = 0 Then
       MsgBox "Nothing selected"
       Exit Sub
   Else
       counter1 = 0
       counter2 = 0
       counter3 = 0
       counter4 = 0
       counterveri = 0
       For Each obj In SS

               Set otext = obj

               ' <--- RICVBA: these following statements you can place here outside "If-Then" block, since they apply to every condition you can avoid reapeting them every time
               xcoord = otext.InsertionPoint(0)
               ycoord = otext.InsertionPoint(1)
               txtstring = otext.TextString
               ' <--- RICVBA

               If InStr(1, otext.TextString, "Km =") > 0 Then
                   counter1 = counter1 + 1
                   ReDim Preserve txtdata_km(0 To 2, counter1 - 1)
                   counterveri = counterveri + 1

               ElseIf InStr(1, otext.TextString, "Serbest Kazi=") > 0 Then
                   counter2 = counter2 + 1
                   ReDim Preserve txtdata_srbst(0 To 2, 0 To counter2 - 1)
                   txtdata_srbst(0, counter2 - 1) = xcoord: txtdata_srbst(1, counter2 - 1) = ycoord: txtdata_srbst(2, counter2 - 1) = txtstring
                   counterveri = counterveri + 1

               ElseIf InStr(1, otext.TextString, "Dolgu =") > 0 Then
                   counter3 = counter3 + 1
                   ReDim Preserve txtdata_dolgu(0 To 2, 0 To counter3 - 1)
                   txtdata_dolgu(0, counter3 - 1) = xcoord: txtdata_dolgu(1, counter3 - 1) = ycoord: txtdata_dolgu(2, counter3 - 1) = txtstring
                   counterveri = counterveri + 1

               ElseIf InStr(1, otext.TextString, "Yarma =") > 0 Then
                   counter4 = counter4 + 1
                   ReDim Preserve txtdata_yarma(0 To 2, 0 To counter4 - 1)
                   txtdata_yarma(0, counter4 - 1) = xcoord: txtdata_yarma(1, counter4 - 1) = ycoord: txtdata_yarma(2, counter4 - 1) = txtstring
                   counterveri = counterveri + 1

               'Else: GoTo devam ' <--- RICVBA: this you can avoid. since after the execution of whatsoever "If" or "ElseIf" or "Else" blocks of statements the program jumps directly below "End if" statement, thus processing "Next obj" one
               End If

'devam: '<--- RICVBA: this you can avoid. see preceeding comment
       Next obj

   End If


For k = 0 To counter1 - 1
'           <--- RICVBA: beware! you dimensioned these arrays with the first index ranging from 0 to 2. while you were treating them as if this was true for its second index !!' <---
'            MsgBox txtdata_km(k, 0)
'            xlSheet.Cells(lngRow, lngCol + 1).Value = txtdata_km(k, 0)
'            xlSheet.Cells(lngRow, lngCol + 2).Value = txtdata_km(k, 1)
'            xlSheet.Cells(lngRow, lngCol).Value = Replace(Replace(txtdata_km(k, 2).TextString, "Km =", ""), ".", ",")

           MsgBox txtdata_km(0, k) ' <--- RICVBA: see preceeding comment
           xlSheet.Cells(lngRow, lngCol + 1).Value = txtdata_km(0, k) ' <--- RICVBA: see preceeding comment
           xlSheet.Cells(lngRow, lngCol + 2).Value = txtdata_km(1, k) ' <--- RICVBA: see preceeding comment
           xlSheet.Cells(lngRow, lngCol).Value = Replace(Replace(txtdata_km(2, k), "Km =", ""), ".", ",") '' <--  RICVBA:  in addition to preceeding comment, txtdata_km is a (dinamic) array, not a object. so it doesn't have any property (like "textstring") to access via a "dot" operator. you previously stored the "textstring" property of "otext" object in the 3rd column of your array, so you have to simply access its position
           lngRow = lngRow + 1
Next k


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
xlSheet.Columns.HorizontalAlignment = xlHAlignLeft
xlSheet.Columns.AutoFit
xlApp.ScreenUpdating = True
xlBook.Save
xlBook.Close
xlApp.Quit
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' <--- RICVBA: set objects to "nothing" in reverse order with respect to the one followed when instantiating them ' <---
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
counter1 = Empty
counter2 = Empty
counter3 = Empty
counter4 = Empty
counterveri = Empty
k = Empty
' <--- RICVBA: arrays are not objects. you can't set them to nothing. instead set them to Empty' <---
'Set txtdata_km = Nothing
'Set txtdata_srbst = Nothing
'Set txtdata_dolgu = Nothing
'Set txtdata_yarma = Nothing
txtdata_km = Empty ' <--- RICVBA: see preceeding comment
txtdata_srbst = Empty ' <--- RICVBA: see preceeding comment
txtdata_dolgu = Empty ' <--- RICVBA: see preceeding comment
txtdata_yarma = Empty ' <--- RICVBA: see preceeding comment
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
MsgBox "Done"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Err_Control:
If Err.Number <> 0 Then
   MsgBox Err.Description
End If
End Sub

bye

here you can find my proposals, along with some comments (they're all preceeded by "

 

bye

I'm very grateful. It works perfect.

I'm very grateful. It works perfect.

fine

good work!