TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: jvillarreal on May 10, 2010, 07:19:38 AM
-
Typically we will recieve contours in 3d from the surveyor or polylines containing object data which can be used to elevate them, but a few times the files will contain polylines with text calling out the elevations. After being asked to manually elevate these polylines, I put this together. Its been useful so far but is not worthy of the show your stuff category as it can definitely be enhanced. So to anybody interested, here it is.
;Routine will elevate flat segments by searching for numeric text objects within a starting and max radius.
;Text objects are skipped once max radius is reached.
;Currently only works with text objects
;used ssget->vla-list & list->variantArray functions written by CAB
*Edit*
Updated routine
-
cheers
-
This routine has been a real time saver but was terrible with a large number of polyline segments so i've updated.
Am i missing any obvious ways to further cut run time?
Any advice is appreciated,
Juan
;Routine will elevate flat segments by selecting linework within a starting and max radius
;of the midpoint of text or mtext objects
;Text objects are skipped once max radius is reached.
;used ssget->vla-list by CAB
(defun ssget->vla-list (ss / i ename allobj)
(if ss
(progn
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq allobj (cons (vlax-ename->vla-object ename) allobj))
)
allobj
)
)
)
(defun c:autoelevate ( / linework number ent elist elevat circle *Space* newradius numlines
ActDoc bb pt1 pt2 insxpt midpoint radius increment count skipped maxrad inc)
(vl-load-com)
(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(setq *Space* (vlax-get-property ActDoc (nth (vla-get-ActiveSpace ActDoc)'("PaperSpace" "ModelSpace"))))
(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)
(setq radius (getreal "\nEnter starting radius:"))
(while (or (null radius)(<= radius 0))(setq radius (getreal "\nEnter starting radius greater than 0:")))
(setq increment (getreal "\nEnter radius increment:"))
(while (or (null increment)(<= increment 0))(setq increment (getreal "\nEnter radius increment greater than 0:")))
(setq maxrad (getreal "\nEnter maximum radius:"))
(while (or (null maxrad)(< maxrad radius))(setq maxrad (getreal "\nEnter maximum (greater than radius):")))
(setq count 0 skipped 0)
(vlax-for i (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(if (member (vla-get-objectname i) '("AcDbMText" "AcDbText"))
(progn
(vl-catch-all-apply 'vla-getboundingbox
(list i
'minpoint
'maxpoint
)
)
(setq pt1 (vlax-safearray->list minpoint)
pt2 (vlax-safearray->list maxpoint)
midpoint (mapcar '(lambda (a b) (/ (+ a b) 2.0)) pt1 pt2)
inc (/ (* pi 2) 10)
newradius radius
elevat nil)
(while (and (<= newradius maxrad)(null elevat))
(setq plist nil n 0)
(while (<= n 10)
(setq n (1+ n)
plist (append plist (list (polar midpoint (* inc n) newradius)))
)
)
(setq newradius (+ newradius increment))
(and
(setq linework
(ssget->vla-list
(ssget "_CP" plist (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,ELLIPSE")))))
(setq number (vla-get-textstring i)
elevat (atoi number)
)
(eq (vla-get-elevation (nth 0 linework)) 0.0)
(not (vla-put-elevation (nth 0 linework) elevat))
(setq count (1+ count))
(grtext -2 (strcat (itoa count) " Flat Segments Elevated."))
);and
);while
);progn
);if
);vlax-for
(vla-EndUndoMark ActDoc)
(princ (strcat "\nProcess Complete..." (itoa count) " Flat Segments Elevated."))
(princ)
);defun autoelevate
(defun c:aev ()(c:autoelevate))
-
Hi Jvillarreal
I have a question about autoelevate routine . dose it work with block points or no ? namely , the texts are related to some point blocks , please , if possible for you put a gif animated hint for use of this routine . I'm a beginner and still in learning stage , and don't deal whit vlisp codes ! :-o
thanks
-
Sorry for the late response..was at the company thanksgiving lunch...
This routine doesn't work with block points but can be modified to work with anything as long as you can extract an elevation from the object.
You could change this section to get the block.
(vlax-for i (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(if [color=red](member (vla-get-objectname i) '("AcDbMText" "AcDbText"))[/color]
and this section to extract the textstring from the block
(and
(setq linework
(ssget->vla-list
(ssget "_CP" plist (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,ELLIPSE")))))
(setq number [color=red](vla-get-textstring i)[/color]
elevat (atoi number)
)
(eq (vla-get-elevation (nth 0 linework)) 0.0)
(not (vla-put-elevation (nth 0 linework) elevat))
(setq count (1+ count))
(grtext -2 (strcat (itoa count) " Flat Segments Elevated."))
);and
A gif wouldn't do much good for this routine..
You have to provide a starting radius, increment to increase radius, and maxradius.
In this case, for each (m)text object found, a selection is attempted using the user input radius. If no linework is selected, the radius is increased and the process is repeated until the user input max radius is reached or linework is selected.
-
from the outside it appears you are creating elevated polylines by using 'proximity' information, sounds like a very bad practice if one is creating terrain models. One would be far ahead of the curve to use real survey data such as the point(s) blocks being referred to instead of proximal elevation information from text entries.
-
from the outside it appears you are creating elevated polylines by using 'proximity' information, sounds like a very bad practice if one is creating terrain models. One would be far ahead of the curve to use real survey data such as the point(s) blocks being referred to instead of proximal elevation information from text entries.
This routine is intended to do as you described. I ONLY use this routine when no other survey information is available as described in the first post.
(At times, we will receive polylines with elevation provided in text form only. This routine removes the slow/mundane task of manually elevating each polyline.)
-
from the outside it appears you are creating elevated polylines by using 'proximity' information, sounds like a very bad practice if one is creating terrain models. One would be far ahead of the curve to use real survey data such as the point(s) blocks being referred to instead of proximal elevation information from text entries.
This routine is intended to do as you described. I ONLY use this routine when no other survey information is available as described in the first post.
(At times, we will receive polylines with elevation provided in text form only. This routine removes the slow/mundane task of manually elevating each polyline.)
do you have MAP? it's possible to extract those text entities to points through a Query to Report function; I use this method often when converting Ariel Topography to TINS. perhpas this is a process you might try as well
-
do you have MAP? it's possible to extract those text entities to points through a Query to Report function; I use this method often when converting Ariel Topography to TINS. perhpas this is a process you might try as well
I do have map and am not familiar with the Query to Report function. The position of the text provided is not always on the linework provided. How will extracting the text entities to points be any more accurate?
-
do you have MAP? it's possible to extract those text entities to points through a Query to Report function; I use this method often when converting Ariel Topography to TINS. perhpas this is a process you might try as well
I do have map and am not familiar with the Query to Report function. The position of the text provided is not always on the linework provided. How will extracting the text entities to points be any more accurate?
given that there are sufficient points, one can construct the original surface from them.
Process for map query report:
Attach the source file to a NEW MAP drawing
Query in the Text, either by object or layer
Change Query Type From Preview To Report
Extrat the X and y of the text objects AND the TVALUE of the Text
Execute the query
It then writes and XYZ file that you then import as a point file...
build your surface from thata data
In the case of Ariel Topo I generally work with the SPOT X's and the text adjacent to them
If you look at your data closely there might be similar Spot X's to work from as well
Also consider asking the source for the LandXML file of that surface and save everyone the grief.
*small rant here* You will need to open the report and SAVE AS to CSV from excel because autodesk broke this report file generator about 4 years ago, and it adds phantom 'HEX' data to the TXT file created even though it should be a simple asci text file
-
Thanks for the lesson Michael. I will definitely use that process in the future. Unfortunately there are no spot x's to work with in some cases and the elevation is not always called out sufficiently enough to use the text as points. The most recent time i had to use this routine was due to financial issues. The surveyor was asking for more money to provide any information in 3d. :x
Nice to know there are other options though. Thanks again!
-
Sorry for the late response..was at the company thanksgiving lunch...
This routine doesn't work with block points but can be modified to work with anything as long as you can extract an elevation from the object.
You could change this section to get the block.
(vlax-for i (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(if [color=red](member (vla-get-objectname i) '("AcDbMText" "AcDbText"))[/color]
and this section to extract the textstring from the block
(and
(setq linework
(ssget->vla-list
(ssget "_CP" plist (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,ELLIPSE")))))
(setq number [color=red](vla-get-textstring i)[/color]
elevat (atoi number)
)
(eq (vla-get-elevation (nth 0 linework)) 0.0)
(not (vla-put-elevation (nth 0 linework) elevat))
(setq count (1+ count))
(grtext -2 (strcat (itoa count) " Flat Segments Elevated."))
);and
A gif wouldn't do much good for this routine..
You have to provide a starting radius, increment to increase radius, and maxradius.
In this case, for each (m)text object found, a selection is attempted using the user input radius. If no linework is selected, the radius is increased and the process is repeated until the user input max radius is reached or linework is selected.
Thanks Jvillarreal for response , and now I'm sorry for the late ! it is my favorite when I work with old version of topographic maps . :wink:
-
...
Nice to know there are other options though. Thanks again!
In Civil3D there is a command for doing that, and you don't have to use queries and textfiles.
Also here http://www.theswamp.org/index.php?topic=31812.msg373120#msg373120 you can find information to create 3D points from texts, using VB.Net. At home I also have a compiled version of that so if you're interested in that tool, I'll mail it.
But your routine is very interesting for creating breaklines, though in Civil3D there is an option to use proximity breaklines which will do the same, as long as there are 3D points above the nodes.
-
Glad you like it Robert.
Huiz,
What is the command in Civil 3d? I'm definitely interested in your tool and would be thankful if you shared it. Thanks, Juan
-
The command is AeccMoveTextToElevation.
If I'm home, I'll try to upload the tool.
-
The command is AeccMoveTextToElevation.
If I'm home, I'll try to upload the tool.
Hurry up,and I couldn't wait :-P
-
In Civil3D there is a command for doing that, and you don't have to use queries and textfiles.
, though in Civil3D there is an option to use proximity breaklines which will do the same, as long as there are 3D points above the nodes.
To use AeccMoveTextToElevation the actual COMMAND Line entry is MoveTextToElevation. I'm not sure if this command is available outside of C3D.
As for using 'proximity' breaklines, which I advise against because it assigns what ever elevation to the vertices, from whatever point is proximal to that point. The points do not need to be exactly at the vertex.
-
Quick look and I made a few changes but not much change in speed I suspect. See ; CAB for changes.
Will look again after breakfast to see what this routine is doing.
(defun ssget->vla-list (ss / i ename allobj)
(if ss
(progn
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq allobj (cons (vlax-ename->vla-object ename) allobj))
)
allobj
)
)
)
(defun c:autoelevate (/ linework number ent elist elevat
circle *Space* newradius numlines ActDoc bb
pt1 pt2 insxpt midpoint radius increment
count skipped maxrad inc
)
(vl-load-com)
(setq ActDoc (vla-get-activedocument (vlax-get-acad-object)))
(setq *Space* (vlax-get-property
ActDoc
(nth (vla-get-activespace ActDoc) '("PaperSpace" "ModelSpace"))
)
)
(vla-endundomark ActDoc)
(vla-startundomark ActDoc)
(setq radius (getreal "\nEnter starting radius:"))
(while (or (null radius) (<= radius 0))
(setq radius (getreal "\nEnter starting radius greater than 0:"))
)
(setq increment (getreal "\nEnter radius increment:"))
(while (or (null increment) (<= increment 0))
(setq increment (getreal "\nEnter radius increment greater than 0:"))
)
(setq maxrad (getreal "\nEnter maximum radius:"))
(while (or (null maxrad) (< maxrad radius))
(setq maxrad (getreal "\nEnter maximum (greater than radius):"))
)
(setq count 0
skipped 0
)
(vlax-for i (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
(if (vl-position (vla-get-objectname i) '("AcDbMText" "AcDbText")) ; CAB
(progn
(vl-catch-all-apply
'vla-getboundingbox
(list i
'minpoint
'maxpoint
)
)
(setq pt1 (vlax-safearray->list minpoint)
pt2 (vlax-safearray->list maxpoint)
midpoint (mapcar (function (lambda (a b) (/ (+ a b) 2.0))) pt1 pt2) ; CAB
inc (/ (* pi 2) 10)
newradius radius
elevat nil
)
(while (and elevat (<= newradius maxrad)) ; CAB
(setq plist nil
n 0
)
(while (< (setq n (1+ n)) 12) ; CAB
(setq plist (append plist (list (polar midpoint (* inc n) newradius))))
)
(setq newradius (+ newradius increment))
(and
(setq linework
(ssget->vla-list
(ssget "_CP"
plist
(list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,ELLIPSE"))
)
)
)
(setq number (vla-get-textstring i)
elevat (atoi number)
)
(eq (vla-get-elevation (car linework)) 0.0) ; CAB
(not (vla-put-elevation (car linework) elevat)) ; CAB
(setq count (1+ count))
(grtext -2 (strcat (itoa count) " Flat Segments Elevated."))
) ;and
) ;while
) ;progn
) ;if
) ;vlax-for
(vla-endundomark ActDoc)
(princ (strcat "\nProcess Complete..." (itoa count) " Flat Segments Elevated."))
(princ)
) ;defun autoelevate
(defun c:aev () (c:autoelevate))
-
To use AeccMoveTextToElevation the actual COMMAND Line entry is MoveTextToElevation. I'm not sure if this command is available outside of C3D.
For those without C3D...
(defun c:MoveTextToElevation (/ ss z)
(vl-load-com)
(if (setq ss (ssget "_:L" '((0 . "MTEXT,TEXT"))))
(progn
(vlax-for x (setq ss (vla-get-activeselectionset
(cond (*AcadDoc*)
((setq *AcadDoc* (vla-get-activedocument
(vlax-get-acad-object)
)
)
)
)
)
)
(if (setq z (distof (vla-get-textstring x)))
(vlax-put x
'InsertionPoint
(reverse (cons z (cdr (reverse (vlax-get x 'InsertionPoint)))))
)
)
)
(vla-delete ss)
)
)
(princ)
)
-
jv
Looking at the code I see this:
Step trough model space objects, process Text or Mtext objects only
Use BB to get the middle point of the text
Create a point list to circle the text center at each radius, up to MaxRadius
Use ssget CP to gather any objects (see types list) within or crossing that raidus
Update the first one (closest one?) to the desired elevation
why only the first object in the SS ?
You should end the WHILE loop at this point, but it continues on
Or do you want it to continue on?
-
Cab,
The reason it only updates the first one is because its intended to only grab the closest object. If it grabs more than one, the increment or starting radius should probably have been decreased. On the version i posted, the while loop ends when an elevation is extracted from a text object or the max radius is reached.
Thanks for looking at this.
-
Problem is that i is set outside the WHILE loop and never changes to end the loop.
See in this one I end the while loop by setting elevat to nil
(defun ssget->vla-list (ss / i ename allobj)
(if ss
(progn
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq allobj (cons (vlax-ename->vla-object ename) allobj))
)
allobj
)
)
)
(defun c:autoelevate (/ linework number ent elist elevat
circle *Space* newradius numlines ActDoc bb
pt1 pt2 insxpt midpoint radius increment
count skipped maxrad inc
)
(vl-load-com)
(setq ActDoc (vla-get-activedocument (vlax-get-acad-object)))
(setq *Space* (vlax-get-property
ActDoc
(nth (vla-get-activespace ActDoc) '("PaperSpace" "ModelSpace"))
)
)
(vla-endundomark ActDoc)
(vla-startundomark ActDoc)
(setq radius (getreal "\nEnter starting radius:"))
(while (or (null radius) (<= radius 0))
(setq radius (getreal "\nEnter starting radius greater than 0:"))
)
(setq increment (getreal "\nEnter radius increment:"))
(while (or (null increment) (<= increment 0))
(setq increment (getreal "\nEnter radius increment greater than 0:"))
)
(setq maxrad (getreal "\nEnter maximum radius:"))
(while (or (null maxrad) (< maxrad radius))
(setq maxrad (getreal "\nEnter maximum (greater than radius):"))
)
(setq count 0
skipped 0
)
;|
Step through model space objects, process Text or Mtext objects only
Use BB to get the middle point of the text
Create a point list to circle the text center at each radius, up to MaxRadius
Use ssget CP to gather any objects (see types list) within or crossing that raidus
Update the first one (closest one?) to the desired elevation
You should end the WHILE loop at this point, but it continues on
Or do you want it to continue on?
|;
(vlax-for i (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
(if (vl-position (vla-get-objectname i) '("AcDbMText" "AcDbText")) ; CAB
(progn
(vl-catch-all-apply
'vla-getboundingbox
(list i
'minpoint
'maxpoint
)
)
(setq pt1 (vlax-safearray->list minpoint)
pt2 (vlax-safearray->list maxpoint)
midpoint (mapcar (function (lambda (a b) (/ (+ a b) 2.0))) pt1 pt2) ; CAB
inc (/ (* pi 2) 10)
newradius radius
elevat nil
)
;; This does not change in the WHILE loop
(setq number (vla-get-textstring i) ; CAB relocated
elevat (atoi number)
)
;; --------------------------------------------------- Main Loop
(while (and elevat (<= newradius maxrad)) ; CAB
(setq plist nil
n 0
)
(while (< (setq n (1+ n)) 12) ; CAB
(setq plist (cons (list (polar midpoint (* inc n) newradius)) plist)) ; CAB remove append
)
(setq newradius (+ newradius increment))
(and
(setq linework
(ssget->vla-list
(ssget "_CP"
plist
(list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,ELLIPSE"))
)
)
)
;; why only the first object in the SS ?
(eq (vla-get-elevation (car linework)) 0.0) ; CAB
(not (vla-put-elevation (car linework) elevat)) ; CAB
(not (setq elevat nil)) ; end while loop ; CAB
(setq count (1+ count))
(grtext -2 (strcat (itoa count) " Flat Segments Elevated."))
) ;and
) ;while
;; ---------------------------------------------------- Main Loop
) ;progn
) ;if
) ;vlax-for
(vla-endundomark ActDoc)
(princ (strcat "\nProcess Complete..." (itoa count) " Flat Segments Elevated."))
(princ)
) ;defun autoelevate
(defun c:aev () (c:autoelevate))
-
Problem is that i is set outside the WHILE loop and never changes to end the loop.
(while[color=red] (and (<= newradius maxrad)(null elevat))[/color] (setq plist nil n 0)
(while (<= n 10)
(setq n (1+ n)
plist (append plist (list (polar midpoint (* inc n) newradius)))
)
)
(setq newradius (+ newradius increment))
(and
(setq linework
(ssget->vla-list
(ssget "_CP" plist (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,ELLIPSE")))))
[color=red] (setq number (vla-get-textstring i)
elevat (atoi number)
)[/color]
(eq (vla-get-elevation (nth 0 linework)) 0.0)
(not (vla-put-elevation (nth 0 linework) elevat))
(setq count (1+ count))
(grtext -2 (strcat (itoa count) " Flat Segments Elevated."))
);and
);while
The while loop is ended after elevat is set so i don't think the while loop is an issue
-
I apologize for the slow responses. My current connection speed is very slow.
The while loop shouldn't affect the speed as the original while loop ends after a selection is made as i've shown in the previous post.
-
Show me where in the WHILE loop the variable i changes.
If you step through the while loop you will see that
(setq number (vla-get-textstring i)
elevat (atoi number)
) Never changes the value elevat, it just keeps setting it to the same value because I never changes.
-
Foreach text entity in modelspace, elevat is set to nil and the while loop is run until elevat is set or the max radius is reached. Elevat is only set when a selection is made. Once elevat is set, the elevation of the first object in the selection set is changed and the process is repeated for the next text entity.
(vlax-for i (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(if (member (vla-get-objectname i) '("AcDbMText" "AcDbText"))
(progn
(vl-catch-all-apply 'vla-getboundingbox
(list i
'minpoint
'maxpoint
)
)
(setq pt1 (vlax-safearray->list minpoint)
pt2 (vlax-safearray->list maxpoint)
midpoint (mapcar '(lambda (a b) (/ (+ a b) 2.0)) pt1 pt2)
inc (/ (* pi 2) 10)
newradius radius
[color=red]elevat nil[/color])
(while [color=red](and (<= newradius maxrad)(null elevat))[/color]
(setq plist nil n 0)
(while (<= n 10)
(setq n (1+ n)
plist (append plist (list (polar midpoint (* inc n) newradius)))
)
)
(setq newradius (+ newradius increment))
[color=red](and
(setq linework
(ssget->vla-list
(ssget "_CP" plist (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,ELLIPSE")))))
(setq number (vla-get-textstring i)
elevat (atoi number)
)[/color]
(eq (vla-get-elevation (nth 0 linework)) 0.0)
(not (vla-put-elevation (nth 0 linework) elevat))
(setq count (1+ count))
(grtext -2 (strcat (itoa count) " Flat Segments Elevated."))
);and
);while
);progn
);if
);vlax-for
-
Show me where in the WHILE loop the variable i changes.
If you step through the while loop you will see that
(setq number (vla-get-textstring i)
elevat (atoi number)
) Never changes the value elevat, it just keeps setting it to the same value because I never changes.
Hi dear CAB and Alanjt
Very nice And quite elaborate. ,You're a real genius in autocad programming ...!?
I have some guests and must go to drink ... so Goodbye to you again :wink:
Thanks and I hope you always happy
-
Cab, i'm still a beginner in writing lisp routines and appreciate any advice you have for me. Am i missing something in the way one of these functions works?
The while loop SHOULD stop running when elevat is set and continue to the next entity in my example shouldn't it?
-
Foreach text entity in modelspace, elevat is set to nil and the while loop is run until elevat is set or the max radius is reached. Elevat is only set when a selection is made. Once elevat is set, the elevation of the first object in the selection set is changed and the process is repeated for the next text entity.
Ah yes, I see it now, Thanks.
-
Thanks again for looking at it Cab. I'll implement all other changes you made in my copy at work.
-
...For those without C3D...
This is really cool! And just a few lines :-) In VBA or .NET it takes much more code.
-
Piece of VBA code which will place Points at the insertion point of texts and taking the Z value of that text:
Public Sub ToolText2Point()
Dim acTekst As AcadText
Dim acPoint As AcadPoint
Dim pnt As Variant
Dim objTxt As AcadEntity
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
Dim strVal As String
Dim varData(3) As Variant
Dim intType(3) As Integer
Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
If objSelSet.Name = "HOOGTEPUNTEN" Then
objSelCol.Item("HOOGTEPUNTEN").Delete
Exit For
End If
Next
ThisDrawing.Utility.Prompt vbCrLf & "This tool places Points above texts with a Z value of selected text." & vbCrLf
Set objSelSet = objSelCol.Add("HOOGTEPUNTEN")
intType(0) = -4
varData(0) = "<OR"
intType(1) = 0
varData(1) = "TEXT"
intType(2) = 0
varData(2) = "MTEXT"
intType(3) = -4
varData(3) = "OR>"
objSelSet.SelectOnScreen intType, varData
For Each objTxt In objSelSet
pnt = objTxt.InsertionPoint
strVal = ReturnHoogteCijfer(objTxt.TextString)
If IsNumeric(strVal) Then
pnt(2) = CDbl(strVal)
Set acPoint = ThisDrawing.ModelSpace.AddPoint(pnt)
End If
Next objTxt
ThisDrawing.SelectionSets.Item("HOOGTEPUNTEN").Delete
End Sub
Function ReturnHoogteCijfer(varGetal As String) As String
Dim varGetalChecked As String
varGetalChecked = Trim(varGetal)
If Left(varGetalChecked, 1) = "+" Then
varGetalChecked = Right(varGetalChecked, Len(varGetalChecked) - 1)
End If
varGetalChecked = Replace(varGetalChecked, ".", ",", 1, 1)
ReturnHoogteCijfer = varGetalChecked
End Function
-
VB.Net solution with the same code to place Points, all in the zip file.
-
To use AeccMoveTextToElevation the actual COMMAND Line entry is MoveTextToElevation. I'm not sure if this command is available outside of C3D.
For those without C3D...
(defun c:MoveTextToElevation (/ ss z)
(vl-load-com)
(if (setq ss (ssget "_:L" '((0 . "MTEXT,TEXT"))))
(progn
(vlax-for x (setq ss (vla-get-activeselectionset
(cond (*AcadDoc*)
((setq *AcadDoc* (vla-get-activedocument
(vlax-get-acad-object)
)
)
)
)
)
)
(if (setq z (distof (vla-get-textstring x)))
(vlax-put x
'InsertionPoint
(reverse (cons z (cdr (reverse (vlax-get x 'InsertionPoint)))))
)
)
)
(vla-delete ss)
)
)
(princ)
)
Hi dear alanjt
Thanks for sharing your valuable codes , I worked with your codes in autocad 2010 , 2007 , 2004 and it action was same as each others and very good . in addition I executed it on many different types of topographic maps and results were perfectly correct. but at two types of my maps there are elevation strings and co responding survey point blocks . your routine put text string to z value of text insertion point but at real state the block points (surveying points ) must receive elevation string for replacing with z value of point's block coordinates . I want make two selection sets after your codes or in separate function so that the first one select all surveying point blocks and second select your 3d text in my map and at the next stage I want add z of your text to z 's block points (now all of them have zero value) but my problem is that there are many block points without elevation text near them , how I must filter them from those one have co responding text strings. :?
Robert
-
I must admit, I don't fully understand what you are wanting.
-
I must admit, I don't fully understand what you are wanting.
better data from his surveyor to work with ; if you ask me ;-)
-
I must admit, I don't fully understand what you are wanting.
better data from his surveyor to work with ; if you ask me ;-)
LoL
I've known crews like that.
-
I must admit, I don't fully understand what you are wanting.
Hi dear alanjt
I thank you for your quick reply
This is my sample position . you can see that elevation's strings lie above of survey points and point's number lie top of them (red text) . the z value of all surveying points are zero and I want convert them to elevation's strings value and some points like P4 don't have any elevation's text . please tell me how I can remove points like P4 from selection sets . :oops:
thanks
-
I must admit, I don't fully understand what you are wanting.
better data from his surveyor to work with ; if you ask me ;-)
Hi Higgs Boson's
this survey operation made more than 12 years ago and I don't Know surveyor man and at the other hand I haven't at this time any project like this , but it is a question for me and I want learn about this situation .
-
I must admit, I don't fully understand what you are wanting.
Hi dear alanjt
I thank you for your quick reply
This is my sample position . you can see that elevation's strings lie above of survey points and point's number lie top of them (red text) . the z value of all surveying points are zero and I want convert them to elevation's strings value and some points like P4 don't have any elevation's text . please tell me how I can remove points like P4 from selection sets . :oops:
thanks
post an example drawing.
-
I must admit, I don't fully understand what you are wanting.
Hi dear alanjt
I thank you for your quick reply
This is my sample position . you can see that elevation's strings lie above of survey points and point's number lie top of them (red text) . the z value of all surveying points are zero and I want convert them to elevation's strings value and some points like P4 don't have any elevation's text . please tell me how I can remove points like P4 from selection sets . :oops:
thanks
post an example drawing.
Hi Alanjt
Here is my sample file that I purged all contour lines and other objects for convenience and to read better I deducted from the heights 2000 Unit
-
Hi dear members
I wrote this codes for elevating block points by value of text string but it return this error message :
; error: bad argument type:
lentityp nil
why ...?! :oops:
(defun c:text2elev (/ tex textnam texent
texlen texhei blk
blknam blkent blkins
blkref delta_x filter
sst sstn sstent
ssblk ssblken ssblkent
blksiz index blklay
blkname texlay find_box
name_text find_text_ins new_ins_point_blk
ins_point_blk rigtexheit_point_1
rigtexheit_point_2 left_point_1
left_point_2
)
(setq tex (entsel "\n Please pick on ttexheie sample elevation text :")
textnam (car tex)
texent (entget textnam)
texlen (strlen (cdr (assoc 1 texent)))
texhei (cdr (assoc 40 texent))
texlay (cdr (assoc 8 texent))
blk (entsel "\n Please pick on ttexheie sample survey block point :")
blknam (car blk)
blkent (entget blknam)
blkins (cdr (assoc 10 blkent))
blklay (cdr (assoc 8 blkent))
blkname (cdr (assoc 2 blkent))
delta_y
(+ (abs (- (cadr (cdr (assoc 10 texent)))
(cadr (cdr (assoc 10 blkent)))
)
)
texhei
)
delta_x
(+ (abs (- (car (cdr (assoc 10 texent)))
(car (cdr (assoc 10 blkent)))
)
)
(car (cadr(textbox texent)))
)
);setq tex
(setq filter (list
(cons 0 "insert")
(cons 8 blklay)
(cons 2 blkname)
)
)
(setq ssblk (ssget "x" filter)
blksiz (sslengttexhei ssblk)
index 0
);setq ssblk
(wtexheiile (< index blksiz)
(setq blkref (ssname ssblk index))
(setq ins_point_blk (cdr (assoc 10 (entget blkref)))
left_point_1 (list (- (car ins_point_blk) 0.10)
(- (cadr ins_point_blk) 0.10)
0
)
left_point_2 (list (- (car ins_point_blk) 0.10)
(+ (cadr ins_point_blk) delta_y 0.10)
0
)
rigtexheit_point_1 (list (+ (car ins_point_blk) delta_x 0.10)
(- (cadr ins_point_blk) 0.10)
0
)
rigtexheit_point_2 (list (+ (car ins_point_blk) delta_x 0.10)
(+ (cadr ins_point_blk) delta_y 0.10)
0
)
pt (list left_point_1 left_point_2 rigtexheit_point_2 rigtexheit_point_1 left_point_1)
);setq ins_point_blk
(if (and
(setq find_box (ssget "WP"
pt
(list (cons 0 "text")
(cons 8 texlay)
(cons 40 texhei)
)
)
);setq "W"
);and
(progn
(if (= 1 (sslengttexhei find_box))
(progn
(setq name_text (ssname find_box index))
(setq find_text_ins (cdr (assoc 10 (entget name_text))))
(setq new_ins_point_blk
(list (car ins_point_blk)
(cadr ins_point_blk)
(atof
(cdr
(assoc
1
(entget name_text)
)
)
)
)
);setq new_ins_point_blk
(setq ins_point_blk new_ins_point_blk)
);progn
);end if
) ;progn
);end if
(setq index (1+ index))
);end wtexheiile
(command "regen all")
(command "zoom" "e")
(princ ins_point_blk)
(princ new_ins_point_blk)
(princ)
);defun
-
6 problems. 3 due to replacing "h" with "texhei" :roll:.
(defun c:text2elev (/ tex textnam texent
texlen texhei blk
blknam blkent blkins
blkref delta_x filter
sst sstn sstent
ssblk ssblken ssblkent
blksiz index blklay
blkname texlay find_box
name_text find_text_ins new_ins_point_blk
ins_point_blk rigtexheit_point_1
rigtexheit_point_2 left_point_1
left_point_2
)
(setq tex (entsel "\n Please pick on ttexheie sample elevation text :")
textnam (car tex)
texent (entget textnam)
texlen (strlen (cdr (assoc 1 texent)))
texhei (cdr (assoc 40 texent))
texlay (cdr (assoc 8 texent))
blk (entsel "\n Please pick on ttexheie sample survey block point :")
blknam (car blk)
blkent (entget blknam)
blkins (cdr (assoc 10 blkent))
blklay (cdr (assoc 8 blkent))
blkname (cdr (assoc 2 blkent))
delta_y
(+ (abs (- (cadr (cdr (assoc 10 texent)))
(cadr (cdr (assoc 10 blkent)))
)
)
texhei
)
delta_x
(+ (abs (- (car (cdr (assoc 10 texent)))
(car (cdr (assoc 10 blkent)))
)
)
(car (cadr(textbox texent)))
)
);setq tex
(setq filter (list
(cons 0 "insert")
(cons 8 blklay)
(cons 2 blkname)
)
)
(setq ssblk (ssget "x" filter)
[color=red] blksiz (sslength ssblk) ;; changed[/color]
index 0
);setq ssblk
[color=red] (while (< index blksiz) ;; changed[/color]
(setq blkref (ssname ssblk index))
(setq ins_point_blk (cdr (assoc 10 (entget blkref)))
left_point_1 (list (- (car ins_point_blk) 0.10)
(- (cadr ins_point_blk) 0.10)
0
)
left_point_2 (list (- (car ins_point_blk) 0.10)
(+ (cadr ins_point_blk) delta_y 0.10)
0
)
rigtexheit_point_1 (list (+ (car ins_point_blk) delta_x 0.10)
(- (cadr ins_point_blk) 0.10)
0
)
rigtexheit_point_2 (list (+ (car ins_point_blk) delta_x 0.10)
(+ (cadr ins_point_blk) delta_y 0.10)
0
)
pt (list left_point_1 left_point_2 rigtexheit_point_2 rigtexheit_point_1 left_point_1)
);setq ins_point_blk
(if (and
(setq find_box (ssget "WP"
pt
(list (cons 0 "text")
(cons 8 texlay)
(cons 40 texhei)
)
)
);setq "W"
);and
(progn
[color=red] (if (= 1 (sslength find_box)) ;; changed[/color]
(progn
[color=red] (setq name_text (ssname find_box 0)) ; changed[/color]
(setq find_text_ins (cdr (assoc 10 (entget name_text))))
(setq new_ins_point_blk
(list (car ins_point_blk)
(cadr ins_point_blk)
(atof
(cdr
(assoc
1
(entget name_text)
)
)
)
)
);setq new_ins_point_blk
[color=red] (entmod (subst (cons 10 new_ins_point_blk) (cons 10 ins_point_blk) (entget blkref))) ;; changed[/color]
);progn
);end if
) ;progn
);end if
(setq index (1+ index))
);end wtexheiile
[color=red] (command "regen") ; changed[/color]
(command "zoom" "e")
(princ ins_point_blk)
(princ new_ins_point_blk)
(princ)
);defun
-
6 problems. 3 due to replacing "h" with "texhei" :roll:.
(defun c:text2elev (/ tex textnam texent
texlen texhei blk
blknam blkent blkins
blkref delta_x filter
sst sstn sstent
ssblk ssblken ssblkent
blksiz index blklay
blkname texlay find_box
name_text find_text_ins new_ins_point_blk
ins_point_blk rigtexheit_point_1
rigtexheit_point_2 left_point_1
left_point_2
)
(setq tex (entsel "\n Please pick on ttexheie sample elevation text :")
textnam (car tex)
texent (entget textnam)
texlen (strlen (cdr (assoc 1 texent)))
texhei (cdr (assoc 40 texent))
texlay (cdr (assoc 8 texent))
blk (entsel "\n Please pick on ttexheie sample survey block point :")
blknam (car blk)
blkent (entget blknam)
blkins (cdr (assoc 10 blkent))
blklay (cdr (assoc 8 blkent))
blkname (cdr (assoc 2 blkent))
delta_y
(+ (abs (- (cadr (cdr (assoc 10 texent)))
(cadr (cdr (assoc 10 blkent)))
)
)
texhei
)
delta_x
(+ (abs (- (car (cdr (assoc 10 texent)))
(car (cdr (assoc 10 blkent)))
)
)
(car (cadr(textbox texent)))
)
);setq tex
(setq filter (list
(cons 0 "insert")
(cons 8 blklay)
(cons 2 blkname)
)
)
(setq ssblk (ssget "x" filter)
[color=red] blksiz (sslength ssblk) ;; changed[/color]
index 0
);setq ssblk
[color=red] (while (< index blksiz) ;; changed[/color]
(setq blkref (ssname ssblk index))
(setq ins_point_blk (cdr (assoc 10 (entget blkref)))
left_point_1 (list (- (car ins_point_blk) 0.10)
(- (cadr ins_point_blk) 0.10)
0
)
left_point_2 (list (- (car ins_point_blk) 0.10)
(+ (cadr ins_point_blk) delta_y 0.10)
0
)
rigtexheit_point_1 (list (+ (car ins_point_blk) delta_x 0.10)
(- (cadr ins_point_blk) 0.10)
0
)
rigtexheit_point_2 (list (+ (car ins_point_blk) delta_x 0.10)
(+ (cadr ins_point_blk) delta_y 0.10)
0
)
pt (list left_point_1 left_point_2 rigtexheit_point_2 rigtexheit_point_1 left_point_1)
);setq ins_point_blk
(if (and
(setq find_box (ssget "WP"
pt
(list (cons 0 "text")
(cons 8 texlay)
(cons 40 texhei)
)
)
);setq "W"
);and
(progn
[color=red] (if (= 1 (sslength find_box)) ;; changed[/color]
(progn
[color=red] (setq name_text (ssname find_box 0)) ; changed[/color]
(setq find_text_ins (cdr (assoc 10 (entget name_text))))
(setq new_ins_point_blk
(list (car ins_point_blk)
(cadr ins_point_blk)
(atof
(cdr
(assoc
1
(entget name_text)
)
)
)
)
);setq new_ins_point_blk
[color=red] (entmod (subst (cons 10 new_ins_point_blk) (cons 10 ins_point_blk) (entget blkref))) ;; changed[/color]
);progn
);end if
) ;progn
);end if
(setq index (1+ index))
);end wtexheiile
[color=red] (command "regen") ; changed[/color]
(command "zoom" "e")
(princ ins_point_blk)
(princ new_ins_point_blk)
(princ)
);defun
Hi Roy
First I must thank you to reply and good hints
I changed my codes to your red line format and run it on a sample file that had 8 elements (like attached image) without any error messages but when I checked block points by id command the z value of blocks : P1,P6,P7,P8 stay at old value (zero) and other ones changed to corresponding text string values , it means that correctly half of them changed and elevated and others not elevated , please tell me why this occurs ?
Robert
-
this vlx from xanadu will do what you want
http://www.xanadu.cz/dl_file.asp?ID=583
p
-
@ Robert98
Without the drawing I would have to guess, but I think that for these points the text is further away so that a portion of the text falls outside the WP selection.
You could try two thing:
Make the tolerance that you use (currently 0.1) bigger.
Use (ssget "CP" ...) instead of (ssget "WP" ...).
If that doesn't work then please post the drawing.
BTW: Nice work Robert!
-
@ Pad
Robert98 wants to move blocks (representing points) and not texts.
-
ah Roy, sorry I didn't notice the survey points in the drawing.
P
-
Hi Jvillarreal
I have just tested your autoelevate routine and it works extremely well.
One thing though, I see it rounds the contour bands up to a whole number.
How I can I change it so that it can account for 1/2 metre contours or even 0.25m contours?
Thanks
P
-
@ Robert98
Without the drawing I would have to guess, but I think that for these points the text is further away so that a portion of the text falls outside the WP selection.
You could try two thing:
Make the tolerance that you use (currently 0.1) bigger.
Use (ssget "CP" ...) instead of (ssget "WP" ...).
If that doesn't work then please post the drawing.
BTW: Nice work Robert!
Hi Roy
I'm sorry because I had a big mistake and resolved that ,at present no problem And everything is sorted On and going well , thank you for everything Roy . ^-^
-
Hi Jvillarreal
I have just tested your autoelevate routine and it works extremely well.
One thing though, I see it rounds the contour bands up to a whole number.
How I can I change it so that it can account for 1/2 metre contours or even 0.25m contours?
Thanks
P
Thanks, I'm glad you like it. Changing atoi to atof should do it.
-
yep it has, thanks!