[编程交流] LISP例程帮助

;;; THIS LISP WILL TAKE A LINE ON AN EXPLOPED
;;; PROFILE AND CALCULATE THE SLOPE
;;;
;;; THE LISP WILL ASK THE USER FOR THE RATIO
;;; OF THE PROFILE IN QUESTION (IE: 10:1 , ]
;;; 5:1 AND SO ON).
;;;
;;; NEXT THE USER WILL SELECT THE LINE IN QUESTION
;;; AND WILL PLACE THE SLOPE ON THE LINE AT THE MID-POINT
;;;
;;;
;;;   This program is free software: you can redistribute it and/or modify
;;;    it under the terms of the GNU General Public License as published by
;;;    the Free Software Foundation, either version 3 of the License, or
;;;    (at your option) any later version.
;;;
;;;    This program is distributed in the hope that it will be useful,
;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;    GNU General Public License for more details.
;;;
;;;    You should have received a copy of the GNU General Public License
;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;;
;;;
;;;
;;; SLOPELINE.LSP - COPYRIGHT 2014 BY J. SHAWN YOUNG
;;;
;;;
;;; VERSION 1.0 - INITIAL STATE
;;;
;;; VERSION 2.0 2014-11-26
;;;                - RE-WROTE LISP TO BE MORE EFFICENT
;;;                - NO MORE NEGITIVE SLOPES
;;;                - ALLOW FOR SELECTION SETS OF LINES AND POLYLINES
;;;
;;; VERSION 2.1 2014-11-26
;;;                - FIXED ISSUED WITH TEXT COMING IN UPSIDE DOWN
;;;                IF LINE WAS DRAWN RIGHT TO LEFT
;;;
;;;
;;;
;;;
(DEFUN C:SLOPELINE (/      PT1    PT2    PT1_Y  PT1_X  PT2_Y         PT2_X        RATIO
       SSET   OBJ    RISE   RUN           SLOPE  MIDPOINT        ANG
       ANG2   LEN    LST    COUNT  LAYER  ITEM         COUNT        CHECK
       N STYTEXT len2
      )
 (vl-load-com)
;;;                SELECTION SET                ;;;
 (SETQ        SSET                                ;BEGIN SETQ
 (SSGET                                ;BEGIN SSGET
   '(
     (-4 . "<XOR")                ;BEGIN XOR
     (0 . "LWPOLYLINE")                ;GET POLYLINE
     (0 . "LINE")                ;GET LINE
     (-4 . "XOR>")                ;END XOR
    )
 )                                ;END SSGET
 )                                        ;END SETQ
 (SETQ                                        ;BEGIN SETQ
   COUNT (SSLENGTH SSET)                ;SET COUNT TO SELECTION SET LENGTH
   N          0                                ;N TO 0
   RATIO 1
 )                                        ;END SETQ
;;;        CHECK AND SET TEXT STYLE        ;;;
 (COMMAND "CMDECHO" 0)                        ;ECHO OFF
 (setq stytext (tblsearch "style" "AE-25")) ;SEARCH FOR AE-25
 (if                                        ;BEGINS PROCESS FOR MAKING AE-25
   (or
     (= NIL stytext)
     (/= (cdr (assoc 40 stytext)) 0.0)
   )
    (command "-style" "AE-25" "arial" "a" "y" "N" "2.5" "1.0" "0" "n"
      "n")
 )                                        ;END IF
;;;        CHECK AND SET TEXT STYLE        ;;;
 (SETQ LAYER (TBLSEARCH "LAYER" "C-ANNO-TEXT"))
 (IF
   (= NIL LAYER)
    (COMMAND "-LAYER" "N" "C-ANNO-TEXT" "S" "C-ANNO-TEXT" "C" "2" "" "")
 )
 (IF
   (/= LAYER NIL)
    (COMMAND "-LAYER" "S" "C-ANNO-TEXT" "")
 )
