Ok Experts-Advice requested

[Anonymous]

I am trying to figure out the best approach to do the following (I am no VBA
expert):

1. Prompt user to select multiple text entities.

2. Take the collection of text entities and remember column and row orders
of text.

3. Prompt user to select table to add a field linked to each text object
into the appropriate cells.

I think I can figure out how to place the field expression code into the
text fine, but I am not sure how to progress with the rest.

Thanks,
Dan



A picture say a thousand words, so maybe the attached one will help.

[Anonymous]

I couldn't to do it on VBA
Try this one written on VLisp
Copy this code to Notepad and save as ftt.lsp
Load and type in command line ftt
[code]
; ========code starting here =========;
; ftt.lsp
; written by Fatty T.O.H. all rights removed
; export fields with text contents to table
; (beta-version)
;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~;;

(defun group-by-num (lst num / ls ret)
(if (= (rem (length lst) num) 0)
(progn
(setq ls nil)
(repeat (/ (length lst) num)
(repeat num
(setq ls
(cons (car lst) ls)
lst (cdr lst)
)
)
(setq ret (append ret (list (reverse ls)))
ls nil
)
)
)
)
ret
)

(defun C:ftt (/ acsp adoc atable axss cnt col
columns data headers obj_list row rows
ss tx_list
)
(vl-load-com)
(alert
"Select text separatelly one by another\n
and one column by another columns only"
)
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
acsp (vla-get-modelspace adoc)
)
(setq ss (ssget (list (cons 0 "TEXT"))))
(setq axss (vla-get-activeselectionset adoc))
(vlax-for a axss
(setq obj_list (cons a obj_list))
)
(setq obj_list (reverse obj_list))
(setq columns (getint "\nColumns number : ")
rows (/ (length obj_list) columns)
obj_list (group-by-num obj_list rows)
)

(setq atable (vlax-invoke
acsp
'Addtable
(getpoint "\nTable insertion point\n")
(+ 2 rows)
columns
;; rows height (change by suit)
2.0
;; columns width (change by suit)
15.0
)
)
(vla-settext atable 0 0 "TABLE TITLE")

(setq cnt 1
headers '()
)
(repeat columns
(setq
headers (append headers (list (strcat "Header #" (itoa cnt))))
)
(setq cnt (1+ cnt))
)
(setq col 0
row 1
)
(foreach a headers
(vla-settext atable row col a)
(setq col (1+ col))
)

