Community
Visual LISP, AutoLISP and General Customization
cancel
Turn on suggestions
Auto-suggest helps you quickly narrow down your search results by suggesting possible matches as you type.
Showing results for 
Show  only  | Search instead for 
Did you mean: 

Somebody to modify this lsp

7 REPLIES 7
Back to AutoCAD Customization Category
Back to Topic Listing
Reply
Message 1 of 8
agent47x
Contributor
453 Views, 7 Replies
‎10-17-2014 10:53 PM
‎10-17-2014 10:53 PM

Somebody to modify this lsp


;* distance and bearing label for lines
(graphscr)
(prompt "\nloading. . .")

;convert radians to degrees
(defun rtd (R) (/ (* R 180.0) pi))

(defun C:brg2 ()
;input for line notations
(setq P1 (getpoint "\nfirst point: "))
(while
(setq P2 (getpoint p1 "\nsecond point: "))
(setq T1 "text height: <default = "
T2 ">: "
T3 (getvar "textsize")
);setq
(terpri)
(setq TH (getreal (strcat T1 (rtos T3 2 2) T2)))
(if (= TH nil)
(setq TH t3))
;determine if bearings are true north, south, east, or west
(defun nsew ()
(if (and (= (car P1) (car P2))
(< (cadr P1) (cadr P2)))
(setq BNG "north")
);if
(if (and (< (car P1) (car P2))
(= (cadr P1) (cadr P2)))
(setq BNG "east")
);if
(if (and (= (car P1) (car P2))
(> (cadr P1) (cadr P2)))
(setq BNG "south")
);if
(if (and (> (car P1) (car P2))
(= (cadr P1) (cadr P2)))
(setq BNG "west")
);if
);defun

;place text on line
(setq AA (angle P1 P2)
DS (distance P1 P2)
P3 (polar P1 AA (/ DS 2.0))
AA1 (strcat (rtos (/ DS 12.0) 2 2) "'")
);setq

;calculate bearing from coordinates and format for printing
(defun bearing ()

(setq O (- (car P2) (car P1))
T (- (cadr P2) (cadr P1))
AZMTH (/ (* (atan (/ O T)) 180.0) pi)
A (abs AZMTH)
D (fix A)
M (* 60 (- A D))
S (* 60 (- M (fix M)))
M (fix M)
);setq

(if (= "60" (rtos s 2 0)) (setq M (+ 1 m)))
(if (= "60" (rtos s 2 0)) (setq S 0))
(if (= "60" (rtos m 2 0)) (setq D (+ 1 d)))
(if (= "60" (rtos m 2 0)) (setq M 0))
(if (< (cadr P2) (cadr P1)) (setq G "s") (setq G "n"))
(if (< (car P1) (car P2)) (setq H "e") (setq H "w"))

(setq BNG (strcat G ""
(if (< D 10) (strcat "0" (rtos D 2 0)) (rtos D 2 0)) "%%d"
(if (< M 10) (strcat "0" (rtos M 2 0)) (rtos M 2 0)) "'"
(if (< S 10) (strcat "0" (rtos S 2 0)) (rtos S 2 0))
"''" "" H))
);setq

;bearing and distance on line
(if (or (= 0 (- (car P1) (car P2)))
(= 0 (- (cadr P1) (cadr P2))))
(nsew) (bearing))
(command "text" "m"
(polar P3
(rem (+ AA (/ pi 2))
(* pi 2.0))
TH)
TH (rtd AA)
AA1)
(if (or (> (car P1) (car P2))
(= (rtd AA) 270))
(command "rotate" "last" "" P3 180.0)
);if
(command "text" "m"
(polar P3
(rem (+ AA (* pi 1.5))
(* pi 2.0))
TH)
TH (rtd AA)
BNG)
(if (or (> (car P1) (car P2))
(= BNG "south"))
(command "rotate" "last" "" P3 180.0)
);if
(command "line" P1 P2 "")
(setq P1 P2)
)
(princ);end program cleanly
);defun

 

 

 

HOW CAN I MAKE THE OUTPUT LIKE THIS IMAGE

 

 

