Surveying Bearing/Distance LISP Routine

[BoarsNest01]

Does anyone know of a LISP Routine that will label a line with the bearing and distance of said line (each entity in single line text)? I had a great LISP Routine that worked in LDD but I can't get it to work in CIVIL3D. Any help would be appreciated.

[rkmcswain]

Here is one (It's not mine, I just found it here on augi)

22623

[BoarsNest01]

I also found that routine and it is just not user friendly. With the old LISP that I had, all you had to do was type in the routine and select the line in which you were interested in. I have searched for similar routines and have not found any that are as efficient. Thanks for your help though. If anybody knows of anything, please help!!!

[Tom Beauford]

Line_Label.lsp labels lines, arcs & polyline segments using current text size.
I have this macro in the CUI:
^C^C^P(or C:Label (load "Line_Label.lsp"));Label

For curves it creates a curve table. Put Line_Label.lsp, Dim_Arc.DWG & Dim_Line.DWG in a folder in your support path. The drawings are inserted as blocks with attributes.

[BoarsNest01]

Tom-

Thanks for the help. I have done everything that you said but I get the following error:
"Error: no function definition: VLAX-ENAME->VLA-OBJECT". Any ideas?

[Opie]

Tom-

Thanks for the help. I have done everything that you said but I get the following error:
"Error: no function definition: VLAX-ENAME->VLA-OBJECT". Any ideas?
Run (vl-load-com) before running Tom's attached code. You could also add it to the file at the beginning of the routine. It does not hurt if it is run more than once.

[rkmcswain]

Add (vl-load-com) to the top of the file.

[Tom Beauford]

Add (vl-load-com) to the top of the file.
Thanks R. K!. I always forget not everyone has that in their acad.lsp.

[BoarsNest01]

Thanks guys. I got the routine to work and it works well. It is a little more advance than what I need. Rather than opening up a separate edit box, does anyone have a LISP routine that will simply label the line with its Bearing & Distance (in single line text format for each entity while matching the size and layer that is current).

[Tom Beauford]

Thanks guys. I got the routine to work and it works well. It is a little more advance than what I need. Rather than opening up a separate edit box, does anyone have a LISP routine that will simply label the line with its Bearing & Distance (in single line text format for each entity while matching the size and layer that is current).
The edit box is mostly so I can clearly see the labeled information.
You can always remove the two lines that call the attribute editor:
(command "._DDATTE" (entlast))

[rkmcswain]

Ok - I have to ask - why don't you want to just use the labeling commands in C3D?

[ccowgill]

you could try this, it puts the text on the annotation layer, and it gives you a couple more options. Option 3 sounds like what you want. It is supposed to drop the text at the midpoint of the object selected, rotated parallel (or tangent) to the object at that point.

(defun MakeLayer (lyrname acDoc / lyrobj)
(vl-load-com)
(if
(not
(vl-catch-all-error-p
(setq lyrobj
(vl-catch-all-apply
'vla-add
(list (vla-get-layers acDoc) lyrname)
) ;_ end of vl-catch-all-apply
) ;_ end of setq
) ;_ end of vl-catch-all-error-p
) ;_ end of not
lyrobj
) ;_ end of if
) ;_ end of defun
(defun c:lengthtext (/ lengthmode object
objchk listobj vlobj
MidPoint Param startpline
endpline vlobjlen1 angle1
Ang TH vlobjang
textobj1 textobj2 vlobjang1
vlobjang2 lengthscale lyrobj
)
(if (not (tblsearch "Layer" "Annotation"))
(if (setq lyrobj (MakeLayer "Annotation" acadDocument))
(progn
(vla-put-color lyrobj acgreen)
(vla-put-plottable lyrobj :vlax-true)
(vlax-release-object lyrobj)
) ;_ end of progn
(setq errmsg "\nLayer Make failed for Annotation layer")
) ;_ end of if
) ;_ end of if

(setq lengthmode
(getint
"\nSpecify Mode (1 = One Decimal, 2 = Two Decimals, 3 = Two Decimals with Bearing"
) ;_ end of getint
lengthscale (atoi (vl-string-left-trim
":"
(vl-string-left-trim
"1234567890"
(getvar "cannoscale")
) ;_ end of vl-string-left-trim
) ;_ end of vl-string-left-trim
) ;_ end of atoi
) ;_ end of setq
(if (= lengthmode 3)
(setq
object
(ssget
(list
(cons 0
"ARC,LINE"
) ;_ end of cons
) ;_ end of list
) ;_ end of ssget
) ;_ end of setq
(setq
object
(ssget
(list
(cons 0
"POLYLINE,*CONTOUR,ARC,LINE,LWPOLYLINE,2DPOLYLINE"
) ;_ end of cons
) ;_ end of list
) ;_ end of ssget
) ;_ end of setq
) ;_ end of if
(while (setq listobj (ssname object 0))
(setq vlobj (vlax-ename->vla-object listobj))
(if (/= (cdr (assoc 0 (entget listobj))) "ARC")
(setq vlobjlen1 (vla-get-length vlobj)
objchk 1
) ;_ end of setq
(setq vlobjlen1 (vla-get-arclength vlobj)
objchk 2
) ;_ end of setq
) ;_ end of if
(setq MidPoint (vlax-curve-getpointatdist
vlObj
(/ vlobjlen1 2)
) ;_ end of vlax-curve-getpointatdist
Param (vlax-curve-getParamAtPoint VlObj MidPoint)
startpline (vlax-curve-getStartParam VlObj)
endpline (vlax-curve-getEndParam VlObj)
angle1 (vlax-curve-getFirstDeriv
VlObj
(/ (- endpline startpline) 2)
) ;_ end of vlax-curve-getFirstDeriv
TH (* 0.08 lengthscale)
) ;_ end of setq
(if (= objchk 1)
(progn
(if (equal (car angle1) 0.0 0.01)
(setq Ang (/ pi 2))
(setq Ang (atan (/ (cadr angle1) (car angle1))))
) ;_ end of if
(setq
vlobjang (angtos Ang 4 3)
vlobjang1 (vl-string-left-trim "NS 0123456789" vlobjang)
vlobjang2 (vl-string-right-trim
"EW \"0123456789'"
vlobjang
) ;_ end of vl-string-right-trim
vlobjang2 (vl-string-right-trim "d" vlobjang2)
vlobjang (strcat vlobjang2 "%%" vlobjang1)
) ;_ end of setq
) ;_ end of progn
(setq
Ang (- (/ (+ (vla-get-endangle vlobj)
(vla-get-startangle vlobj)
) ;_ end of +
2
) ;_ end of /
(/ pi 2)
) ;_ end of -
vlobjang (angtos Ang 4 3)
vlobjang1 (vl-string-left-trim "NS 0123456789" vlobjang)
vlobjang2 (vl-string-right-trim "EW \"0123456789'" vlobjang)
vlobjang2 (vl-string-right-trim "d" vlobjang2)
vlobjang (strcat vlobjang2 "%%" vlobjang1)
) ;_ end of setq
) ;_ end of if
(cond
((= lengthmode 1)
(if (wcmatch (rtos vlobjlen1 2 1) "*`.*")
(setq vlobjlen (strcat (rtos vlobjlen1 2 1) "'"))
(setq vlobjlen (strcat (rtos vlobjlen1 2 1) ".0'"))
) ;_ end of if
(setq textObj1 (vla-addtext
acadModelSpace
vlobjlen
(vlax-3d-point Midpoint)
TH
) ;end vla-addtext
) ;end setq
)
((= lengthmode 2)
(cond
((wcmatch (rtos vlobjlen1 2 2) "*`.##")
(setq vlobjlen (strcat (rtos vlobjlen1 2 2) "'")
) ;_ end of setq
)
((wcmatch (rtos vlobjlen1 2 2) "*`.#")
(setq vlobjlen (strcat (rtos vlobjlen1 2 2) "0'")
) ;_ end of setq
)
((wcmatch (rtos vlobjlen1 2 2) "*")
(setq vlobjlen (strcat (rtos vlobjlen1 2 2) ".00'")
) ;_ end of setq
)
) ;_ end of cond
(setq
textObj1 (vla-addtext
acadModelSpace
vlobjlen
(vlax-3d-point Midpoint)
TH
) ;end vla-addtext
) ;end setq
)
((= lengthmode 3)
(cond
((wcmatch (rtos vlobjlen1 2 2) "*`.##")
(setq vlobjlen (strcat (rtos vlobjlen1 2 2) "'")
) ;_ end of setq
)
((wcmatch (rtos vlobjlen1 2 2) "*`.#")
(setq vlobjlen (strcat (rtos vlobjlen1 2 2) "0'")
) ;_ end of setq
)
((wcmatch (rtos vlobjlen1 2 2) "*")
(setq vlobjlen (strcat (rtos vlobjlen1 2 2) ".00'")
) ;_ end of setq
)
) ;_ end of cond
(setq
textObj1 (vla-addtext
acadModelSpace
vlobjlen
(vlax-3d-point Midpoint)
TH
) ;end vla-addtext
textobj2 (vla-addtext
acadModelSpace
vlobjang
(vlax-3d-point Midpoint)
TH
) ;_ end of vla-addtext
) ;end setq
)
) ;_ end of cond
(vla-put-color textobj1 256) ;change color
(vla-put-alignment textobj1 13) ;change justification
(vla-put-textalignmentpoint
textobj1
(vlax-3d-point Midpoint)
) ;_ end of vla-put-textalignmentpoint
;change insetion point
(vla-put-rotation textobj1 Ang)
;change rotation
(vla-put-layer textobj1 "Annotation")
(if (/= textObj2 nil)
(progn
(vla-put-color textobj2 256)
(vla-put-alignment textobj2 13)
(vla-put-textalignmentpoint
textobj2
(vlax-3d-point
(list
(+ (car Midpoint) (* (sin ang) (* 0.16 lengthscale)))
(- (cadr Midpoint) (* (cos ang) (* 0.16 lengthscale)))
(caddr Midpoint)
) ;_ end of list
) ;_ end of vlax-3d-point
) ;_ end of vla-put-textalignmentpoint
(vla-put-rotation textobj2 Ang)
(vla-put-layer textobj2 "Annotation")
) ;_ end of progn
) ;_ end of if
(ssdel listobj object)
) ;end while
) ;end defun

[margaretl]

Ok - I have to ask - why don't you want to just use the labeling commands in C3D?

I agree, Why???

[xfirez]

you could try this, it puts the text on the annotation layer, and it gives you a couple more options. Option 3 sounds like what you want. It is supposed to drop the text at the midpoint of the object selected, rotated parallel (or tangent) to the object at that point.

(defun MakeLayer (lyrname acDoc / lyrobj)
(vl-load-com)
(if
(not
(vl-catch-all-error-p
(setq lyrobj
(vl-catch-all-apply
'vla-add
(list (vla-get-layers acDoc) lyrname)
) ;_ end of vl-catch-all-apply
) ;_ end of setq
) ;_ end of vl-catch-all-error-p
) ;_ end of not
lyrobj
) ;_ end of if
) ;_ end of defun
(defun c:lengthtext (/ lengthmode object
objchk listobj vlobj
MidPoint Param startpline
endpline vlobjlen1 angle1
Ang TH vlobjang
textobj1 textobj2 vlobjang1
vlobjang2 lengthscale lyrobj
)
(if (not (tblsearch "Layer" "Annotation"))
(if (setq lyrobj (MakeLayer "Annotation" acadDocument))
(progn
(vla-put-color lyrobj acgreen)
(vla-put-plottable lyrobj :vlax-true)
(vlax-release-object lyrobj)
) ;_ end of progn
(setq errmsg "\nLayer Make failed for Annotation layer")
) ;_ end of if
) ;_ end of if

(setq lengthmode
(getint
"\nSpecify Mode (1 = One Decimal, 2 = Two Decimals, 3 = Two Decimals with Bearing"
) ;_ end of getint
lengthscale (atoi (vl-string-left-trim
":"
(vl-string-left-trim
"1234567890"
(getvar "cannoscale")
) ;_ end of vl-string-left-trim
) ;_ end of vl-string-left-trim
) ;_ end of atoi
) ;_ end of setq
(if (= lengthmode 3)
(setq
object
(ssget
(list
(cons 0
"ARC,LINE"
) ;_ end of cons
) ;_ end of list
) ;_ end of ssget
) ;_ end of setq
(setq
object
(ssget
(list
(cons 0
"POLYLINE,*CONTOUR,ARC,LINE,LWPOLYLINE,2DPOLYLINE"
) ;_ end of cons
) ;_ end of list
) ;_ end of ssget
) ;_ end of setq
) ;_ end of if
(while (setq listobj (ssname object 0))
(setq vlobj (vlax-ename->vla-object listobj))
(if (/= (cdr (assoc 0 (entget listobj))) "ARC")
(setq vlobjlen1 (vla-get-length vlobj)
objchk 1
) ;_ end of setq
(setq vlobjlen1 (vla-get-arclength vlobj)
objchk 2
) ;_ end of setq
) ;_ end of if
(setq MidPoint (vlax-curve-getpointatdist
vlObj
(/ vlobjlen1 2)
) ;_ end of vlax-curve-getpointatdist
Param (vlax-curve-getParamAtPoint VlObj MidPoint)
startpline (vlax-curve-getStartParam VlObj)
endpline (vlax-curve-getEndParam VlObj)
angle1 (vlax-curve-getFirstDeriv
VlObj
(/ (- endpline startpline) 2)
) ;_ end of vlax-curve-getFirstDeriv
TH (* 0.08 lengthscale)
) ;_ end of setq
(if (= objchk 1)
(progn
(if (equal (car angle1) 0.0 0.01)
(setq Ang (/ pi 2))
(setq Ang (atan (/ (cadr angle1) (car angle1))))
) ;_ end of if
(setq
vlobjang (angtos Ang 4 3)
vlobjang1 (vl-string-left-trim "NS 0123456789" vlobjang)
vlobjang2 (vl-string-right-trim
"EW \"0123456789'"
vlobjang
) ;_ end of vl-string-right-trim
vlobjang2 (vl-string-right-trim "d" vlobjang2)
vlobjang (strcat vlobjang2 "%%" vlobjang1)
) ;_ end of setq
) ;_ end of progn
(setq
Ang (- (/ (+ (vla-get-endangle vlobj)
(vla-get-startangle vlobj)
) ;_ end of +
2
) ;_ end of /
(/ pi 2)
) ;_ end of -
vlobjang (angtos Ang 4 3)
vlobjang1 (vl-string-left-trim "NS 0123456789" vlobjang)
vlobjang2 (vl-string-right-trim "EW \"0123456789'" vlobjang)
vlobjang2 (vl-string-right-trim "d" vlobjang2)
vlobjang (strcat vlobjang2 "%%" vlobjang1)
) ;_ end of setq
) ;_ end of if
(cond
((= lengthmode 1)
(if (wcmatch (rtos vlobjlen1 2 1) "*`.*")
(setq vlobjlen (strcat (rtos vlobjlen1 2 1) "'"))
(setq vlobjlen (strcat (rtos vlobjlen1 2 1) ".0'"))
) ;_ end of if
(setq textObj1 (vla-addtext
acadModelSpace
vlobjlen
(vlax-3d-point Midpoint)
TH
) ;end vla-addtext
) ;end setq
)
((= lengthmode 2)
(cond
((wcmatch (rtos vlobjlen1 2 2) "*`.##")
(setq vlobjlen (strcat (rtos vlobjlen1 2 2) "'")
) ;_ end of setq
)
((wcmatch (rtos vlobjlen1 2 2) "*`.#")
(setq vlobjlen (strcat (rtos vlobjlen1 2 2) "0'")
) ;_ end of setq
)
((wcmatch (rtos vlobjlen1 2 2) "*")
(setq vlobjlen (strcat (rtos vlobjlen1 2 2) ".00'")
) ;_ end of setq
)
) ;_ end of cond
(setq
textObj1 (vla-addtext
acadModelSpace
vlobjlen
(vlax-3d-point Midpoint)
TH
) ;end vla-addtext
) ;end setq
)
((= lengthmode 3)
(cond
((wcmatch (rtos vlobjlen1 2 2) "*`.##")
(setq vlobjlen (strcat (rtos vlobjlen1 2 2) "'")
) ;_ end of setq
)
((wcmatch (rtos vlobjlen1 2 2) "*`.#")
(setq vlobjlen (strcat (rtos vlobjlen1 2 2) "0'")
) ;_ end of setq
)
((wcmatch (rtos vlobjlen1 2 2) "*")
(setq vlobjlen (strcat (rtos vlobjlen1 2 2) ".00'")
) ;_ end of setq
)
) ;_ end of cond
(setq
textObj1 (vla-addtext
acadModelSpace
vlobjlen
(vlax-3d-point Midpoint)
TH
) ;end vla-addtext
textobj2 (vla-addtext
acadModelSpace
vlobjang
(vlax-3d-point Midpoint)
TH
) ;_ end of vla-addtext
) ;end setq
)
) ;_ end of cond
(vla-put-color textobj1 256) ;change color
(vla-put-alignment textobj1 13) ;change justification
(vla-put-textalignmentpoint
textobj1
(vlax-3d-point Midpoint)
) ;_ end of vla-put-textalignmentpoint
;change insetion point
(vla-put-rotation textobj1 Ang)
;change rotation
(vla-put-layer textobj1 "Annotation")
(if (/= textObj2 nil)
(progn
(vla-put-color textobj2 256)
(vla-put-alignment textobj2 13)
(vla-put-textalignmentpoint
textobj2
(vlax-3d-point
(list
(+ (car Midpoint) (* (sin ang) (* 0.16 lengthscale)))
(- (cadr Midpoint) (* (cos ang) (* 0.16 lengthscale)))
(caddr Midpoint)
) ;_ end of list
) ;_ end of vlax-3d-point
) ;_ end of vla-put-textalignmentpoint
(vla-put-rotation textobj2 Ang)
(vla-put-layer textobj2 "Annotation")
) ;_ end of progn
) ;_ end of if
(ssdel listobj object)
) ;end while
) ;end defun


i got some error?

Command: appload
lengthtext.lsp successfully loaded.


Command:
Command:
Command: lengthtext
*Cancel*

Command:
Command:
Command: bad argument type: VLA-OBJECT nil
Command: lengthtext
*Cancel*
bad argument type: VLA-OBJECT nil
oliver

[ccowgill]

i got some error?

Command: appload
lengthtext.lsp successfully loaded.


Command:
Command:
Command: lengthtext
*Cancel*

Command:
Command:
Command: bad argument type: VLA-OBJECT nil
Command: lengthtext
*Cancel*
bad argument type: VLA-OBJECT niloliver
what version of AutoCAD are you running, if it is prior to 08, the cannotationscale sysvar does not exist. Also, you may need to add the following to the program and the local variables as well:

(vl-load-com)
(setq acadObject (vlax-get-acad-object)) ;get Autocad object
(setq acadDocument (vla-get-ActiveDocument acadObject))
;get the Activedocument object
(setq DwgProps (vla-get-SummaryInfo acadDocument))
;get custom drawing properties
(setq acadModelSpace (vla-get-modelspace acadDocument))
;get the modelspace block
(setq acadPaperSpace (vla-get-paperspace acadDocument))
;get the paperspace block
(setq acadversion (getvar "acadver"))

[xfirez]

i'm using acad2004?

[ccowgill]

make the change in red:

(setq lengthmode
(getint
"\nSpecify Mode (1 = One Decimal, 2 = Two Decimals, 3 = Two Decimals with Bearing"
) ;_ end of getint
lengthscale (getint "\nInput scale of drawing:\n")
) ;_ end of setq
the scale you would input for instance would be: if the scale will be 1/40, input 40, 1/100, input 100, etc.

[jsnt1109]

try this ..if u can modify it better pls let me know.thanks
hope can help.
http://www.cadtutor.net/forum/showthread.php?t=20991

[boesiii]

Here's my program, it works by picking two points and labeling the bearing and distance between them. If you need help with it email me boesiii at yahoo dot com

I also have another one that labels each individual line in a polyline but its back at the office.

[SuperD]

I also found that routine and it is just not user friendly. With the old LISP that I had, all you had to do was type in the routine and select the line in which you were interested in. I have searched for similar routines and have not found any that are as efficient. Thanks for your help though. If anybody knows of anything, please help!!!

Here's a simple but efficient routine on found on the net that was developed in 1990. I had to make some minor changes to it so that it would work in 2008 but I will not accept credit for it. I love how sweet and efficient it is with various options for displaying the data.

[hilln]

You don't need a lisp routine in Civil3D. General/Add labels/ then choose Feature: Line and Curve. Pick the line to label the bearing and distance. Edit the Command Line in Toolspace/Settings/General/Label Style/Line to have the label the way you want it to show.

Of course, you must have a line first to label. I am using Civil3D 2009.

[zsumera]

You don't need a lisp routine in Civil3D. General/Add labels/ then choose Feature: Line and Curve. Pick the line to label the bearing and distance. Edit the Command Line in Toolspace/Settings/General/Label Style/Line to have the label the way you want it to show.

Of course, you must have a line first to label. I am using Civil3D 2009.

What about if I need to label just parts of that line and than again parts of that line. They should left the ability to put labels between two points.