(setq col 0)
(repeat rows
(setq row 2
data (car obj_list)
)
(foreach obj data
(vla-settext
atable
row
col
(strcat "%<\\AcObjProp Object(%<\\_ObjId "
(itoa (vlax-get obj 'ObjectID))
">%).TextString \\f \"%bl2\">%"
)
)
(setq row (1+ row))
)
(setq col (1+ col)
obj_list (cdr obj_list)
)
)
(vlax-release-object atable)
(princ)
)
(prompt
"\n\t\t\t |-----------------------------|\n"
)
(prompt
"\n\t\t\t <| Start with FTT to execute |>\n"
)
(prompt
"\n\t\t\t |-----------------------------|\n"
)
; ========code ending here =========;
[/code]

Fatty

~'J'~

[Anonymous]

Ok I did it on VBA also:

Option Explicit
''Fill table with fields
Sub FieldsToTable()
Dim oSsets As AcadSelectionSets
Dim oSset As AcadSelectionSet
Dim oTable As AcadTable
Dim oText As AcadText
Dim j, k, l, m As Long
Dim i, n As Integer
Dim ftype(0) As Integer
Dim fData(0) As Variant
Dim insPt As Variant
Dim tmpStr As String

ftype(0) = 0: fData(0) = "TEXT"
MsgBox "NOTE:" & vbCrLf & _
"Select text in following order:" & vbCrLf & _
"Text1 Text5 Text9" & vbCrLf & _
"Text2 Text6 Text10" & vbCrLf & _
"Text3 Text7 Text11" & vbCrLf & _
"Text4 Text8 Text12 e.t.c.", vbExclamation

On Error GoTo ErrMsg
Set oSsets = ThisDrawing.SelectionSets
For Each oSset In oSsets
If oSset.Name = "$axss$" Then
oSset.Delete
End If
Next

Set oSset = oSsets.Add("$axss$")
oSset.SelectOnScreen ftype, fData

i = oSset.Count
k = CLng(InputBox("Enter column number", "Table columns"))
insPt = ThisDrawing.Utility.GetPoint(, "Table insertion point")
j = i \ k

Set oTable = ThisDrawing.ModelSpace.AddTable(insPt, j + 2, k, 2#, 15#)

m = 0
l = 0
tmpStr = "Tilte" ''Change title by suit
oTable.SetText m, l, tmpStr
m = 1
For l = 0 To 2
tmpStr = "Header #" & CStr(l + 1)
oTable.SetText m, l, tmpStr
Next l '' Change headers by suit

n = 0
For l = 0 To k - 1
For m = 2 To j + 1
Set oText = oSset.Item(n)

tmpStr = CStr(oText.ObjectID)
tmpStr = "%<\AcObjProp Object(%<\_ObjId " & tmpStr & _
">%).TextString \f " & "" & "%bl2" & "" & ">%"

oTable.SetText m, l, tmpStr
n = n + 1
Next
Next

oSset.Clear
oSset.Delete
Set oSset = Nothing
Set oSsets = Nothing
Set oTable = Nothing
Exit Sub

ErrMsg:
MsgBox Err.Description

End Sub

Fatty

~'J'~

[Anonymous]

Wow! Amazing...Fatty

This is a huge start Thank you.

Some clarifications:
In my example I used 16 text entities. In reality there will be typically
164 entities going into a larger table. Selecting each entitiy individually
will be to time consuming.
(I have no idea how to do this.)
Would it be possible to use a selection window to create the SSet?
Next...a formatted table already exist, so I need to prompt the user to
simply select the table to populate.

Does this make sense?

I apologize if I was not clear enough at first.

The drawing file is attached.

This is awesome,
Dan

[Anonymous]

I was able to modify the code provided easy enough to promt the user to
select the preformattes table, but I am not sure about how to get the data
selected with a window by the user into the right order.
Please see ne thread "Sort an array of text objects Asc by their X and Y
insertion point values". I thought it could server as a new topic.

Thanks,
Dan


"Dan" wrote in message
news:[email protected]...
Wow! Amazing...Fatty

This is a huge start Thank you.

Some clarifications:
In my example I used 16 text entities. In reality there will be typically
164 entities going into a larger table. Selecting each entitiy individually
will be to time consuming.
(I have no idea how to do this.)
Would it be possible to use a selection window to create the SSet?
Next...a formatted table already exist, so I need to prompt the user to
simply select the table to populate.

Does this make sen
se?

I apologize if I was not clear enough at first.

The drawing file is attached.

This is awesome,
Dan

[Anonymous]

Hi Dan,

Okay, I will work on your task further,
but not sure I can do it
Anyway I will try
Thank you

Fatty

~'J'~

[Anonymous]

Please see new thread "Sort an array of text objects Asc by their X and Y
insertion point values".

I thought it could bew two separate animals, but I was wrong, and definitly
more complex than I thought.
I have a thread with My current code and a sample drawing with the tables
that I use.

Thanks again for all your help. This will ssave a tremendous amount of
rework.

Dan
wrote in message news:[email protected]...
Hi Dan,

Okay, I will work on your task further,
but not sure I can do it
Anyway I will try
Thank you

Fatty

~'J'~

[Anonymous]

Try it on your table on top of your drawing
I could't to write BubbleSort for whole text but
with separate text columns this will work I hope
See prompts inside the code

[code]
Option Explicit

Sub FieldsToTable()
Dim oSsets As AcadSelectionSets
Dim oSset As AcadSelectionSet
Dim oTable As AcadTable
Dim i, j, k, l, m, n As Long
Dim ftype(0) As Integer
Dim fData(0) As Variant
Dim insPt As Variant
Dim tmpStr As String
ftype(0) = 0: fData(0) = "TEXT"

MsgBox "NOTE:" & vbCrLf & _
"Select by window every text column" & vbCrLf & _
"separatelly: from top to bottom" & vbCrLf & _
"and from left to right", vbExclamation

Set oSsets = ThisDrawing.SelectionSets
For Each oSset In oSsets
If oSset.Name = "$axss$" Then
oSset.Delete
End If
Next
Set oSset = oSsets.Add("$axss$")

Dim wPoint1 As Variant
Dim wPoint2 As Variant
Dim unitText As Object

k = CLng(InputBox("Enter the number of columns", "Table parameters", 5))
insPt = ThisDrawing.Utility.GetPoint(, "Table insertion point")

n = 1
l = 0

While n < k + 1

m = 3
wPoint1 = ThisDrawing.Utility.GetPoint(, "Specify first corner point of " & CStr(n) & " column")
wPoint2 = ThisDrawing.Utility.GetCorner(wPoint1, "Specify opposite corner:")
oSset.Select acSelectionSetWindow, wPoint1, wPoint2, ftype, fData

If n = 1 Then
i = oSset.Count
Set oTable = ThisDrawing.ModelSpace.AddTable(insPt, i + 3, k, 7.5, 15#)
oTable.RecomputeTableBlock False
oTable.SetTextHeight 1, 1.6875
oTable.TitleSuppressed = True
oTable.HeaderSuppressed = True
m = 0
l = 0
tmpStr = "NO"
oTable.SetText m, l, tmpStr
oTable.SetCellAlignment m, l, acMiddleCenter
m = 0
l = 1
tmpStr = "Q1"
oTable.SetText m, l, tmpStr
oTable.SetCellAlignment m, l, acMiddleCenter
m = 1
l = 0
tmpStr = "NO"
oTable.SetText m, l, tmpStr
oTable.SetCellAlignment m, l, acMiddleCenter
m = 1
l = 1
tmpStr = "Q"
oTable.SetText m, l, tmpStr
oTable.SetCellAlignment m, l, acMiddleCenter
Dim hdrArr As Variant
hdrArr = Array("Q2", "A", "B", "C", "D")
m = 2
For l = 0 To UBound(hdrArr)
tmpStr = hdrArr(l)
oTable.SetText m, l, tmpStr
oTable.SetCellAlignment m, l, acMiddleCenter
Next l
l = 0
m = 3
End If

Dim txtArr() As Variant
ReDim Preserve txtArr(oSset.Count - 1, 1)
For i = 0 To oSset.Count - 1
Set unitText = oSset.Item(i)

txtArr(i, 0) = unitText.InsertionPoint
txtArr(i, 1) = unitText.ObjectID

Next

txtArr = SortObjectsByRow(txtArr)

For i = 0 To UBound(txtArr, 1)
tmpStr = CStr(txtArr(i, 1))
tmpStr = "%<\AcObjProp Object(%<\_ObjId " & tmpStr & _
">%).TextString \f" & " " & "" & "%bl2" & "" & ">%"
oTable.SetText m, l, tmpStr
oTable.SetCellAlignment m, l, acMiddleCenter
m = m + 1

Next i

l = l + 1
n = n + 1

oSset.Clear
Erase txtArr

Wend

oTable.RecomputeTableBlock True

MsgBox "Mattew 4:14" & vbCrLf & _
"The people who set in darkness" & vbCrLf & _
"have seen a light...", vbExclamation
End Sub
'@'~~~~~~~~~~~written by Fatty T.O.H~~~~~~~~~~~~~~~~'@'
Public Function SortObjectsByRow(ByVal sourceArr As Variant)

Dim OnCondition As Boolean
Dim Depot(0, 1) As Variant
Dim Enumer As Long
OnCondition = False
Do Until OnCondition
OnCondition = True
For Enumer = LBound(sourceArr) To UBound(sourceArr) - 1
If sourceArr(Enumer, 0)(1) < sourceArr(Enumer + 1, 0)(1) Then
Depot(0, 0) = sourceArr(Enumer, 0)
Depot(0, 1) = sourceArr(Enumer, 1)
sourceArr(Enumer, 0) = sourceArr(Enumer + 1, 0)
sourceArr(Enumer, 1) = sourceArr(Enumer + 1, 1)
sourceArr(Enumer + 1, 0) = Depot(0, 0)
sourceArr(Enumer + 1, 1) = Depot(0, 1)
OnCondition = False
End If
Next
Loop
SortObjectsByRow = sourceArr
End Function
[/code]

Fatty

~'J'~

[Anonymous]

Awesome, Thank you Fatty. I have learned a great deal, and I am working on
it now.

wrote in message news:[email protected]...
Try it on your table on top of your drawing
I could't to write BubbleSort for whole text but
with separate text columns this will work I hope
See prompts inside the code

[code]
Option Explicit

Sub FieldsToTable()
Dim oSsets As AcadSelectionSets
Dim oSset As AcadSelectionSet
Dim oTable As AcadTable
Dim i, j, k, l, m, n As Long
Dim ftype(0) As Integer
Dim fData(0) As Variant
Dim insPt As Variant
Dim tmpStr As String
ftype(0) = 0: fData(0) = "TEXT"

MsgBox "NOTE:" & vbCrLf & _
"Select by window every text column" & vbCrLf & _
"separatelly: from top to bottom" & vbCrLf & _
"and from left to right", vbExclamation

Set oSsets = ThisDrawing.SelectionSets
For Each oSset In oSsets
If oSset.Name = "$axss$" Then
oSset.Delete
End If
Next
Set oSset = oSsets.Add("$axss$")

Dim wPoint1 As Variant
Dim wPoint2 As Variant
Dim unitText As Object

k = CLng(InputBox("Enter the number of columns", "Table parameters", 5))
insPt = ThisDrawing.Utility.GetPoint(, "Table insertion point")

n = 1
l = 0

While n < k + 1

m = 3
wPoint1 = ThisDrawing.Utility.GetPoint(, "Specify first corner point
of " & CStr(n) & " column")
wPoint2 = ThisDrawing.Utility.GetCorner(wPoint1, "Specify opposite
corner:")
oSset.Select acSelectionSetWindow, wPoint1, wPoint2, ftype, fData

If n = 1 Then
i = oSset.Count
Set oTable = ThisDrawing.ModelSpace.AddTable(insPt, i + 3, k, 7.5,
15#)
oTable.RecomputeTableBlock False
oTable.SetTextHeight 1, 1.6875
oTable.TitleSuppressed = True
oTable.HeaderSuppressed = True
m = 0
l = 0
tmpStr = "NO"
oTable.SetText m, l, tmpStr
oTable.SetCellAlignment m, l, acMiddleCenter
m = 0
l = 1
tmpStr = "Q1"
oTable.SetText m, l, tmpStr
oTable.SetCellAlignment m, l, acMiddleCenter
m = 1
l = 0
tmpStr = "NO"
oTable.SetText m, l, tmpStr
oTable.SetCellAlignment m, l, acMiddleCenter
m = 1
l = 1
tmpStr = "Q"
oTable.SetText m, l, tmpStr
oTable.SetCellAlignment m, l, acMiddleCenter
Dim hdrArr As Variant
hdrArr = Array("Q2", "A", "B", "C", "D")
m = 2
For l = 0 To UBound(hdrArr)
tmpStr = hdrArr(l)
oTable.SetText m, l, tmpStr
oTable.SetCellAlignment m, l, acMiddleCenter
Next l
l = 0
m = 3
End If

Dim txtArr() As Variant
ReDim Preserve txtArr(oSset.Count - 1, 1)
For i = 0 To oSset.Count - 1
Set unitText = oSset.Item(i)

txtArr(i, 0) = unitText.InsertionPoint
txtArr(i, 1) = unitText.ObjectID

Next

txtArr = SortObjectsByRow(txtArr)

For i = 0 To UBound(txtArr, 1)
tmpStr = CStr(txtArr(i, 1))
tmpStr = "%<\AcObjProp Object(%<\_ObjId " & tmpStr & _
">%).TextString \f" & " " & "" & "%bl2" & "" & ">%"
oTable.SetText m, l, tmpStr
oTable.SetCellAlignment m, l, acMiddleCenter
m = m + 1

Next i

l = l + 1
n = n + 1

oSset.Clear
Erase txtArr

Wend

oTable.RecomputeTableBlock True

MsgBox "Mattew 4:14" & vbCrLf & _
"The people who set in darkness" & vbCrLf & _
"have seen a light...", vbExclamation
End Sub
'@'~~~~~~~~~~~written by Fatty T.O.H~~~~~~~~~~~~~~~~'@'
Public Function SortObjectsByRow(ByVal sourceArr As Variant)

Dim OnCondition As Boolean
Dim Depot(0, 1) As Variant
Dim Enumer As Long
OnCondition = False
Do Until OnCondition
OnCondition = True
For Enumer = LBound(sourceArr) To UBound(sourceArr) - 1
If sourceArr(Enumer, 0)(1) < sourceArr(Enumer + 1, 0)(1) Then
Depot(0, 0) = sourceArr(Enumer, 0)
Depot(0, 1) = sourceArr(Enumer, 1)
sourceArr(Enumer, 0) = sourceArr(Enumer + 1, 0)
sourceArr(Enumer, 1) = sourceArr(Enumer + 1, 1)
sourceArr(Enumer + 1, 0) = Depot(0, 0)
sourceArr(Enumer + 1, 1) = Depot(0, 1)
OnCondition = False
End If
Next
Loop
SortObjectsByRow = sourceArr
End Function
[/code]

Fatty

~'J'~

[Anonymous]

Happy computing, Dan
Cheers:)

~'J'~