PROBLEM.JPG

Report
0 Likes
Reply
7 REPLIES 7
Message 2 of 8
smaher12
Advocate
in reply to: agent47x
‎10-19-2014 08:44 AM
‎10-19-2014 08:44 AM

Okay I'll bite..... See below. Do you need the colors to match as well?

 

;;; * distance and bearing label for lines
(graphscr)
(prompt "\nloading. . .")
;;; convert radians to degrees
(defun rtd (R) (/ (* R 180.0) pi))

(defun C:brg2 ()
;;; input for line notations
  (setq P1 (getpoint "\nFirst point: "))
  (while
    (setq P2 (getpoint p1 "\nSecond point: "))
    (setq T1 "Text Height: <default = "
	  T2 ">: "
	  T3 (getvar "textsize")
	  );setq
    (terpri)
    (setq TH (getreal (strcat T1 (rtos T3 2 2) T2)))
    (if (= TH nil)
      (setq TH t3))

;;; determine if bearings are true north, south, east, or west
(defun nsew ()
  (if (and (= (car P1) (car P2))
	   (< (cadr P1) (cadr P2)))
    (setq BNG "north")
    );if
  (if (and (< (car P1) (car P2))
	   (= (cadr P1) (cadr P2)))
    (setq BNG "east")
    );if
  (if (and (= (car P1) (car P2))
	   (> (cadr P1) (cadr P2)))
    (setq BNG "south")
    );if
  (if (and (> (car P1) (car P2))
	   (= (cadr P1) (cadr P2)))
    (setq BNG "west")
    );if
);defun
    
;;; place text on line
    (setq AA (angle P1 P2)
	  DS (distance P1 P2)
	  P3 (polar P1 AA (/ DS 2.0))
	  AA1 (strcat (rtos (/ DS 12.0) 2 2) "'")
);setq
;calculate bearing from coordinates and format for printing
(defun bearing ()
  (setq O (- (car P2) (car P1))
	T (- (cadr P2) (cadr P1))
	AZMTH (/ (* (atan (/ O T)) 180.0) pi)
	A (abs AZMTH)
	D (fix A)
	M (* 60 (- A D))
	S (* 60 (- M (fix M)))
	M (fix M)
	);setq
  (if (= "60" (rtos s 2 0)) (setq M (+ 1 m)))
  (if (= "60" (rtos s 2 0)) (setq S 0))
  (if (= "60" (rtos m 2 0)) (setq D (+ 1 d)))
  (if (= "60" (rtos m 2 0)) (setq M 0))
  (if (< (cadr P2) (cadr P1)) (setq G "S") (setq G "N"))
  (if (< (car P1) (car P2)) (setq H "W") (setq H "W"))
  (setq BNG (strcat G ""
		    (if (< D 10) (strcat "0" (rtos D 2 0)) (rtos D 2 0)) "%%d"
		    (if (< M 10) (strcat "0" (rtos M 2 0)) (rtos M 2 0)) "'"
		    (if (< S 10) (strcat "0" (rtos S 2 0)) (rtos S 2 0))
		    "''" "" H))
  );setq
;;; bearing and distance on line
    (if (or (= 0 (- (car P1) (car P2)))
	    (= 0 (- (cadr P1) (cadr P2))))
      (nsew) (bearing))

    (command "text" "m"
	     (polar P3
		    (rem (+ AA (* pi 1.5))
			 (* pi 2.0))
		    TH)
	     TH (rtd AA)
	     (strcat BNG "      " AA1))

    (if (or (> (car P1) (car P2))
	    (= BNG "south"))
      (command "rotate" "last" "" P3 180.0)
      );if
    (command "line" P1 P2 "")
    (setq P1 P2)
    )
  (princ);end program cleanly
);defun

 

 

 

Report
0 Likes
Reply
Message 3 of 8
agent47x
Contributor
in reply to: smaher12
‎10-20-2014 03:16 AM
‎10-20-2014 03:16 AM

thanks but there is a problem check the image it appears like this when i try to run the lisp 

 

 

 

