[编程交流] 孔ID的Lisp

(defun C:LC (/ ang base color dia ds elist en ent ep layer p1 p2 p3
       pt rad sp txtheight txtstyle xs xv ys yv)
 (setvar "osmode" 32)
 (setvar "orthomode" 1)
 (setq txtheight 35.0
txtstyle "ISOCP"
layer "DIMS"
color 2
)
(setq base (getpoint "\nPick base point (red cross): "))
 (while (setq ent (entsel "\nSelect circle (or press Enter to Exit)>> "))
   (setq en (car ent)
 elist (entget en)
 pt (cdr (assoc 10 elist))
  xv (abs (- (car base)(car pt)))
  xs (rtos xv 2 0)
  yv (abs (- (cadr base)(cadr pt)))
  ys (rtos yv 2 0)
 rad (cdr (assoc 40 elist))
  dia (* rad 2)
  ds (rtos dia 2 1)
  )
(setq ep (getpoint pt "\nSpecify end point of leader line >>"))
(setq ang (angle pt ep)
     ep (polar pt ang 700)
     sp (polar pt ang dia)
     p1 (polar pt ang 250)
     p2 (polar p1 ang 150)
     p3 (polar p2 ang 150)
     p1 (polar p1 (/ pi 2) (/ txtheight 2))
     p2 (polar p2 (/ pi 2) (/ txtheight 2))
     p3 (polar p3 (/ pi 2) (/ txtheight 2))
     )
(entmake (list '(0 . "LINE")
               '(100 . "AcDbEntity")
        (cons 67
  (if (= 0 (getvar "tilemode"))
    1
    0))
      (cons 410 (getvar "ctab"))
      (cons 8 layer)
      (cons 62 7)
               '(100 . "AcDbLine")
               (cons 10 sp)
               (cons 11 ep)
         ) 
)
(entmake
    (list
      '(0 . "TEXT")
      '(100 . "AcDbEntity")
      (cons 67
  (if (= 0 (getvar "tilemode"))
    1
    0))
      (cons 410 (getvar "ctab"))
      (cons 8 layer)
      (cons 62 color)
      '(100 . "AcDbText")
      (cons 10 p1)
      (cons 11 (list (car p1) (- (cadr p1) (/ txtheight 2)) 0.0))
      (cons 40 txtheight)
      (cons 1 ys)
      '(50 . 0.0)
      '(41 . 1.0)
      '(51 . 0.0)
      (cons 7  txtstyle)
      '(71 . 0)
      '(72 . 1)
      '(73 . 1)))
   (entmake
    (list
      '(0 . "TEXT")
      '(100 . "AcDbEntity")
      (cons 67
  (if (= 0 (getvar "tilemode"))
    1
    0))
      (cons 410 (getvar "ctab"))
      (cons 8 layer)
      (cons 62 color)
      '(100 . "AcDbText")
      (cons 10 p2)
      (cons 11 (list (car p2) (- (cadr p2) (/ txtheight 2)) 0.0))
      (cons 40 txtheight)
      (cons 1 xs)
      '(50 . 0.0)
      '(41 . 1.0)
      '(51 . 0.0)
      (cons 7  txtstyle)
      '(71 . 0)
      '(72 . 1)
      '(73 . 1)))
   (entmake
    (list
      '(0 . "TEXT")
      '(100 . "AcDbEntity")
      (cons 67
  (if (= 0 (getvar "tilemode"))
    1
    0))
      (cons 410 (getvar "ctab"))
      (cons 8 layer)
      (cons 62 color)
      '(100 . "AcDbText")
      (cons 10 p1)
      (cons 11 (list (car p3) (- (cadr p3) (/ txtheight 2)) 0.0))
      (cons 40 txtheight)
      (cons 1 ds)
      '(50 . 0.0)
      '(41 . 1.0)
      '(51 . 0.0)
      (cons 7  txtstyle)
      '(71 . 0)
      '(72 . 1)
      '(73 . 1)))
   )
 (princ)
 )
(prompt "\n   >>>   Type LC to run...")
(prin1)

;; local defun  
(defun dxf (key elist)
 (cdr (assoc key elist))
 )
;; main part  
(defun C:LC (/ *error* ang base color dia ds dxflist elist en ent ep layer osm ort
       p1 p2 p3 pt rad sp txtheight txtstyle xs xv ys yv vpt)
 ;; error trapping routine
 (defun *error* (msg)
 (if
   (and msg
   (vl-position
     msg
     '("console break"
"Function cancelled"
"quit / exit abort"
)
     )
 )
   (princ (strcat "\n** Error: " msg " **"))
   (princ "\nError!")
   )
 (command "undo" "end")  
 (if osm (setvar "osmode" osm))
 (if ort (setvar "orthomode" ort))
)
 (command "undo" "begin")
 (setq osm (getvar "osmode"))
 (setvar "osmode" 32)
 (setq ort (getvar "orthomode"))
 (setvar "orthomode" 0)
 (setq txtheight 35.0
txtstyle "ISOCP"
layer "DIMS"
color 2
)
(setq base (getpoint "\nPick base point (red cross): "))
 (while (setq ent (entsel "\nSelect circle (or press Enter to Exit)>> "))
   (setq en (car ent)
 elist (entget en)
 pt (cdr (assoc 10 elist))
  xv (abs (- (car base)(car pt)))
  xs (rtos xv 2 0)
  yv (abs (- (cadr base)(cadr pt)))
  ys (rtos yv 2 0)
 rad (cdr (assoc 40 elist))
  dia (* rad 2)
  ds (rtos dia 2 1)
  )
(command "_.dimordinate" "_non" pt "_t" (strcat ys "\t" xs "\t" ds) pause)
(setq dxflist (entget (entlast))
     vpt (dxf 14 dxflist)
     )
(if  (> (* pi 1.5) (angle pt vpt) (/ pi 2))
      (setq dxflist (subst (cons 1 (strcat ds "\t" xs "\t" ys))(assoc 1 dxflist) dxflist))
       (setq dxflist (subst (cons 1 (strcat ys "\t" xs "\t" ds))(assoc 1 dxflist) dxflist))
 )
(entmod dxflist)
(entupd (entlast))
   )
(*error* nil) 
(princ)
 )
(prompt "\n   >>>   Type LC to run...")
(prin1)