[编程交流] 更新a。lsp帮助

(defun c:Bearings (/ *error* _draw _angle _fix _dist cmd dzn ucs first lst pt finalList tablePoint
                  row tsize table)
 ;; Point connections to Table with bearings and distances
 ;; Alan J. Thompson, 2013.05.29
 (vl-load-com)
 (defun *error* (msg)
   (redraw)
   (and ucs (vl-cmdf "_.UCS" "_P"))
   (and cmd (setvar 'CMDECHO cmd))
   (and dzn (setvar 'DIMZIN dzn))
   (and *AcadDoc* (vla-endundomark *AcadDoc*))
   (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
     (progn (vl-bt) (princ (strcat "\nError: " msg)))
   )
 )
 (defun _draw (lst)
   (redraw)
   (mapcar (function (lambda (a b) (grdraw a b 3 1))) (cons (last lst) lst) lst)
 )
 (defun _angle (p1 p2 / a)
   (setq a (angtos (angle p1 p2) 4 4))
   (cond ((cdr (assoc a '(("N" . "NORTH") ("S" . "SOUTH") ("E" . "EAST") ("W" . "WEST")))))
         ((_fix a))
   )
 )
 (defun _fix (s / i l a)
   (setq s (vl-string-subst "°" "d" s))
   (foreach v '(" " "°" "'" """ " ")
     (setq a (substr s 1 (setq i (vl-string-search v s))))
     (if (and (member v '("°" "'" """)) (eq (strlen a) 1))
       (setq a (strcat "0" a))
     )
     (setq l (cons a l)
           s (substr s (+ i 2))
     )
   )
   (apply 'strcat
          (apply 'append
                 (mapcar (function (lambda (a b) (list a b)))
                         (reverse (cons s l))
                         '(" " "°" "'" "" " "" "")
                 )
          )
   )
 )
 (defun _dist (p1 p2) (strcat (rtos (distance p1 p2) 2 2) "'"))
 (vla-startundomark
   (cond (*AcadDoc*)
         ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
   )
 )
 (setq dzn (getvar 'DIMZIN))
 (setvar 'DIMZIN 0)
 (if (zerop (getvar 'WORLDUCS))
   (progn (setq cmd (getvar 'CMDECHO))
          (setvar 'CMDECHO 0)
          (vl-cmdf "_.UCS" "")
   )
 )
 (redraw)
 (initget 4)
 (setq *Bearings:Count*
        (cond ((getint (strcat "\nSpecify starting number <"
                               (itoa (cond (*Bearings:Count*)
                                           ((setq *Bearings:Count* 1))
                                     )
                               )
                               ">: "
                       )
               )
              )
              (*Bearings:Count*)
        )
 )
 (setq first (itoa *Bearings:Count*))
 (if (car (setq lst (list (getpoint
                            (strcat "\nSpecify point for number " (itoa *Bearings:Count*) ": ")
                          )
                    )
          )
     )
   (progn
     (while
       (setq pt (getpoint (car lst)
                          (strcat "\nSpecify point for number "
                                  (itoa (1+ *Bearings:Count*))
                                  ": "
                          )
                )
       )
        (_draw (setq lst (cons pt lst)))
        (setq finalList (cons (list (strcat (itoa *Bearings:Count*)
                                            " - "
                                            (itoa (setq *Bearings:Count* (1+ *Bearings:Count*)))
                                    )
                                    (_angle (cadr lst) (car lst))
                                    (_dist (cadr lst) (car lst))
                              )
                              finalList
                        )
        )
     )
     (if (and finalList (setq tablePoint (getpoint "\nSpecify insertion point for table: ")))
       (progn
         (if (> (length finalList) 1)
           (setq finalList (cons (list (strcat (itoa *Bearings:Count*) " - " first)
                                       (_angle (car lst) (last lst))
                                       (_dist (car lst) (last lst))
                                 )
                                 finalList
                           )
           )
         )
         (setq finalList (reverse finalList))
         (setq row   1
               tsize (getvar 'TEXTSIZE)
               table (vlax-invoke
                       (vlax-get-property
                         *AcadDoc*
                         (if (eq (getvar 'CVPORT) 1)
                           'PaperSpace
                           'ModelSpace
                         )
                       )
                       'AddTable
                       tablePoint
                       (+ (length finalList) 2)
                       3
                       (* tsize 2.)
                       (* tsize 15.)
                     )
         )
         (vla-put-regeneratetablesuppressed table :vlax-true)
         (vla-settextheight table actitlerow tsize)
         (vla-settextheight table acheaderrow tsize)
         (vla-settextheight table acdatarow tsize)
         (vla-put-vertcellmargin table (/ tsize 4.25))
         (vla-settext table 0 0 "COURSE TABLE")
         (vla-settext table 1 0 "COURSE")
         (vla-settext table 1 1 "BEARING")
         (vla-settext table 1 2 "DISTANCE")
         (foreach item finalList
           (setq row (1+ row))
           (foreach n '(0 1 2)
             (vla-settext table row n (nth n item))
             (vla-setcellalignment table row n acMiddleCenter)
           )
         )
         (vla-put-regeneratetablesuppressed table :vlax-false)
       )
     )
   )
 )
 (*error* nil)
 (princ)
)

(defun c:Bearings (/ *error* _draw _angle _fix _dist cmd dzn ucs first lst pt finalList tablePoint
                  row tsize table)
 ;; Point connections to Table with bearings and distances
 ;; Alan J. Thompson, 2013.05.29
 (vl-load-com)
 (defun *error* (msg)
   (redraw)
   (and ucs (vl-cmdf "_.UCS" "_P"))
   (and cmd (setvar 'CMDECHO cmd))
   (and dzn (setvar 'DIMZIN dzn))
   (and *AcadDoc* (vla-endundomark *AcadDoc*))
   (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
     (progn (vl-bt) (princ (strcat "\nError: " msg)))
   )
 )
 (defun _draw (lst)
   (redraw)
   (mapcar (function (lambda (a b) (grdraw a b 3 1))) lst (cdr lst))
 )
 (defun _angle (p1 p2 / a)
   (setq a (angtos (angle p1 p2) 4 4))
   (cond ((cdr (assoc a '(("N" . "NORTH") ("S" . "SOUTH") ("E" . "EAST") ("W" . "WEST")))))
         ((_fix a))
   )
 )
 (defun _fix (s / i l a)
   (setq s (vl-string-subst "°" "d" s))
   (foreach v '(" " "°" "'" """ " ")
     (setq a (substr s 1 (setq i (vl-string-search v s))))
     (if (and (member v '("°" "'" """)) (eq (strlen a) 1))
       (setq a (strcat "0" a))
     )
     (setq l (cons a l)
           s (substr s (+ i 2))
     )
   )
   (apply 'strcat
          (apply 'append
                 (mapcar (function (lambda (a b) (list a b)))
                         (reverse (cons s l))
                         '(" " "°" "'" "" " "" "")
                 )
          )
   )
 )
 (defun _dist (p1 p2) (strcat (rtos (distance p1 p2) 2 2) "'"))
 (vla-startundomark
   (cond (*AcadDoc*)
         ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
   )
 )
 (setq dzn (getvar 'DIMZIN))
 (setvar 'DIMZIN 0)
 (if (zerop (getvar 'WORLDUCS))
   (progn (setq cmd (getvar 'CMDECHO))
          (setvar 'CMDECHO 0)
          (vl-cmdf "_.UCS" "")
   )
 )
 (redraw)
 (initget 4)
 (setq *Bearings:Count*
        (cond ((getint (strcat "\nSpecify starting number <"
                               (itoa (cond (*Bearings:Count*)
                                           ((setq *Bearings:Count* 1))
                                     )
                               )
                               ">: "
                       )
               )
              )
              (*Bearings:Count*)
        )
 )
 (setq first (itoa *Bearings:Count*))
 (if (car (setq lst (list (getpoint
                            (strcat "\nSpecify point for number " (itoa *Bearings:Count*) ": ")
                          )
                    )
          )
     )
   (progn
     (while
       (setq pt (getpoint (car lst)
                          (strcat "\nSpecify point for number "
                                  (itoa (1+ *Bearings:Count*))
                                  ": "
                          )
                )
       )
        (_draw (setq lst (cons pt lst)))
        (setq finalList (cons (list (strcat (itoa *Bearings:Count*)
                                            " - "
                                            (itoa (setq *Bearings:Count* (1+ *Bearings:Count*)))
                                    )
                                    (_angle (cadr lst) (car lst))
                                    (_dist (cadr lst) (car lst))
                              )
                              finalList
                        )
        )
     )
     (if (and finalList (setq tablePoint (getpoint "\nSpecify insertion point for table: ")))
       (progn
         (setq finalList (reverse finalList)
               row       1
               tsize     (getvar 'TEXTSIZE)
               table     (vlax-invoke
                           (vlax-get-property
                             *AcadDoc*
                             (if (eq (getvar 'CVPORT) 1)
                               'PaperSpace
                               'ModelSpace
                             )
                           )
                           'AddTable
                           tablePoint
                           (+ (length finalList) 2)
                           3
                           (* tsize 2.)
                           (* tsize 15.)
                         )
         )
         (vla-put-regeneratetablesuppressed table :vlax-true)
         (vla-settextheight table actitlerow tsize)
         (vla-settextheight table acheaderrow tsize)
         (vla-settextheight table acdatarow tsize)
         (vla-put-vertcellmargin table (/ tsize 4.25))
         (vla-settext table 0 0 "COURSE TABLE")
         (vla-settext table 1 0 "COURSE")
         (vla-settext table 1 1 "BEARING")
         (vla-settext table 1 2 "DISTANCE")
         (foreach item finalList
           (setq row (1+ row))
           (foreach n '(0 1 2)
             (vla-settext table row n (nth n item))
             (vla-setcellalignment table row n acMiddleCenter)
           )
         )
         (vla-put-regeneratetablesuppressed table :vlax-false)
       )
     )
   )
 )
 (*error* nil)
 (princ)
)