;;;        BEGIN MAIN FUNCTION                ;;;
 (WHILE                                ;BEGIN IF
   (> COUNT N)                                ;LOGIC STATEMENT
    (PROGN                                ;BEGIN PROGN
      (SETQ                                ;BEGIN SETQ
 OBJ   (SSNAME SSET N)                ;GET NEXT OBJECT IN SELECTION SET
 OBJ   (VLAX-ENAME->VLA-OBJECT OBJ) ;CONVERT
 check (vlax-get obj 'objectname) ;get object name
 len   (vla-get-length obj)
 len2   (/ len 2)
      )                                ;END SETQ
      (IF                                ;BEGIN IF FOR LINE
 (= CHECK "AcDbLine")                ;LOGIC STATEMENT
  (progn
    (setq
      ITEM (ENTGET (SSNAME SSET N))
      PT1  (CDR (ASSOC 10 ITEM))
      PT2  (CDR (ASSOC 11 ITEM))
    )
  )
      )                                ;END IF FOR LINE
      (IF                                ;BEGIN IF FOR POLYLINE
 (= CHECK "AcDbPolyline")        ;LOGIC STATEMENT
  (setq                                ;BEGIN SETQ
    lst        (vlax-get OBJ 'coordinates) ;GETS COORDINATES
    LEN        (VLA-GET-LENGTH OBJ)        ;GET LENGTH
    LEN2(/ LEN 2)                ;HALVE THE LENGTH
    pT1        (list (car lst) (cadr lst)) ;GETS START POINT
    lst        (reverse lst)                ;REVERSE LIST
    pT2        (list (cadr lst) (car lst)) ;GETS END POINT
  )
      )                                ;END IF POLYLINE
      (setq
 ANG   (ANGLE PT1 PT2)                ;GET ANGLE IN RADS
 ANG2  (/ (* ANG 180) PI)        ;CONVERTS ANGLE TO DEGREES
 PT1_X (CAR PT1)                ;GETS X OF START POINT
 PT1_Y (CADR PT1)                ;GETS Y OF START POINT
 PT2_X (CAR PT2)                ;GETS X OF END POINT
 PT2_Y (CADR PT2)                ;GETS Y OF END POINT
 RUN   (- PT2_X PT1_X)                ;GETS RUN
 RISE  (/ (- PT2_Y PT1_Y) RATIO)
                                ;GETS RISE AND DIVIDES BY RATIO
      )                                ;END SETQ
      (IF (> 0 RUN)                        ;BEGIN IF
 (SETQ RUN (* RUN -1))                ;IF RUN IS NEGITIVE TURN POSITIVE
      )                                ;END IF
      (IF (> 0 RISE)                        ;BEGIN IF
 (SETQ RISE (* RISE -1))        ;IF RUN IS NEGITIVE TURN POSITIVE
      )                                ;END IF
      (SETQ                                ;BEGIN SETQ
 SLOPE (* (/ RISE RUN) 100)        ;GETS SLOPE
      )
      (IF (> 0 SLOPE)                        ;BEGIN IF
 (SETQ SLOPE (* SLOPE -1))        ;IF RUN IS NEGITIVE TURN POSITIVE
      )                                ;END IF
      (SETQ
 MIDPOINT (POLAR PT1 ANG LEN2)
      )                                ;END SETQ
(if
 (< PT2_X PT1_X)
 (SETQ ANG2 (- ANG2 180)
))
      (COMMAND "_TEXT" "J" "BC" MIDPOINT ANG2 ( RTOS len 2 3))
      (SETQ N (+ 1 N))                        ;INCREASE N BY 1
    )                                        ;END PROGN
 )                                        ;END IF
 (COMMAND "CMDECHO" 1)
 (PRINC)
)
;END DEFUN

;;;        CHECK AND SET TEXT STYLE        ;;;
 (COMMAND "CMDECHO" 0)                        ;ECHO OFF
 (setq stytext (tblsearch "style" "AE-25")) ;SEARCH FOR AE-25
 (if                                        ;BEGINS PROCESS FOR MAKING AE-25
   (or
     (= NIL stytext)
     (/= (cdr (assoc 40 stytext)) 0.0)
   )
    (command "-style" "AE-25" "arial" "a" "y" "N" "2.5" "1.0" "0" "n"
      "n")
 )                                        ;END IF
;;;        CHECK AND SET TEXT STYLE        ;;;
 (SETQ LAYER (TBLSEARCH "LAYER" "C-ANNO-TEXT"))
 (IF
   (= NIL LAYER)
    (COMMAND "-LAYER" "N" "C-ANNO-TEXT" "S" "C-ANNO-TEXT" "C" "2" "" "")
 )
 (IF
   (/= LAYER NIL)
    (COMMAND "-LAYER" "S" "C-ANNO-TEXT" "")

(if
 (< PT2_X PT1_X)
 (SETQ ANG2 (- ANG2 180)
))
      (COMMAND "_TEXT" "J" "BC" MIDPOINT [b]ANG2[/b] ( RTOS len 2 [b]3[/b]))
      (SETQ N (+ 1 N))                        ;INCREASE N BY 1
    )                                        ;END PROGN
 )                                        ;END IF

