[编程交流] Lisp程序有点小问题！！！

;------------------------------------------------------------------------------
; 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:100, 2 = 1:200, 3 = 1:500" 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