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

[GreyHippo]

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.

[mervc612493]

Is there is a lisp function that writes bearing and distance in metric without the foot symbol and and quadrant bearings

[fixo]

Try this code, not seriously tested though

;; local defuns

;;--------------------------------------------;;

;; draw text
(defun vk_true_text (txt t0 h ug just / elast)
(setq elast (entlast))
(if (= (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE")))) 0.0)
(if (/= (strcase just) "L")
(vl-cmdf "_.TEXT" "_J" just t0 h ug txt)
(vl-cmdf "_.TEXT" t0 h ug txt)
) ;_ if
(if (/= (strcase just) "L")
(vl-cmdf "_.TEXT" "_J" just t0 ug txt)
(vl-cmdf "_.TEXT" t0 ug txt)
) ;_ if
) ;_ if
(if (/= elast (entlast))
(entlast)
nil
) ;_ if
)
;;--------------------------------------------;;

; Convert value in radians to degrees
(defun rtd (a)
(* 180.0 (/ a pi))
)

;;------------------------------------- main part ---------------------------------;;
(defun C:BEAR(/ a ang b curth dist elist en ent gkw mp mp2 osm p1 p2 strang strdist txh)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(setq curth (getvar "dimtxt"))
(initget 6)
(setq txh (getreal
(strcat "\nEnter the text height <" (rtos curth) ">: ")
)
)
(cond ((not txh) (setq txh curth)))

(initget 1 "Select Enter")
(setq gkw (getkword
"\nSelect line or Enter two points (Select/Enter) <S>: "
)
)
(if (eq "Select" gkw)
(progn
(setq ent (entsel "\nSelect line: "))
(setq en (car ent))
(setq elist (entget en))
(setq p1 (cdr (assoc 10 elist))
p2 (cdr (assoc 11 elist))
mp (mapcar '(lambda (a b) (/ (+ a b) 2)) p1 p2)
ang (angle p1 p2)

dist (distance p1 p2)
strdist (rtos dist 2 3)
strang (angtos ang 0 2)
)

(if (< (/ pi 2) ang (* pi 1.5))
(setq ang (+ pi ang))
)
(setq mp2 (polar mp (- ang (/ pi 2)) txh)
mp (polar mp (+ (/ pi 2) ang) (/ txh 2))
)

(vk_true_text strdist mp txh (rtd ang) "BC")

(vk_true_text strang mp2 txh (rtd ang) "TC")

)
(progn
(setq p1 (getpoint "\nSpecify a first point: "))
(setq p2 (getpoint p1 "\nSpecify a second point: "))
(setq mp (mapcar '(lambda (a b) (/ (+ a b) 2)) p1 p2)
ang (angle p1 p2)


dist (distance p1 p2)
strdist (rtos dist 2 3)
strang (angtos ang 0 2)
)
(if (< (/ pi 2) ang (* pi 1.5))
(setq ang (+ pi ang))
)
(setq mp2 (polar mp (- ang (/ pi 2)) txh)
mp (polar mp (+ (/ pi 2) ang) (/ txh 2))
)

(vk_true_text strdist mp txh (rtd ang) "BC")

(vk_true_text strang mp2 txh (rtd ang) "TC")
)
)


(setvar "osmode" osm)
(princ)
)

(prompt "\nType BEAR to start command")
(prin1)

~'J'~

[steveo]

Try this code, not seriously tested though

;; local defuns

;;--------------------------------------------;;

;; draw text
(defun vk_true_text (txt t0 h ug just / elast)
(setq elast (entlast))
(if (= (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE")))) 0.0)
(if (/= (strcase just) "L")
(vl-cmdf "_.TEXT" "_J" just t0 h ug txt)
(vl-cmdf "_.TEXT" t0 h ug txt)
) ;_ if
(if (/= (strcase just) "L")
(vl-cmdf "_.TEXT" "_J" just t0 ug txt)
(vl-cmdf "_.TEXT" t0 ug txt)
) ;_ if
) ;_ if
(if (/= elast (entlast))
(entlast)
nil
) ;_ if
)
;;--------------------------------------------;;

; Convert value in radians to degrees
(defun rtd (a)
(* 180.0 (/ a pi))
)

;;------------------------------------- main part ---------------------------------;;
(defun C:BEAR(/ a ang b curth dist elist en ent gkw mp mp2 osm p1 p2 strang strdist txh)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(setq curth (getvar "dimtxt"))
(initget 6)
(setq txh (getreal
(strcat "\nEnter the text height <" (rtos curth) ">: ")
)
)
(cond ((not txh) (setq txh curth)))

(initget 1 "Select Enter")
(setq gkw (getkword
"\nSelect line or Enter two points (Select/Enter) <S>: "
)
)
(if (eq "Select" gkw)
(progn
(setq ent (entsel "\nSelect line: "))
(setq en (car ent))
(setq elist (entget en))
(setq p1 (cdr (assoc 10 elist))
p2 (cdr (assoc 11 elist))
mp (mapcar '(lambda (a b) (/ (+ a b) 2)) p1 p2)
ang (angle p1 p2)

dist (distance p1 p2)
strdist (rtos dist 2 3)
strang (angtos ang 0 2)
)

(if (< (/ pi 2) ang (* pi 1.5))
(setq ang (+ pi ang))
)
(setq mp2 (polar mp (- ang (/ pi 2)) txh)
mp (polar mp (+ (/ pi 2) ang) (/ txh 2))
)

(vk_true_text strdist mp txh (rtd ang) "BC")

(vk_true_text strang mp2 txh (rtd ang) "TC")

)
(progn
(setq p1 (getpoint "\nSpecify a first point: "))
(setq p2 (getpoint p1 "\nSpecify a second point: "))
(setq mp (mapcar '(lambda (a b) (/ (+ a b) 2)) p1 p2)
ang (angle p1 p2)


dist (distance p1 p2)
strdist (rtos dist 2 3)
strang (angtos ang 0 2)
)
(if (< (/ pi 2) ang (* pi 1.5))
(setq ang (+ pi ang))
)
(setq mp2 (polar mp (- ang (/ pi 2)) txh)
mp (polar mp (+ (/ pi 2) ang) (/ txh 2))
)

(vk_true_text strdist mp txh (rtd ang) "BC")

(vk_true_text strang mp2 txh (rtd ang) "TC")
)
)


(setvar "osmode" osm)
(princ)
)

(prompt "\nType BEAR to start command")
(prin1)

~'J'~

FIXO; I believe the angle reported by the program is the complement of the angle which needs to be reported. Angle needs to be reported from north or south, not east or west. (angle reported as 16.8 degrees, should be 73.2 degrees)
Steve

[fixo]

Thank you Steve, but I'm not a math, I'm still waiting for OP response
He wrote:
>>

Is there is a lisp function that writes bearing and distance in metric without the foot symbol and and quadrant bearings

Oleg

[Scooby]

Hey, guys

I need a lisp that label the azimuth & distance by picking a line?
The azimuth is according to the position of UCS from the AutoCad2012.



Kind Regards,

[rkmcswain]

Hey, guys

I need a lisp that label the azimuth & distance by picking a line?
The azimuth is according to the position of UCS from the AutoCad2012.


Take a look at
http://forums.autodesk.com/t5/Visual-LISP-AutoLISP-and-General/AZIMUTH-distance/td-p/2668454

[GreyHippo]

See file below.

[Scooby]

86394

Hello guys,
Thanks for the help but I saw this lisp and didn't work.
I need lisp that give me azimuth and distance: e.g. 25°26'23" - 15,30m.

Following attached file as a model.
Thanks.

[GreyHippo]

Try this lisp, the previous had some basic error checking which I commented out.

[Scooby]

Hey, GreyHippo.
BD_POLY.lisp is great, but the bearing that I need is e.g 159°18'10" and your program give N 44°40'34" E in the same polyline.


Just take a look in the Attached Files, please.
86397

[GreyHippo]

See attached below.

[Scooby]

Hey, GreyHippo.
The problem is the UCS.
The BD_POLY lisp calcutes the bearing of UCS position ORTHO, but my bearing is according to specific UCS name LLGSF-ESCRITURA.

Kind Regards,
Fabricio

[Scooby]

Sorry Grey Hippo,
I made a mistake. I wrote UCS position ORHTO, it's worng. The correct is UCS position WORLD.

[GreyHippo]

See attached file below.

[Scooby]

Thanks, Grey Hippo.
You're awesome!!!
The PD_BOLY_V2 lisp is fantastic!!

Sorry to bother you, my friend.
Kind Regards.

[Scooby]

GreyHippo,
I'd like to know why some drawings don't put the bearing and distance on the line?
I have to press F2 to see them.

[Heather_W]

I snagged the following bearings.lsp I love this routine! However, I work in architectual vs. engineering. So when it gives me the distance it will say 780' instead of 65'. How do I get it to divide the length by 12...or give the true length?
Also, when I complete the routine, it wipes out all my osnaps. Can that be fixed?
If you couldn't guess....I don't know much about code. :)

Thanks in advance!
oh...and I tried to attached the .lsp but it wouldn't let me for some reason so I just copied it in.




; o Command: (load "BEARINGS") BEARINGS
; o Automatically Annotates all lines, in a window or crossing selection set,
; with SURVEYOR style BEARINGS and DISTANCES, in user specified format.
; o Removes non-line entities from selection set before annotating
; selected line entities.
; o Left-Right Orientation of text placement is determined by the direction
; the LINE ENTITY was entered. CLOCKWISE line orientation is assumed for
; L and R KEYWORDS.
; o Surveyor Angles have a real degree mark. Distances have a foot mark to
; represent decimal feet.
; o Adjusts text placement based on TEXTSIZE.
; o Adjusts NW and SE text orientation for better readability of the
; Bearing-Distance dimension.
; o User specified Bearing Direction reversal.
; o Resets current STYLE HT to 0.0
; o KEYWORDS used to select desired insertion format are:
;
; LR - BEARING/DIST Left/Right
; RL - BEARING/DIST Right/Left
; LL - BEARING-DIST Left
; RR - BEARING-DIST Right
; BL - BEARING Left
; BR - BEARING Right
; DL - DIST Left
; DR - DIST Right
;
(DEFUN CHGD(OS / NS SL CT LT )
(SETQ NS "" SL (STRLEN OS) CT 1)
(WHILE (<= CT SL)
(SETQ LT (SUBSTR OS CT 1))
(IF (= LT "d")(SETQ LT "%%d"))
(SETQ CT (1+ CT) NS (STRCAT NS LT))))

(DEFUN C:BEARINGS( / P1 P2 P3 P4 DSTR DIST ASTR ANG TMP ENT LEN SS FLG KW1 TH KW )
(SETVAR "OSMODE" 0)
(SETVAR "ANGBASE" 0)
(SETVAR "CMDECHO" 0)
(command "style" "" "" 0.0 "" "" "" "" "" nil)
(PRINC "Note: ALL DISTANCES are from the X-Y PLANE\n")
(INITGET 1 "LR RL LL RR BL BR DL DR")
(SETQ KW (GETKWORD "LR RL LL RR BL BR DL DR: "))
(initget (+ 2 4))
(SETQ TH (GETDIST (strcat "TEXT HEIGHT <" (rtos (getvar "TEXTSIZE")) "> :")))
(if (= nil TH)(setq th (getvar "textsize")))
(INITGET 1 "Yes No")
(SETQ KW1 (GETKWORD "Reverse the Bearing Direction <Y>es <N>o: "))
(SETQ FLG 0)
(if (= KW1 "Yes")(progn
(IF (and(= KW "LR")(= FLG 0))(SETQ KW "RL" FLG 1))
(IF (and(= KW "RL")(= FLG 0))(SETQ KW "LR" FLG 1))
(IF (and(= KW "LL")(= FLG 0))(SETQ KW "RR" FLG 1))
(IF (and(= KW "RR")(= FLG 0))(SETQ KW "LL" FLG 1))
(IF (and(= KW "BL")(= FLG 0))(SETQ KW "BR" FLG 1))
(IF (and(= KW "BR")(= FLG 0))(SETQ KW "BL" FLG 1))
(IF (and(= KW "DL")(= FLG 0))(SETQ KW "DR" FLG 1))
(IF (and(= KW "DR")(= FLG 0))(SETQ KW "DL" FLG 1))
))
(SETVAR "TEXTSIZE" TH)
(SETQ SS (SSGET))
(SETQ LEN (SSLENGTH SS))
(SETVAR "HIGHLIGHT" 0)
(PRINC "WORKING...\n")
(REPEAT LEN
(SETQ LEN (1- LEN))
(SETQ ENT (SSNAME SS LEN))
(IF (/= "LINE" (CDR (ASSOC '0 (ENTGET ENT))))
(SSDEL ENT SS))
)
(SETQ LEN (SSLENGTH SS))
(REPEAT LEN
(SETQ LEN (1- LEN)
ENT (ENTGET (SSNAME SS LEN))
P1 (CDR (ASSOC '10 ENT))
P2 (CDR (ASSOC '11 ENT))
)
(IF (= KW1 "Yes")(SETQ TMP P2 P2 P1 P1 TMP))
(SETQ ANG (ANGLE P1 P2)
ASTR (CHGD (ANGTOS ANG 4 6))
DIST (DISTANCE P1 P2)
DSTR (RTOS DIST 2 2)
DSTR (STRCAT DSTR "\047")
P3 (POLAR P1 ANG (/ DIST 2.0))
P3 (POLAR P3 (+ ANG (/ PI 2.0))(* TH 1.125))
P4 (POLAR P1 ANG (/ DIST 2.0))
P4 (POLAR P4 (- ANG (/ PI 2.0))(* TH 1.125))
)
(IF (AND (> ANG (/ PI 2.0))(< ANG (* PI 1.5)))(SETQ ANG (- ANG PI)))
(SETQ ANG (ANGTOS ANG 0 8))
(IF (OR (= KW "DL") (= KW "DR"))(SETQ ASTR ""))
(IF (OR (= KW "BL")(= KW "BR"))(SETQ DSTR ""))
(IF (= ASTR "E")(SETQ ASTR "East"))
(IF (= ASTR "N")(SETQ ASTR "North"))
(IF (= ASTR "W")(SETQ ASTR "West"))
(IF (= ASTR "S")(SETQ ASTR "South"))
(IF (OR (= KW "LR")(= KW "BL")(= KW "DR"))(PROGN
(COMMAND "TEXT" "M" P3 "" ANG ASTR)
(COMMAND "TEXT" "M" P4 "" ANG DSTR)
)
)
(IF (= KW "LL") (PROGN
(SETQ ASTR (STRCAT ASTR " " DSTR))
(COMMAND "TEXT" "M" P3 "" ANG ASTR)
)
)
(IF (OR (= KW "RL")(= KW "BR")(= KW "DL")) (PROGN
(COMMAND "TEXT" "M" P4 "" ANG ASTR)
(COMMAND "TEXT" "M" P3 "" ANG DSTR)
)
)
(IF (= KW "RR") (PROGN
(SETQ ASTR (STRCAT ASTR " " DSTR))
(COMMAND "TEXT" "M" P4 "" ANG ASTR)
)
)
)
(SETVAR "HIGHLIGHT" 1)
(SETQ SS nil)(GC)
(SETVAR "FLATLAND" 0)
(PRINC "DONE")
(PRINC)
)

[zedd33y502609]

Hi GreyHippo... I too love BD_POLY lisp. the one problem i have with it is that my units are set to north direction (i.e. 270d) and clockwise to have angles shown 0d as north and 180d as south. I can't work out how to alter the lisp to suit my needs (text goes to a wierd angle). Also a Tolerans of +-5mm and +-5sec would be a great as an addition to choose if needed. would be vey greatfull if this idea could be looked at
Many Regards

[gugg]

THIS IS NOT MINE BUT BEEN USING IT FOR YEARS ...



;Output the bearing of a line.
(defun c:bearing ()
(setvar "cmdecho" 0)
(setq p1 (getpoint "Select line: "))
(setq p2 (osnap p1 "midp"))
(setq p3 (osnap p1 "endp"))
(setq string (angtos (angle p2 p3)))
(command "text" "c" (polar p2 (+ (angle p2 p3) (/ pi 2))
(/ (getvar "textsize") 2.0)) "" (* (/ 180.0 pi) (angle p2 p3)) string)
(princ)
)

LET ME KNOW IF IT WORKS ... AL

[miked101]

Hello. Our company just switch to civil 3d 2017. I was looking for a lisp routine to label bearing and distances on multiple lines at a time. Instead of having to pick on each line. Any help would be greatly appreciated.

Thank you.

[MMccall]

Civil 3d can do this.

Select Annotate from the top menus to get to the annotate ribbon. On the left end of the ribbon is "Add Labels". This is a two part button, a top and bottom. Press the top to open the Add Label dialog. The feature you want is Line and Curve, label type is Multiple Segment. Select/make a label style for lines and one for curves. Select the objects you want labeled. The line/curve labels act just like parcel segment labels.

[miked101]

When doing a subdivision layout even picking multiple segments. I still have to pick on each lot line. I was wanting to be able to isolate the layer and label all with a bearing an distance at once. Is it a setting that is keeping me from being able to this?

[MMccall]

Ok, yea, Multiple would make you pick each one. It works best on a polyline with multiple segments as it would then label the entire line. if it were me, with Civil 3d, I would do it as parcel segments. (Create parcels from objects).

I'm sure the lispers have a solution.

[ccalder]

This is super ineligant, just for my personal use, and only works with lines and polylines but might be a good starting point to do what I think you're asking for.



(PRINC "\n LAL: Label All Lines")
(DEFUN C:lal ( / LAY SS:LINES CNT EN EN1 PT A)
(VL-LOAD-COM)
(SETQ SS:LINES (SSGET))
(SETQ CNT 0)
(command "-layer" "OFF" "*" "Y" "")
(command "-layer" "ON" "0" "")
(REPEAT (SSLENGTH SS:LINES)
(SETQ EN (SSNAME SS:LINES CNT))
(SETQ EN1 (VLAX-ENAME->VLA-OBJECT EN))
(SETQ LAY (VLAX-GET EN1 'LAYER))
(VLAX-PUT EN1 'LAYER "0")
(COND
((= (CDR (ASSOC 0 (ENTGET EN))) "LINE")
(SETQ PT (LIST (/ (+ (CAR (VLAX-GET EN1 'StartPoint)) (CAR (VLAX-GET EN1 'EndPoint))) 2) (/ (+ (CADR (VLAX-GET EN1 'StartPoint)) (CADR (VLAX-GET EN1 'EndPoint))) 2))))
((= (CDR (ASSOC 0 (ENTGET EN))) "LWPOLYLINE")
(SETQ PT (LIST (/ (+ (NTH 0 (VLAX-GET EN1 'Coordinates)) (NTH 2 (VLAX-GET EN1 'Coordinates))) 2) (/ (+ (NTH 1 (VLAX-GET EN1 'Coordinates)) (NTH 3 (VLAX-GET EN1 'Coordinates))) 2))))
)
(IF PT
(COMMAND "ADDSEGMENTLABELS" "NEA" PT ""))
(VLAX-PUT EN1 'LAYER LAY)
(SETQ PT NIL)
(SETQ CNT (+ 1 CNT))
)
(command "-layer" "ON" "*" "")
(command "REGEN")
(PRINC)
)

[rkmcswain]

This is super ineligant, just for my personal use, and only works with lines and polylines but might be a good starting point to do what I think you're asking for.


Very nice @ccalder !

[Tom Beauford]

This is super ineligant, just for my personal use, and only works with lines and polylines but might be a good starting point to do what I think you're asking for.

Nice, it does do arcs on lwpolylines. Shouldn't be hard to add something for arcs.

[miked101]

Ccalder.

I ran the lisp routine could not get it to work. Do you have to have the layer frozen to start the command?

[remi678731]

In Civil3d in the line/curve label dialog there is an option to label multiple segments. It will label all segments of a pline

[ccalder]

Nice, it does do arcs on lwpolylines. Shouldn't be hard to add something for arcs.

yeah it would just need another cond to get a point on the arc for the pseudo click. And it might not work on a polyline with arcs if the the first segment is an arc.


I ran the lisp routine could not get it to work. Do you have to have the layer frozen to start the command?

Hmmm... well it only works if you have Civil 3D, other than that, what the routine is doing is turning off every layer, then turning layer "0" back on. It then goes through the selection set one by one, saves the current layer of the object then changes the objects layer to "0" then if the object is a line or lwpolyline it figures a point for a psuedo-click, runs the "ADDSEGMENTLABELS" Civil 3d command with a "nea" snap, then puts the object back to its original layer. If any of those steps might conflict in your drawing that would be the cause. Also it has nothing resembling error trapping so it would need some shinning up before i handed it to any of my users, but like I said this is just one I use for myself.

Nows I'm pondering it, I might try using vlax-curve-getClosestPointTo to get a point on the object, that would help it with arcs... I just haven't given this one a hard look in a few years cuz I only use it with batches of normal lines when I'm labeling section breakdowns. XD

[Tom Beauford]

This is super ineligant, just for my personal use, and only works with lines and polylines but might be a good starting point to do what I think you're asking for.

I modified it to work with arcs as well by adding Togores code. https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/get-midpoint-of-arc/m-p/848200#M73858

(PRINC "\n LAL: Label All Lines")
(DEFUN C:lal ( / ax-longtotal ax-ptmid LAY SS:LINES CNT EN EN1 PT A)

;;returns the total length of any linear object
(defun ax-longtotal (objcurva)
(vlax-curve-getdistatparam
objcurva
(vlax-curve-getendparam objcurva))
)

;;returns the midpoint
(defun ax-ptmid (objcurva)
(vlax-curve-getPointAtDist
objcurva
(/ (ax-longtotal objcurva) 2))
)

(VL-LOAD-COM)
(vl-cmdf "undo" "BEgin")
(SETQ SS:LINES (SSGET))
(SETQ CNT 0)
(command "-layer" "OFF" "*" "Y" "")
(command "-layer" "ON" "0" "")
(REPEAT (SSLENGTH SS:LINES)
(SETQ EN (SSNAME SS:LINES CNT))
(SETQ EN1 (VLAX-ENAME->VLA-OBJECT EN))
(SETQ LAY (VLAX-GET EN1 'LAYER))
(VLAX-PUT EN1 'LAYER "0")
(IF(= (CDR (ASSOC 0 (ENTGET EN))) "LINE")(= (CDR (ASSOC 0 (ENTGET EN))) "ARC")(= (CDR (ASSOC 0 (ENTGET EN))) "LWPOLYLINE"))
(SETQ PT (ax-ptmid EN1))
(IF PT
(COMMAND "ADDSEGMENTLABELS" "NEA" PT ""))
(VLAX-PUT EN1 'LAYER LAY)
(SETQ PT NIL)
(SETQ CNT (+ 1 CNT))
)
(command "-layer" "ON" "*" "")
(command "REGEN")
(vl-cmdf "undo" "End")
(PRINC)
)

I also added the ability to undo.

[ccalder]

I modified it to work with arcs as well by adding Togores code. https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/get-midpoint-of-arc/m-p/848200#M73858

Nice! I like, it especially needed the undo bracketing.

[miked101]

This one kind of works but if anyone can improve on it please do. It labels some multiple times and wont label all.



(defun c:go(/ lay ss len ctr ob pt)

(vl-load-com)

(setq lay (cdr (assoc 8 (entget (car (entsel "\nSelect object on layer: "))))))

(setq ss (ssget "x" (list (cons 8 lay)))
len (sslength ss)
ctr 0)

(while (< ctr len)
(setq ob (ssname ss ctr))
(if (= (cdr (assoc 0 (entget ob))) "LINE")
(progn
(setq pt (cdr (assoc 10 (entget ob))))
(vl-cmdf "addsegmentlabels" pt "")
)
)
(setq ctr (1+ ctr))
)
(princ)
);end defun

[ccalder]

At a glance, if they are connected endpoint to endpoint it would have issues which might explain why some get labeled twice and some skipped. That's why the code I posted earlier does the isolation thing. Try this, with Toms contribution from above, it sets the pt variable at the midpoint instead of the endpoint:



(defun c:go(/ lay ss len ctr ob pt)

(vl-load-com)

(setq lay (cdr (assoc 8 (entget (car (entsel "\nSelect object on layer: "))))))

(setq ss (ssget "x" (list (cons 8 lay)))
len (sslength ss)
ctr 0)

(while (< ctr len)
(setq ob (ssname ss ctr))
(if (= (cdr (assoc 0 (entget ob))) "LINE")
(progn
(setq pt (ax-ptmid (vlax-ename->vla-object)))
(vl-cmdf "addsegmentlabels" pt "")
)
)
(setq ctr (1+ ctr))
)
(princ)
);end defun

;;returns the total length of any linear object
(defun ax-longtotal (objcurva)
(vlax-curve-getdistatparam
objcurva
(vlax-curve-getendparam objcurva))
)

;;returns the midpoint
(defun ax-ptmid (objcurva)
(vlax-curve-getPointAtDist
objcurva
(/ (ax-longtotal objcurva) 2))

[Tom Beauford]

I took out the layer modifications, limited the selection set, and formatted the spacing.
;| http://forums.augi.com/showthread.php?97969-Surveying-Bearing-Distance-LISP-Routine&p=1324020&viewfull=1#post1324020
^C^C^P(or C:LAL (load "LAL.lsp"));LAL |;
(PRINC "\n LAL: Label All Lines")
(VL-LOAD-COM)
(DEFUN C:LAL ( / ax-ptmid LAY SS:LINES CNT EN EN1 PT A)
(command-s "undo" "BEgin")

;;returns the midpoint
(defun ax-ptmid (objcurva)
(vlax-curve-getPointAtDist
objcurva
(/ (vlax-curve-getdistatparam objcurva(vlax-curve-getendparam objcurva)) 2))
)

(if(SETQ SS:LINES (SSGET'((0 . "LINE,ARC,LWPOLYLINE,POLYLINE"))))
(progn
(SETQ CNT 0)
(REPEAT (SSLENGTH SS:LINES)
(SETQ EN (SSNAME SS:LINES CNT)
EN1 (VLAX-ENAME->VLA-OBJECT EN)
LAY (VLAX-GET EN1 'LAYER)
PT (ax-ptmid EN1)
)
(vl-cmdf "ADDSEGMENTLABELS" "NEA" PT "")
(SETQ CNT (+ 1 CNT))
)
);progn
);if SETQ SS:LINES
(command-s "undo" "End")
(PRINC)
)

[miked101]

Tom
Im running civil 3d 2017. every time i load the lisp code you have crashes my civil? Where you having this issue as well.

Calder
Every time i run the lisp code you put it send this "Select object on layer: ; error: too few arguments"

Does the layer have to be isolated to run either lisp?

Thanks for all your help.

[miked101]

Tom
I apologize, I was taking to much of the script. I will recheck. Did a prelim test seem to work.
Thank you.

[miked101]

Tom
You are the man. If you grab to many it will pick and choose what it will do. However picking 60 at a time worked like a champ. Thank you.

[Tom Beauford]

Tom
You are the man. If you grab to many it will pick and choose what it will do. However picking 60 at a time worked like a champ. Thank you.

Glad it worked out, I only tested it on 15 objects.

Since commands don't always process as fast as lisp runs sometimes adding something like
(vl-cmdf "delay" 50) in the loop helps when processing a lot of objects, but it will slow it down as well. If you need to run it on a larger number you should experiment with it.