(defun c:pole_line ( / *error* acDoc ms ht ss i e p a pn pp pole_list prev_list p1 p2 pt txt)
 (setq acDoc (vla-get-activedocument (vlax-get-acad-object)))
 (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
;;;  (setq ht (/ (if (zerop (getvar 'measurement)) 0.1 2.5) (cond ((getvar 'cannoscalevalue)) (1.0))))
 (setq ht 5.0)
 (vla-startundomark acDoc)
 
 (defun *error* (msg)
   (and
     msg
     (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*"))
     (princ (strcat "\nError: " msg))
     )
   (vla-endundomark acDoc)
   (princ)
   )
 
 (if
   (setq ss (ssget '((0 . "INSERT"))))
   (progn
     (repeat (setq i (sslength ss))
       (setq e (vlax-ename->vla-object (ssname ss (setq i (1- i))))
             p (vlax-get e 'InsertionPoint)
             a (vlax-invoke e 'GetAttributes)
             pn nil pp nil
             )
       (foreach x a
         (cond
           ((eq (vla-get-tagstring x) "POLE_NUM")
            (setq pn (vla-get-textstring x))
            )
           ((eq (vla-get-tagstring x) "PREV_POLE")
            (setq pp (vla-get-textstring x))
            )
           )
         )
       (if pn (setq pole_list (cons (list pn pp p) pole_list))
         (if pp (setq prev_list (cons (list pp p) prev_list)))
         )
       )
     (foreach p2 pole_list
       (if
         (or
           (setq p1 (assoc (cadr p2) pole_list))
           (setq p1 (assoc (cadr p2) prev_list))
           )
         (progn
           (setq p1 (last p1) p2 (last p2)
                 a  (angle p1 p2)
                 a  (if (< (* pi 0.5) a (* pi 1.25)) (- a (/ pi 2.0)) (+ a (/ pi 2.0)))
                 pt (polar (mapcar '(lambda (a b) (* (+ a b) 0.5)) p1 p2) a (* ht 2.0))
                 )
           (entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
           (setq txt (vla-addtext ms (rtos (distance p1 p2) 2 0) (vlax-3D-point 0.0 0.0 0.0) ht))
           (vla-put-alignment txt acalignmentmiddlecenter)
           (vla-put-textalignmentpoint txt (vlax-3D-point pt))
         )
       )
     )
   )
 )
 (vla-endundomark acDoc)
 (princ)
)

(defun c:pole_line ( / *error* acDoc ms ht ss i e p a pn pp pole_list prev_list p1 p2 pt txt)
 (setq acDoc (vla-get-activedocument (vlax-get-acad-object)))
 (setq ms (getvar 'ctab))
 (vla-startundomark acDoc)
 
 (defun *error* (msg)
   (and
     msg
     (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*"))
     (princ (strcat "\nError: " msg))
     )
   (vla-endundomark acDoc)
   (princ)
   )
 
 (if
   (setq ss (ssget '((0 . "INSERT"))))
   (progn
     (repeat (setq i (sslength ss))
       (setq e (vlax-ename->vla-object (ssname ss (setq i (1- i))))
             p (reverse (cdr (reverse (vlax-get e 'InsertionPoint))))
             a (vlax-invoke e 'GetAttributes)
             pn nil pp nil
             )
       (foreach x a
         (cond
           ((eq (vla-get-tagstring x) "POLE_NUM")
            (setq pn (vla-get-textstring x))
            )
           ((eq (vla-get-tagstring x) "PREV_POLE")
            (setq pp (vla-get-textstring x))
            )
           )
         )
       (if pn (setq pole_list (cons (list pn pp p) pole_list))
         (if pp (setq prev_list (cons (list pp p) prev_list)))
         )
       )
     (foreach p2 pole_list
       (if
         (or
           (setq p1 (assoc (cadr p2) pole_list))
           (setq p1 (assoc (cadr p2) prev_list))
           )
         (progn
           (setq p1 (last p1) p2 (last p2)
                 a  (angle p1 p2)
                 a  (if (< (* pi 0.5) a (* pi 1.25)) (- a (/ pi 2.0)) (+ a (/ pi 2.0)))
                 pt (polar (mapcar '(lambda (a b) (* (+ a b) 0.5)) p1 p2) a 15.0)
                 )
           (entmake
             (list
               '(0 . "LWPOLYLINE")
               '(100 . "AcDbEntity")
               (cons 410 ms)
               '(100 . "AcDbPolyline")
               '(90 . 2)
               '(70 . 0)
               (cons 10 p1)
               '(40 . 1.0)
               '(41 . 1.0)
               (cons 10 p2)
               '(40 . 1.0)
               '(41 . 1.0)
               '(210 0.0 0.0 1.0)
             )
           )
           (entmake
             (list
               '(0 . "TEXT")
               '(100 . "AcDbEntity")
               (cons 410 ms)
               '(100 . "AcDbText")
               (cons 10 pt)
               '(40 . 10.0)
               (cons 1 (strcat (rtos (distance p1 p2) 2 0) "'"))
               '(50 . 0.0)
               (cons 7 (getvar "textstyle"))
               '(72 . 1)
               (cons 11 pt)
               '(73 . 2)
             )
           )
         )
       )
     )
   )
 )
 (vla-endundomark acDoc)
 (princ)
)