brg2.jpg

Report
0 Likes
Reply
Message 4 of 8
agent47x
Contributor
in reply to: smaher12
‎10-20-2014 03:45 AM
‎10-20-2014 03:45 AM

The bearings are wrong orientations the North East becomes North West...

Report
0 Likes
Reply
Message 5 of 8
smaher12
Advocate
in reply to: agent47x
‎10-20-2014 10:47 AM
‎10-20-2014 10:47 AM

Opps... Try this one...

 

;;; * distance and bearing label for lines
(graphscr)
(prompt "\nloading. . . ")
;;; convert radians to degrees
(defun rtd (R) (/ (* R 180.0) pi))

(defun C:brg2 ()
;;; input for line notations
  (setq P1 (getpoint "\nFirst point: "))
  (while
    (setq P2 (getpoint p1 "\nSecond point: "))
    (setq T1 "Text Height: <default = "
	  T2 ">: "
	  T3 (getvar "textsize")
	  );setq
    (terpri)
    (setq TH (getreal (strcat T1 (rtos T3 2 2) T2)))
    (if (= TH nil)
      (setq TH t3))

;;; determine if bearings are true north, south, east, or west
(defun nsew ()
  (if (and (= (car P1) (car P2))
	   (< (cadr P1) (cadr P2)))
    (setq BNG "north")
    );if
  (if (and (< (car P1) (car P2))
	   (= (cadr P1) (cadr P2)))
    (setq BNG "east")
    );if
  (if (and (= (car P1) (car P2))
	   (> (cadr P1) (cadr P2)))
    (setq BNG "south")
    );if
  (if (and (> (car P1) (car P2))
	   (= (cadr P1) (cadr P2)))
    (setq BNG "west")
    );if
);defun
    
;;; place text on line
    (setq AA (angle P1 P2)
	  DS (distance P1 P2)
	  P3 (polar P1 AA (/ DS 2.0))
	  AA1 (strcat (rtos (/ DS 12.0) 2 2) "'")
);setq
;calculate bearing from coordinates and format for printing
(defun bearing ()
  (setq O (- (car P2) (car P1))
	T (- (cadr P2) (cadr P1))
	AZMTH (/ (* (atan (/ O T)) 180.0) pi)
	A (abs AZMTH)
	D (fix A)
	M (* 60 (- A D))
	S (* 60 (- M (fix M)))
	M (fix M)
	);setq
  (if (= "60" (rtos s 2 0)) (setq M (+ 1 m)))
  (if (= "60" (rtos s 2 0)) (setq S 0))
  (if (= "60" (rtos m 2 0)) (setq D (+ 1 d)))
  (if (= "60" (rtos m 2 0)) (setq M 0))
  (if (< (cadr P2) (cadr P1)) (setq G "S") (setq G "N"))
  (if (< (car P1) (car P2)) (setq H "E") (setq H "W"))
  (setq BNG (strcat G ""
		    (if (< D 10) (strcat "0" (rtos D 2 0)) (rtos D 2 0)) "%%d"
		    (if (< M 10) (strcat "0" (rtos M 2 0)) (rtos M 2 0)) "'"
		    (if (< S 10) (strcat "0" (rtos S 2 0)) (rtos S 2 0))
		    "''" "" H))
  );setq
;;; bearing and distance on line
    (if (or (= 0 (- (car P1) (car P2)))
	    (= 0 (- (cadr P1) (cadr P2))))
      (nsew) (bearing))

    (command "text" "m"
	     (polar P3
		    (rem (+ AA (* pi 1.5))
			 (* pi 2.0))
		    TH)
	     TH (rtd AA)
	     (strcat BNG " " AA1))

    (if (or (> (car P1) (car P2))
	    (= BNG "south"))
      (command "rotate" "last" "" P3 180.0)
      );if
    (command "line" P1 P2 "")
    (setq P1 P2)
    )
  (princ);end program cleanly
);defun

 

Report
0 Likes
Reply
Message 6 of 8
smaher12
Advocate
in reply to: agent47x
‎10-20-2014 07:32 PM
‎10-20-2014 07:32 PM

