I need a litle changes !!!!!!!!!

July 30, 2013

I have this lisp code.This lisp calculate Bearing (in grads) and the distasce (in meters)

;------------------------------------------------------------------------------
; CAD Concepts Limited
; 
; BEARING DISTANCE TEXT
; 
; Copyright (C) 2011 CAD Concepts Limited.
; BEARING DISTANCE TEXT by CAD Concepts Ltd is licensed under
; a Creative Commons Attribution-ShareAlike 3.0 Unported License.
; http://creativecommons.org/licenses/by-sa/3.0/nz/deed.en
; For options available to you under this license.

; This software is provided "as is". No liability is taken of
; FITNESS FOR ANY PARTICULAR PURPOSE.
;------------------------------------------------------------------------------
; File          : BD.lsp
; Author        : Jason Bourhill
; Email         : jason@cadconcepts.co.nz
; Web			: http://www.cadconcepts.co.nz
; Date          : 20/Mar/2011
; CAD Ver(s)	: Tested on AutoCAD 2010 & Bricscad V11
; Purpose       : Places Bearing & Distance text above and below selected lines
;
; Usage         : To load type (load "BD.LSP") from the command line or drag
;				  and drop the file onto your drawing using explorer. Will
;				  automatically run on loading.
;
;				  Select a LINES or LIGHT WEIGHT POLYLINES on your drawing. Text
;				  placed above the line will give the Bearing. Text placed
;				  below the line gives the distance.
;				
;				  If you use inside a viewport from paperspace the routine will
;				  automatically work out the scale factor. If you use in model
;				  space you will be prompted for a scale factor.
;
;				  Bearing given is always between 0 - 180 deg irrespective of
;				  the direction the line has been drawn in.
;
;				  Text is placed on the current layer using the default text
;				  style. Text height is based on the text height for the
;				  current dimension style.
;				  
;				  To run the routine again type BD at the command line.
;
;				  NOTE in AutoCAD bearing gives a D instead of the degree symbol
;				  in Bricscad you get the degree symbol.
;
; Requires      : Nothing else
;------------------------------------------------------------------------------
; Rev no   : A
; Reason   : First release
; Rev Date : 20/Mar/2011
; Rev by   : Jason Bourhill
; Email    : jason@cadconcepts.co.nz
;
; Description:
; First release.
;------------------------------------------------------------------------------

