[编程交流] Lisp-将pt1切换到pt2-

(defun c:test(/ pt1 pt2)
 (and
   (setq pt1(getpoint "\nSpecify pt1: "))
   (setq pt2(getpoint "\nSpecify pt2: "))
   (>(cadr pt2)(cadr pt1))
   (vl-cmdf "_.line" pt1 pt2 "")
   ); end and
 (princ)
 ); end of c:test

(defun c:linewiz ()
   (vl-load-com)
   (defun MkLine (p1 p2 lw_lay)
(entmakex (list        (cons 0 "LINE")
                (cons 8 lw_lay)
                (cons 10 p1)
                (cons 11 p2)
          ) ;_ end_list
) ;_ end_entmakex
   ) ;_ end_defun
   (if        (setq lw_set (ssget '((0 . "LINE"))))
(progn
    (setq counter 0)
    (while (< counter (sslength lw_set))
        (setq lw_ent (ssname lw_set counter))
        (setq lw_lay (cdr (assoc 8 (entget lw_ent))))
        (if
            (< (cadr (setq lw_stpt
                              (vlax-curve-getStartPoint
                                  lw_ent
                              ) ;_ end_vlax-curve-getStartPoint
                     ) ;_ end_setq
               ) ;_ end_cadr
               (cadr (setq lw_endpt
                              (vlax-curve-getendpoint
                                  lw_ent
                              ) ;_ end_vlax-curve-getendpoint
                     ) ;_ end_setq
               ) ;_ end_cadr
            ) ;_ end_<
               (progn
                   (mkline lw_endpt lw_stpt lw_lay)
                   (entdel lw_ent)
               ) ;_ end_progn
        ) ;_ end_if
        (setq counter (1+ counter))
    ) ;_ end_while
) ;_ end_progn
   ) ;_ end_if
   (princ)
) ;_ end_defun

;;  CAB 10.23.08  version 1.4
;;  added skip of length too short for sizing
;;  CAB 10.24.08  version 1.5
;;  Changed test for Metric using MEASUREMENT ILO MEASUREINIT system var
;;  Zykl0 10.24.08  version 1.5.1
;;  Changed Some Layers and textstyle to fit new template
(defun c:LabelPipe (/ index ss obj lyr ept spt mpt mpt1 mpt2 txtht len len$ lst dUnits
                   MinLen Metric
                   txtoffset 25Size 32Size 40Size 50Size 65Size maketext kdub:roundNearest GetUnits)
 
 (defun maketext (pt ang str ht just lay sty / dxf72 dxf73)
   ;;(setq dxf72 (cdr (assoc just '(("TC" . 1 )("BC" . 1 )))))
   (setq dxf73 (cdr (assoc just '(("TC" . 3) ("BC" . 1)))))
   (entmakex (list (cons 0 "TEXT") 
                   (cons 1 str) ; (the string itself)
                   (cons 6 "BYLAYER") ; Linetype name 
                   (cons 7 sty) ;* Text style name, defaults to STANDARD, not current
                   (cons 8 lay) ; layer
                   (cons 10 pt) ;* First alignment point (in OCS) 
                   (cons 11 pt) ;* Second alignment point (in OCS) 
                   ;;(cons 39 0.0) ; Thickness (optional; default = 0)
                   (cons 40 ht) ;* Text height
                   ;;(cons 41 1.0) ; Relative X scale factor, Width Factor, defaults to 1.0
                   (cons 50 ang) ; Text rotation ange
                   ;;(cons 51 0.0) ; Oblique angle 
                   (cons 71 0) ; Text generation flags 
                   (cons 72 1) ; Horizontal text justification type 
                   (cons 73 dxf73) ; Vertical text justification type
             )
   )
 )
 
 ;;* kdub:roundNearest (numVal roundTo displayPrecision)
 ;; Round a numeric positive number to the NEAREST 'rounded' number
 ;; and format to n digits
 ;; kwb@theSwamp 20070814
 (DEFUN kdub:roundNearest (numVal roundTo displayPrecision / remNum)
     (SETQ remNum (REM numVal roundTo))
     (RTOS (IF (>= (* 2 remNum) roundTo)
               (+ numVal (- roundTo remNum))
               (- numVal remNum)
           )
           2
           displayPrecision
     )
 )
 
 ;;  Returns the type of units
 (defun GetUnits (/ Units)
   (setq Units (getvar "InsUnits")) ; DesignCenter Drag Units
   (cond
     ((= Units 0) ;NoUnit
      (if (= (getvar "MEASUREMENT") 1) ; if metric
        "mm"                           ; use Millimeter
        "inch"                         ; else Inch
      )
     )
     (t
      (nth
        (1- Units)
        (list
          "inch"       ;Inch
          "feet"       ;Feet
          "mile"       ;Mile
          "mm"         ;Millimeter
          "cm"         ;Centimeter
          "m"          ;Meter
          "km"         ;Kilometer
          "microinch"  ;Micro inch
          "mil"        ;Milli inch
          "yard"       ;Yard
          "angstrom"   ;Angstrom
          "nm"         ;Nanometer
          "micron"     ;Micron
          "dm"         ;Decimeter
          "dam"        ;Decameter
          "hm"         ;Hectometer
          "gm"         ;Gigameter
          "au"         ;Astronomic unit
          "light_year" ;Light year
          "parsec"     ;Parsec
         )
      )
     )
   )
 )
 ;;  use Royal Text Style if it exist
 (if (setq lst (tblsearch "style" "Royaltech"))
   (setq sty "Royaltech"
         txtht (cdr (assoc 40 lst)) ; calc the text height
         txtht (if (zerop txtht)(* (getvar "dimscale") 0.09375)txtht) ; correct for 0
   )
   ;; else use current text height
   (setq sty "STANDARD"
         ;;txtht (getvar 'textsize) ; calc the text height
         txtht (* (getvar "dimscale") 0.09375) ; calc the text height
   )
 )
 
 
 (setq dUnits (strcat " "(GetUnits)))
 (if (or (vl-position (getvar "InsUnits") '(4 5 6 7 12 14 15 16 17))
               (= (getvar "MEASUREMENT") 1) ; if metric
           )
   ;;  Metric Units
   (setq txtoffset (/ txtht 2.0) ; text offset from line
         25Size  (strcat "25")
         32Size  (strcat "32")
         40Size  (strcat "40")
         50Size  (strcat "50")
         65Size  (strcat "65")
         MinLen    305  ; Min Length to add text
         Metric    t
   )
   ;;  English Units
   (setq txtoffset (/ txtht 2.0) ; text offset from line
         25Size  "1""
         32Size  "1¼""
         40Size  "1½""
         50Size  "2""
         65Size  "2½""
         MinLen    12  ; Min Length to add text
   )
 )
 
 (setq index -1)
 (prompt "\nSelect pipes to label.")
 (if (setq ss (ssget '((0 . "LINE") (8 . "M-N-INC-CPVC-25,M-N-INC-CPVC-32,M-N-INC-CPVC-40,M-N-INC-CPVC-50,M-N-INC-CPVC-65"))))
   (progn
     (command "._Undo" "_begin")
     (while (< (setq index (1+ index)) (sslength ss))
       (setq obj (vlax-ename->vla-object (ssname ss index))
             lyr (vla-get-layer obj)
             ept (vlax-get obj 'endpoint)
             spt (vlax-get obj 'startpoint)
             ang (angle spt ept)
             mpt (polar ept (angle ept spt) (/ (distance ept spt) 2.0))
             len (vlax-get obj 'length)
       )
       (if (> len MinLen)
         (progn
       (if (and (> ang (* 0.5 pi)) (<= ang (* 1.5 pi)))
         (setq ang (+ ang pi))
       )
       ;;  text offset from pipe 
       (setq mpt1  (polar mpt (+ ang (/ pi 2.0)) txtoffset)
             mpt2 (polar mpt (+ ang (* pi 1.5)) txtoffset)
       )
       ;;  adjust for Metric units rounded to 5 & 0 decimal points
       ;;  or English Units rounded to 1/4
       (if Metric ; if metric
         (setq len$ (strcat (kdub:roundNearest len 5 0))) ; use Millimeter 05 
         (setq len$ (rtos len 4 2)) ; else Inch & 0.00
       )
       (cond
         ((= lyr "M-N-INC-CPVC-25")
          (maketext mpt1 ang 25Size txtht "BC" "M-N-INC-CPVC-25-DIA" sty)
          (maketext mpt2 ang len$ txtht "TC" "M-N-INC-CPVC-25-LIN" sty)
         )
         ((= lyr "M-N-INC-CPVC-32")
          (maketext mpt1 ang 32Size txtht "BC" "M-N-INC-CPVC-32-DIA" sty)
          (maketext mpt2 ang len$ txtht "TC" "M-N-INC-CPVC-32-LIN" sty)
         )
         ((= lyr "M-N-INC-CPVC-40")
          (maketext mpt1 ang 40Size txtht "BC" "M-N-INC-CPVC-40-DIA" sty)
          (maketext mpt2 ang len$ txtht "TC" "M-N-INC-CPVC-40-LIN" sty)
         )
         ((= lyr "M-N-INC-CPVC-50")
          (maketext mpt1 ang 50Size txtht "BC" "M-N-INC-CPVC-50-DIA" sty)
          (maketext mpt2 ang len$ txtht "TC" "M-N-INC-CPVC-50-LIN" sty)
         )
         ((= lyr "M-N-INC-CPVC-65")
          (maketext mpt1 ang 65Size txtht "BC" "M-N-INC-CPVC-65-DIA" sty)
          (maketext mpt2 ang len$ txtht "TC" "M-N-INC-CPVC-65-LIN" sty)
         )
       )
      ))
     )
     (command "._Undo" "_end")
   )
 )
 (princ)
)
(prompt "\nLabel pipe lisp loaded, Enter LabelPipe to run.")
(princ)