This should match your original post....

 

;;; Distance and bearing label for lines
;;;

(graphscr)
(prompt "\nloading. . . ")
;;; convert radians to degrees
(defun rtd (R) (/ (* R 180.0) pi))

(defun C:brg2 ()
;;; input for line notations
  (setq cc (getvar 'cecolor))
  (if (setq P1 (getpoint "\nFirst point: "))
    (while
      (and
	(setq P2 (getpoint p1 "\nSecond point: "))
	);and
      (if (not (setq T1 (getreal (strcat "\nText Height: <" (rtos (getvar 'textsize) 2 2) "> "))))
	(setq T1 (getvar 'textsize))
	)

;;; determine if bearings are true north, south, east, or west
(defun nsew ()
  (if (and (= (car P1) (car P2))
	   (< (cadr P1) (cadr P2)))
    (setq BNG "north")
    );if
  (if (and (< (car P1) (car P2))
	   (= (cadr P1) (cadr P2)))
    (setq BNG "east")
    );if
  (if (and (= (car P1) (car P2))
	   (> (cadr P1) (cadr P2)))
    (setq BNG "south")
    );if
  (if (and (> (car P1) (car P2))
	   (= (cadr P1) (cadr P2)))
    (setq BNG "west")
    );if
);defun
    
;;; place text on line
      (setq AA (angle P1 P2)
	    DS (distance P1 P2)
	    P3 (polar P1 AA (/ DS 2.0))
	    AA1 (strcat (rtos (/ DS 12.0) 2 2) " M.")
	    );setq
      
;;; calculate bearing from coordinates and format for printing
 (defun bearing ()
  (setq O (- (car P2) (car P1))
	T (- (cadr P2) (cadr P1))
	AZMTH (/ (* (atan (/ O T)) 180.0) pi)
	A (abs AZMTH)
	D (fix A)
	M (* 60 (- A D))
	S (* 60 (- M (fix M)))
	M (fix M)
	);setq
  (if (= "60" (rtos s 2 0)) (setq M (+ 1 m)))
  (if (= "60" (rtos s 2 0)) (setq S 0))
  (if (= "60" (rtos m 2 0)) (setq D (+ 1 d)))
  (if (= "60" (rtos m 2 0)) (setq M 0))
  (if (< (cadr P2) (cadr P1)) (setq G "S") (setq G "N"))
  (if (< (car P1) (car P2)) (setq H "E") (setq H "W"))
  (setq BNG (strcat G ""
		    (if (< D 10) (strcat "0" (rtos D 2 0)) (rtos D 2 0)) "%%d"
		    (if (< M 10) (strcat "0" (rtos M 2 0)) (rtos M 2 0)) "'"
		    (if (< S 10) (strcat "0" (rtos S 2 0)) (rtos S 2 0))
		    "''" "" H))
  );setq
;;; bearing and distance on line
    (if (or (= 0 (- (car P1) (car P2)))
	    (= 0 (- (cadr P1) (cadr P2))))
      (nsew) (bearing))

    (setvar 'cecolor "3")
    (command "_.text" "m" "_none" (polar P3 (rem (+ AA (* pi 1.5)) (* pi 2.0)) T1) T1 (rtd AA)
	     (strcat BNG "  " AA1)
    )
    (if (or (> (car P1) (car P2))
	    (= BNG "south"))
      (command "_.rotate" "last" "" P3 180)
      );if
    (setvar 'cecolor "5")
    (command "_.line" "_none" P1 "_none" P2 "")
    (setq P1 P2)
    )
  );if
  (setvar 'cecolor cc)
 (princ)
);defun

 

Report
0 Likes
Reply
Message 7 of 8
agent47x
Contributor
in reply to: smaher12
‎10-20-2014 10:24 PM
‎10-20-2014 10:24 PM

almost perpect the output is this

 

BRG2 OUTPUT.JPG

 

 

 

but this is the one i asking..

 

BRG4.JPG

 

 

Report
0 Likes
Reply
Message 8 of 8
smaher12
Advocate
in reply to: agent47x
‎10-21-2014 10:34 AM
‎10-21-2014 10:34 AM

This should do the trick....

 

;;; Distance and bearing label for lines
;;;

(graphscr)
(prompt "\nloading. . . ")
;;; convert radians to degrees
(defun rtd (R) (/ (* R 180.0) pi))

(defun C:brg2 ()
;;; input for line notations
  (setq cc (getvar 'cecolor)
	ts (getvar 'textsize)
	)
  (if (setq P1 (getpoint "\nFirst point: "))
    (while
      (and
	(setq P2 (getpoint p1 "\nSecond point: "))
	);and
      (if (not (setq T1 (getreal (strcat "\nText Height: <" (rtos (getvar 'textsize) 2 2) "> "))))
	(setq T1 (getvar 'textsize))
	)

;;; determine if bearings are true north, south, east, or west
(defun nsew ()
  (if (and (= (car P1) (car P2))
	   (< (cadr P1) (cadr P2)))
    (setq BNG "north")
    );if
  (if (and (< (car P1) (car P2))
	   (= (cadr P1) (cadr P2)))
    (setq BNG "east")
    );if
  (if (and (= (car P1) (car P2))
	   (> (cadr P1) (cadr P2)))
    (setq BNG "south")
    );if
  (if (and (> (car P1) (car P2))
	   (= (cadr P1) (cadr P2)))
    (setq BNG "west")
    );if
);defun
    
;;; place text on line
      (setq AA (angle P1 P2)
	    DS (distance P1 P2)
	    P3 (polar P1 AA (/ DS 2.0))
	    AA1 (strcat (rtos (/ DS 12.0) 2 2) " M.")
	    );setq
      
;;; calculate bearing from coordinates and format for printing
 (defun bearing ()
  (setq O (- (car P2) (car P1))
	T (- (cadr P2) (cadr P1))
	AZMTH (/ (* (atan (/ O T)) 180.0) pi)
	A (abs AZMTH)
	D (fix A)
	M (* 60 (- A D))
	S (* 60 (- M (fix M)))
	M (fix M)
	);setq
  (if (= "60" (rtos s 2 0)) (setq M (+ 1 m)))
  (if (= "60" (rtos s 2 0)) (setq S 0))
  (if (= "60" (rtos m 2 0)) (setq D (+ 1 d)))
  (if (= "60" (rtos m 2 0)) (setq M 0))
  (if (< (cadr P2) (cadr P1)) (setq G "S") (setq G "N"))
  (if (< (car P1) (car P2)) (setq H "E") (setq H "W"))
  (setq BNG (strcat G ""
		    (if (< D 10) (strcat "0" (rtos D 2 0)) (rtos D 2 0)) "%%d"
		    (if (< M 10) (strcat "0" (rtos M 2 0)) (rtos M 2 0)) "'"
		    (if (< S 10) (strcat "0" (rtos S 2 0)) (rtos S 2 0))
		    "''" "" H))
  );setq
;;; bearing and distance on line
    (if (or (= 0 (- (car P1) (car P2)))
	    (= 0 (- (cadr P1) (cadr P2))))
      (nsew) (bearing))

      (setq TPT (polar P3 (rem (+ AA (* pi 1.5)) (* pi 2.0)) T1))
      (setvar 'cecolor "3")
      (command "_.text" "m" "_none" TPT T1 (rtd AA) (strcat BNG "  " AA1))

      (if (or (> (car P1) (car P2))
	      (= BNG "south"))
	(command "_.rotate" "last" "" "_none" TPT 180)
	);if

      (setvar 'cecolor "5")
      (command "_.line" "_none" P1 "_none" P2 "")
      (setq P1 P2)
    );while
  );if
  (setvar 'cecolor cc)
  (setvar 'textsize ts)
 (princ)
);defun

 

Report
0 Likes
Reply
Reply

Can't find what you're looking for? Ask the community or share your knowledge.

Post to forums  

Autodesk Design & Make Report

”Boost

 

Report a website issue