(defun C:BD ( / ASK GETDWGSCALE  TEXTPOSITION LISTPLINEVER PLACETEXT sset num scalefac ent startpt endpt VerLst Ctr lstlen)

;ASK
;This routine allows default prompt issuing
(defun ASK (typ prmpt def / val vt)
   (setq vt (type def))
   (cond ((null vt) (princ (strcat prmpt ": ")))
         ((= vt 'STR) (princ (strcat prmpt " <" def ">: ")))
         ((= typ 'ANG) (princ (strcat prmpt " <" (rtd def) ">: ")))
         ((= vt 'REAL) (princ (strcat prmpt " <" (rtos def 2 2) ">: ")))
         ((= vt 'INT) (princ (strcat prmpt " <" (itoa def) ">: ")))
   )
   (cond ((= typ 'R) (setq val (getreal)))
         ((= typ 'S) (setq val (getkword)))
         ((= typ 'ANG) (setq val (getangle)))
         ((= typ 'DIST) (setq val (getdist)))
         ((= typ 'INT) (setq val (getint)))
         ((= typ 'STR) (setq val (getstring)))
         ((= typ 'STRT)(setq val (getstring T)))
   )
   (if (or (= val "")(= val ())) def val)
)

; find Drawing scale
; if user is inside a paperspace vport will work out dwgscale automatically
; if in paperspace set dwgscale = 1
; if in modelspace as user for dwgscale value
; Required as Bricscad doesn't support annotative text scaling
(defun getdwgscale ( )
(cond
((and (= 0 (getvar "TILEMODE")) (= 1 (getvar "CVPORT"))) ; in paperspace not inside a vport 
	(setq dwgscale 1)
)
((and (= 0 (getvar "TILEMODE")) (> (getvar "CVPORT") 1)) ; in paperspace and inside a vport
	(setq dwgscale (/ 1.0 (caddr (trans '(0 0 1) 2 3))))
)
((= 1 (getvar "TILEMODE")) ; in modelspace, ask user for dwgscale
	(if (not dwgscale) (setq dwgscale 0.5)) ; if not set, set dwgscale to 1:2000 assumes modelspace is in metres, and paperspace is mm
	(setq dwgscale (ask 'R "Drawing scale factor 1= 1:200, 2 = 1:500, 3 = 1:1000" dwgscale))
)
 )
 dwgscale ; return dwgscale value
) ; end getdwgscale

; Find and return the Text postion and angle value
; adjusts position and angle based on which quadrant the angle falls in
; Note internally Lisp uses radians, with 0 at East position and measures anticlockwise.
(defun textposition (LineMpt Langle TextOff / TestPos Langle)
(cond 
	 ((and (>= Langle 0 )(<= Langle (/ pi 2.0))) ; Langle between 0 - 90 degrees
		(setq TextPos (polar LineMpt (+ Langle (/ pi 2.0)) TextOff))
		(setq Langle Langle)
	 )
	 ((and (> Langle (/ pi 2.0))(<= Langle pi)) ; Langle between 90 - 180 degrees
		(setq TextPos (polar LineMpt (- Langle (/ pi 2.0)) TextOff))
		(setq Langle (- Langle pi))			
	 )
	 ((and (> Langle pi)(<= Langle (* pi 1.5)))  ; Langle between 180 - 270 degrees
		(setq TextPos (polar LineMpt (- Langle (/ pi 2.0)) TextOff))
		(setq Langle (- Langle pi))			
	 )
	 ((and (> Langle (* pi 1.5))(<= Langle (* pi 2.0)))  ; Langle between 270 - 360 degrees
		(setq TextPos (polar LineMpt (+ Langle (/ pi 2.0)) TextOff))
		(setq Langle Langle)
	 )
)
(list Textpos Langle) ; return the text position and angle as a list
) ; end textpostion

; List LWpline Vertices
; Iterates through presented list retaining only Lwpline vertices
; returns the vertices found as a list.
(defun ListPlineVer (ent)
   (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) ent))
) ;end ListPlineVer

(defun PlaceText (startpt endpt dwgscale / Bunits Bprec Dunits Dprec dwgscale txtoff)
; Set BEARING display preferences
; Bunit Options are:
; 0 Degrees, 1 Degrees/minutes/seconds, 2 Grads, 3 Radians, 4 Surveyor's units
(setq Bunits 1) ; Degrees/minutes/seconds
(setq Bprec 4) ; Angle Precision, specifies the number of decimal places

; Set DISTANCE display preferences
; Dunit Options are:
; 1 Scientific, 2 Decimal, 3 Engineering (feet and decimal inches),
; 4 Architectural (feet and fractional inches), 5 Fractional
(setq Dunits 2) ; Decimal
(setq Dprec 2) ; Linear Precision, specifies the number of decimal places

; Set TEXT display options
; Text OFFSET. Distance that the text is offset from the line
(setq txtoff (* 0.25 dwgscale))
;(setq txtoff (* (getvar dimgap) dwgscale)) could use dimgap if it is set to a reasonable value
; Text HEIGHT.
(setq txtheight (* (getvar "DIMTXT") dwgscale)) ; use dimension text height

(setq 
	ang (angle startpt endpt) ; find angle between two points
	dis (distance startpt endpt) ; find distance between two points
	midpt (polar startpt ang (/ dis 2.0)) ; find the midpoint between the two ponts
	angtxtval (textposition midpt ang txtoff) ; Find Bearing Text Position and Angle
	angtxtpos (car angtxtval) ; Bearing text position
	angtxt (angtos (cadr angtxtval) 2 Bprec) ; returns angle as a text string
	distxtpos (car (textposition midpt ang (* -1.0 (+ txtoff txtheight)))) ; Find Distance Text position below line, taking text height into account
	distxt (rtos dis Dunits Dprec) ; returns distance as a text string
)
(entmake (list (cons 0 "TEXT") (cons 10 angtxtpos) (cons 40 txtheight) (cons 1 angtxt) (cons 50 (cadr angtxtval)) (cons 72 1) (cons 11 angtxtpos)))
(entmake (list (cons 0 "TEXT") (cons 10 distxtpos) (cons 40 txtheight) (cons 1 distxt) (cons 50 (cadr angtxtval)) (cons 72 1) (cons 11 distxtpos)))
) ; end PlaceText

; Begin Main Program
;------------------------------------------------------------------------------
(princ "\nSelect LINES or LWPOLYLINES to attach Bearing Distance to") ; Provide prompt
(setq sset (ssget '((-4 . "<or")(0 . "LINE")(0 . "LWPOLYLINE")(-4 . "or>")))) ; select only LINES or Light Weight Polylines
(if sset
	(progn
		(setq num 0) ; zero counter
		; Scale factor. Find drawing scale factor
		(setq scalefac (getdwgscale))
		(repeat (sslength sset) ; repeat for each object in the selection set
			(setq ent (entget(ssname sset num))) ; find entity properties
			(cond
				((= (cdr (assoc 0 ent)) "LINE")
					(setq startpt (cdr (assoc 10 ent))) ; find the start point of the line
					(setq endpt (cdr (assoc 11 ent))) ; find the end point of the line
					(PlaceText startpt endpt scalefac) ; Place Bearing Distance Text
				)
				((= (cdr (assoc 0 ent)) "LWPOLYLINE")
					(setq VerLst (ListPlineVer ent)) ; find all the vertices for the pline
					(setq ctr 0) ; Zero Counter
					; Step through each vertice in list and place bearing distance text accordingly
					(if (= 1 (boole 1 1 (cdr (assoc 70 ent)))) ; check if the pline is Open or Closed
						(repeat (setq lstlen (length VerLst)) ; Assoc 70 = 1 pline Closed
							(if (= (1+ ctr) lstlen) ; Check if we are at the last vertice in the list
								(setq
									startpt (nth ctr verlst)
									endpt (nth 0 verlst) ; endpoint = 1st vertice in list
								)
								(setq
									startpt (nth ctr verlst)
									endpt (nth (1+ ctr) verlst)
								)
							)
							(PlaceText startpt endpt scalefac) ; Place Bearing Distance Text
							(setq ctr (1+ ctr)) ; iterate counter to next vertice in point list
						)
						(repeat (1- (length VerLst)) ; Assoc 70 = 0 pline Open
							(setq
								startpt (nth ctr verlst)
								endpt (nth (1+ ctr) verlst)
							)
							(PlaceText startpt endpt scalefac) ; Place Bearing Distance Text
							(setq ctr (1+ ctr)) ; iterate counter to next vertice in point list
						)
					)
				)
			)
			(setq num (1+ num)) ; Iterate counter to next object in selection set
		)
	)
	(princ "\nNo lines selected\n")
)

) ;end main function

;(C:BD) ; run automatically on loading

The problem with this lisp is that give the bearing all the time from the left point to the right point

Look tha attach drawing and tyou will understand

I need to gine the ungle from point

1-->2, 2-->3, 3-->4, 4-->5, 5-->1

not

1-->2, 2-->3, 4-->3, 5-->4, 1-->5

Can any one convert this lisp ????????

test.dwg

July 30, 2013

Any one !!!!!

July 31, 2013

No one !!!!!!!!!!!!!! Is it so difficult ???

July 31, 2013

No one !!!!!!!!!!!!!! Is it so difficult ???

Perhaps not. But YOU are very demanding and very impatient.

After all the help you have been having recently, perhaps you could try and puzzle it out yourself. Just go through it all logically.

July 31, 2013

can you help ???

July 31, 2013

I solve the problem .Thank you all.

July 31, 2013

For someone demanding so much help, the least you could do is provide the solution for others.

July 31, 2013

the change I made is on line 164 of the lisp routine

July 31, 2013

I would suggest that you read this article prodromosm.

If you follow the guidlines outlined in the article, you may find that you will receive a better response from the community.

July 31, 2013

Thank you Lee.

July 31, 2013

I would suggest that you read this article prodromosm.
If you follow the guidlines outlined in the article, you may find that you will receive a better response from the community.

a bit too long for me to read right now but good find Lee.

July 31, 2013

a bit too long for me to read right now but good find Lee.

Thanks Dave - when you get some time, this article is also a good read demonstrating how to approach program bug reports.

August 1, 2013

Thanks Dave - when you get some time, this article is also a good read demonstrating how to approach program bug reports.

How do you find these? Go to page 4000 of the Google searches?

August 1, 2013

Knowing how to write good search criteria is usually the first step in finding what others may consider to be elusive. Persistent helps too.

August 1, 2013

Thanks Dave - when you get some time, this article is also a good read demonstrating how to approach program bug reports.

I thought that very interesting until I wondered if you were implying I don't give you clear bug reports!

Actually, I can't remember needing to submit any bug reports to you. By the time I found the last one, you had already corrected it.

August 1, 2013

How do you find these? Go to page 4000 of the Google searches?

Collected & bookmarked along the way when others have shared them...

I thought that very interesting until I wondered if you were implying I don't give you clear bug reports!

Actually, I can't remember needing to submit any bug reports to you. By the time I found the last one, you had already corrected it.

Don't worry, it wasn't personal

August 1, 2013

It seems that the O.P. is only here to exploit this great community.

August 1, 2013

Yep, no more pealed grapes for him.

August 1, 2013

the change I made is on line 164 of the lisp routine

prodromosm, while that's a step in the right direction, you might notice that there are no line numbers in the routine. Thus, that comment might not help at all for a lot of people. You could, on the other hand, show a small excerpt of the routine, including the line you changed and exactly what you changed. That would be more suitable and might even help others understand how the routine works as well.

Sign In

I need a litle changes !!!!!!!!!

Recommended Posts

Guest

Guest

Guest

eldon

Guest

Guest

SLW210

Guest

Lee Mac

Guest

dbroada

Lee Mac

Tuns

ReMark

dbroada

Lee Mac

tzframpton

nestly

neophoible

Join the conversation

Tutorials

Forums

Activity