Dears,
I have a lot of lines that I need a length, like in attached file. At this moment I do it with a vba that put fields in all lines.
The problems:
1) fields makes drawing slow to regen or after I modify line.
2) fields not follow lines slopes and position, if I stretch or move one end point of line. Text must be in middle of line.
So I thinking use reactors .
I tried reactor but I don't have much experience in lisp and I am having problems with persistent reactors, after I close file and open again, load lisp. Reactor not continue persistent.
This is a test that I tried. Works only for one line.
(defun print-align-text ( owner reactor lst / sp ep a d )
(setq sp (vlax-curve-getstartpoint line1))
(setq ep (vlax-curve-getendpoint line1))
(setq a (angle sp ep))
(setq d (distance sp ep))
'(vla-put-textstring mytext (rtos d 2 0))
(vla-put-alignment mytext acalignmentbottomcenter)
(vla-put-textalignmentpoint mytext (vlax-3d-point (mapcar '/ (mapcar '+ sp ep) (list 2.0 2.0 2.0))))
(vla-put-rotation mytext a)
)
(defun c:pp ( / sp ep a d )
(vl-load-com)
(setq line1 (car (entsel "\nSelect line: ")))
(setq texto(car (entsel "\nSelect text: ")))
(setq sp (cdr (assoc 10 (entget line1))))
(setq ep (cdr (assoc 11 (entget line1))))
(setq line1 (vlax-ename->vla-object line1))
(setq mytext(vlax-ename->vla-object texto))
(setq a (angle sp ep))
(setq d (distance sp ep))
(vla-put-alignment mytext acalignmentbottomcenter)
(vla-put-textalignmentpoint mytext (vlax-3d-point (mapcar '/ (mapcar '+ sp ep) (list 2.0 2.0 2.0))))
(vla-put-rotation mytext a)
(setq myreactor (vlr-object-reactor (list line1) "Object Reactor : " '((:vlr-modified . print-align-text))))
(vlr-pers myreactor)
(princ)
)
I have read that is better store data using XData. But I have no idea to start.
In VBA I tried construct class module withevents, without any sucess.
My knowledge in VBA is basic.
Anyone could you give some directions to study best way to do it?
I can't use any kind of dimension.
Thanks
Claudio
Solved! Go to Solution.
Solved by truss_85. Go to Solution.
As a solution to your problems:
1) "fields makes drawing slow to regen or after I modify line" use UPDATEFIELD rather to REGEN. Because regen updates all fields in a drawing. UPDATEFIELD only updates specific fields that save a lot of time.
2) "fields not follow lines slopes and position, if I stretch or move one end point of line. Text must be in middle of line." use GEOMETRIC CONSTRAINTS to fix field to the line. _GcCoincident and _GcParallel do it what you wants.
Yes Storing data is better when you use XDATA but it is not a dynamic solution like field. You must run a code to store and another code to display. I am not recommend that solution to your situation. If you are insist to use XDATA, a code I inserted from VBA HELP.
Sub Example_SetXdata() ' This example creates a line and attaches extended data to that line. ' Create the line Dim lineObj As AcadLine Dim startPt(0 To 2) As Double, endPt(0 To 2) As Double startPt(0) = 1#: startPt(1) = 1#: startPt(2) = 0# endPt(0) = 5#: endPt(1) = 5#: endPt(2) = 0# Set lineObj = ThisDrawing.ModelSpace.AddLine(startPt, endPt) ZoomAll ' Initialize all the xdata values. Note that first data in the list should be ' application name and first datatype code should be 1001 Dim DataType(0 To 9) As Integer Dim Data(0 To 9) As Variant Dim reals3(0 To 2) As Double Dim worldPos(0 To 2) As Double DataType(0) = 1001: Data(0) = "Test_Application" DataType(1) = 1000: Data(1) = "This is a test for xdata" DataType(2) = 1003: Data(2) = "0" ' layer DataType(3) = 1040: Data(3) = 1.23479137438413E+40 ' real DataType(4) = 1041: Data(4) = 1237324938 ' distance DataType(5) = 1070: Data(5) = 32767 ' 16 bit Integer DataType(6) = 1071: Data(6) = 32767 ' 32 bit Integer DataType(7) = 1042: Data(7) = 10 ' scaleFactor reals3(0) = -2.95: reals3(1) = 100: reals3(2) = -20 DataType(8) = 1010: Data(8) = reals3 ' real worldPos(0) = 4: worldPos(1) = 400.99999999: worldPos(2) = 2.798989 DataType(9) = 1011: Data(9) = worldPos ' world space position ' Attach the xdata to the line lineObj.SetXData DataType, Data ' Return the xdata for the line Dim xdataOut As Variant Dim xtypeOut As Variant lineObj.GetXData "", xtypeOut, xdataOut End Sub
Dear Truss,
Thank you very much.
I will try before with fields.
I am using updatefield.
I set regenauto to off.
Drafters is complaining about.
Anyway Thanks
claudio
Hi,
>> fields not follow lines slopes and position, if I stretch or move one end point of line. Text must be in middle of line.
Can be done with constraints 😉
- alfred -
PS: rename the attached file to .DWG (I could not upload it directly with extension DWG)
Hi,
I am trying to use sendcommand in my vba code.
To apply a constraint I need two clicks, in line and text. In my code this point has same coordinates.
Is there a way to filter in first point is to select line and in the second point in text?
ThisDrawing.SendCommand "_GcCoincident "
ThisDrawing.SendCommand x & "," & y & vbCr
ThisDrawing.SendCommand x & "," & y & vbCr
error
The object or point is already selected. Select a different object or
constraint point.
Thanks
I assumed that you add field to midpoint of the line. Add field slightly a diiferent coordinate then the midpoint and try again. If it does not work send whole of your code.
Best Regards...
Hi,
>> Sometimes works fine and sometimes not. I think that depend of zoom, text size and length of line
Correct! You can also see how the text-objects baseline get's highlighted depending on the position of your cursor (relative to the text object), that is needed for AutoCAD to know what point from the text is the point you need.
And that gives the explenation why you can't use just an ObjectID for a selection when using SendCommand with that commands. The object is not enough, you also need the point where the object is selected.
I guess you will not have luck doing that automatism with SendCommand. >>>this blog<<< gives some input/functions to go through constraints. Hopefully that will work for you.
If all fails you also have the option to create a dynamic block containing a line with a stretch-action on every line-endpoint + an attribute showing then the length of the line. So if it's to havy to create a line, then the field, then the constraints the insertion of that block might be the way to go?
Look to the attached sample, it's a (very) simple block with just one base-grip and two options to stretch to both sides. It depends on what you like to do, so it might be better to define the dynamic in another way, it's just a sample to show what I mean by block instead of each single object line+field+constraint to combine in runtime.
HTH, - alfred -
Hi,
I agree with Alfred. Using a block more easy then line+field+constraint. But may be using a polar stretch parameter more like line charactaristics. Take a look attached block.
Best Regards...
If you use "handle to object" method your code must be like that:
Public Sub alignfield() Dim ssetObj As AcadSelectionSet Dim oText1 As AcadText Dim oText2 As AcadText On Error Resume Next ThisDrawing.SelectionSets("teste").Delete Set ssetObj = ThisDrawing.SelectionSets.Add("teste") Dim f_type(0) As Integer Dim f_data(0) As Variant f_type(0) = 0 f_data(0) = "TEXT" ThisDrawing.SelectOnScreen f_type, f_data For Each Item In ssetObj Set oText1 = ssetObj.Item(n) ID = oText1.FieldCode 'also you can get ID of an object like ID=oText1.ObjectID If ID <> "" Then ID = Mid(ID, 31, 13) handle_text1 = oText1.Handle Set oText2 = ThisDrawing.HandleToObject(handle_text1) 'but we already select object as oText1 ? now we have same object on our hand oText1 and oText2 n = n + 1 Next End Sub
I must do some corrections to your code. I can not know where do you use this module but I think handletoobject is not necessary. And if you use selection set why are you using "each object in modelspace" it is a conflict. I hope I understand your goal correctly.
Best Regards...
Sorry for missunderstanding. Here it is the code:
Public Sub deneme() Dim oEnt As AcadEntity Dim oLine As AcadLine Dim MtextObj As AcadMText Dim pt As Variant Dim FilterType(0) As Integer Dim FilterData(0) As Variant Dim ssetObj As AcadSelectionSet On Error Resume Next ThisDrawing.SelectionSets.Item("SS1").Delete Set ssetObj = ThisDrawing.SelectionSets.Add("SS1") FilterType(0) = 0 FilterData(0) = "LINE" ssetObj.Select acSelectionSetAll, , , FilterType, FilterData ThisDrawing.Utility.GetEntity oEnt, pt, "Select a Mtext:" Set MtextObj = oEnt ID_line = Mid(MtextObj.FieldCode, 31, 13) n = 0 For Each Item In ssetObj Set oLine = ssetObj.Item(n) If ThisDrawing.Utility.GetObjectIdString(oLine, False) = ID_line Then 'do what ever you want to do for example change the color or if you want to grap line I recommend handletoobject it never fails. oLine.color = acRed
End If n = n + 1 Next End Sub
In field use Objectid not Objectid32 because of that your "ObjectIdToObject32(objectID)" does not work. Also "ObjectIdToObject32(objectID)" does not work either. I found a solution to get a selection set only lines and check out ids. It is not pretty but either two ways of above failed there is no option avaliable. Try it and let me know if it is working.
Dear Truss,
I made some changes to adapt to my code. It's working, Really thanks.
But the problem is that, for each field, program has to read all lines, because of this program run slow. I put filters to try reduce quantity of elements and time to run.
Do you have any other suggestion to run more quickly?
Public Sub deneme() Dim oEnt As AcadEntity Dim oLine As AcadLine Dim oField As AcadText Dim pt As Variant Dim FilterType(1) As Integer Dim FilterData(1) As Variant Dim ssetObj1 As AcadSelectionSet Dim ssetObj2 As AcadSelectionSet On Error Resume Next ThisDrawing.SelectionSets.Item("SS1").Delete Set ssetObj1 = ThisDrawing.SelectionSets.Add("SS1") 'lines ThisDrawing.SelectionSets.Item("SS2").Delete Set ssetObj2 = ThisDrawing.SelectionSets.Add("SS2") 'TEXTs with FIELD FilterType(0) = 0 FilterData(0) = "LINE" FilterType(1) = 8 '8 is layer FilterData(1) = "5,c-5" ssetObj1.Select acSelectionSetAll, , , FilterType, FilterData ' selection with lines filter FilterType(0) = 0 FilterData(0) = "TEXT" FilterType(1) = 8 FilterData(1) = "2,c-TEXTO" ssetObj2.SelectOnScreen FilterType, FilterData 'selection with fields k = 0 For Each Item2 In ssetObj2 Set oField = ssetObj2.Item(k) 'fields in drawing ID_line = Mid(oField.FieldCode, 31, 13) If ID_line <> "" Then n = 0 For Each Item In ssetObj1 Set oLine = ssetObj1.Item(n) If ThisDrawing.Utility.GetObjectIdString(oLine, False) = ID_line Then 'do what ever you want to do for example change the color or if you want to grap line I recommend handletoobject it never fails. oLine.color = acRed 'In this part I will manipulate field location with line information End If n = n + 1 Next End If k = k + 1 Next End Sub