[编程交流] 用多边形绘制圆

(defun C:test (/ e sel d c p en)
;;;jdiala 09-06-14 Cadtutor.net ;;;
(vl-load-com)
(if
(setq e
 (while
   (not e)
     (progn 
       (setq sel (entsel "\nSelect a polygon :"))
       (cond
         ( (= nul sel)
           (princ "\nMissed! ")
         )
         ( (/= "LWPOLYLINE" (cdr (assoc 0 (entget (car sel)))))
           (princ "\nInvalid selection. " )
         )        
         ( (and
             (= "LWPOLYLINE" (cdr (assoc 0 (entget (car sel)))))
             (= 1 (cdr (assoc 70 (entget (car sel)))))
           )  
           (setq e sel))
         (t nil)
       ) 
     )
 )
 d (getdist "\nEnter offset distance :")
 c (/ (getdist "\nEnter diameter of circle :") 2.0)
 p (getpoint "\nPick side to offset :")
 )
 (progn
  (command "_.offset" d e p "")
  (mapcar 
    (function 
      (lambda (z)
        (entmake 
          (list 
            (cons 0 "CIRCLE") 
            (cons 10 (cdr z)) 
            (cons 40 c)
          )
        )
        (entmake 
          (list 
            (cons 0 "LINE") 
            (cons 10 (polar (cdr z) 0 (* c 1.5))) 
            (cons 11 (polar (cdr z) pi (* c 1.5))) 
          )
        )
        (entmake 
          (list 
            (cons 0 "LINE") 
            (cons 10 (polar (cdr z) (/ pi 2.) (* c 1.5))) 
            (cons 11 (polar (cdr z) (* pi 1.5) (* c 1.5))) 
          )
        )
      )
    ) 
    (vl-remove-if-not 
      (function 
        (lambda (x) 
          (= 10 (car x))
        )
      ) 
      (entget 
        (setq en (entlast))
      )
    )
  )
  (entdel en)
 )
)
(princ)
)

(defun c:Test (/ _line _screw l lk s sn a p1 p2 gr ang o lst pts)
 ;;        Author : Tharwat Al Shoufi                ;;
 ;;        Date : 07.Sep.2014                        ;;
 ;; Dynamic draw a circle with a cross of line        ;;
 ;; at specific offset distance of a polyline        ;;
 (defun _line (p q) (entmakex (list '(0 . "LINE") (cons 62 4) (cons 10 p) (cons 11 q))))
 (defun _screw (pts r / lst 1p)
   (mapcar '(lambda (p)
              (setq lst (cons (entmakex (list '(0 . "CIRCLE") (cons 10 p) (cons 40 r))) lst)
                    lst (cons (_line (setq 1p (polar p 0. (* r 1.2))) (polar p pi (* r 1.2))) lst)
                    lst (cons (_line (setq 1p (polar p (* pi 1.5) (* r 1.2))) (polar p (* pi 0.5) (* r 1.2))) lst)
              )
            )
           pts
   )
   lst
 )
 (if (eq 4 (logand 4 (cdr (assoc 70 (entget (tblobjname "LAYER" (getvar 'clayer)))))))
   (progn (alert "Warning ! Current layer is Locked") (setq lk t))
 )
 (setq l (entlast))
 (if (and (not lk)
          (setq s (entsel "\n Select a polyline :"))
          (eq (cdr (assoc 0 (entget (setq sn (car s))))) "LWPOLYLINE")
          (setq *dist* (cond ((getdist (strcat "\n Offset distance < "
                                               (rtos (if *dist*
                                                       *dist*
                                                       (setq *dist* 1.0)
                                                     )
                                                     2
                                                     2
                                               )
                                               " > :"
                                       )
                              )
                             )
                             (*dist*)
                       )
          )
          (setq *rad* (cond ((getdist (strcat "\n Specify radius of Circles < "
                                              (rtos (if *rad*
                                                      *rad*
                                                      (setq *rad* 1.0)
                                                    )
                                                    2
                                                    2
                                              )
                                              " > :"
                                      )
                             )
                            )
                            (*rad*)
                      )
          )
     )
   (progn (setq a (fix (vlax-curve-getparamatpoint sn (vlax-curve-getclosestpointto sn (cadr s)))))
          (setq p1 (vlax-curve-getpointatparam sn a))
          (setq p2 (vlax-curve-getpointatparam sn (setq a (1+ a))))
          (while (and (eq (car (setq gr (grread t 15 0))) 5)
                      (not (redraw))
                      (if (minusp (sin (- (angle p1 p2) (angle p2 (cadr gr)))))
                        (setq ang t)
                        (progn (setq ang nil) t)
                      )
                 )
            (vla-offset
              (vlax-ename->vla-object sn)
              (if ang
                (- *dist*)
                *dist*
              )
            )
            (if o
              (entdel o)
            )
            (if lst
              (mapcar 'entdel lst)
            )
            (if (not (eq (setq o (entlast)) l))
              o
            )
            (setq l   o
                  pts nil
            )
            (foreach x (entget o)
              (if (eq (car x) 10)
                (setq pts (cons (list (cadr x) (caddr x) 0.) pts))
              )
            )
            (setq lst (_screw pts *rad*))
          )
          (if l
            (entdel l)
          )
   )
 )
 (princ)
)

;; Polyline Circles  -  Lee Mac
;; Generates a set of circles with centerlines for every vertex of a selected polyline,
;; offset inside or outside by a given distance based on the cursor position.
(defun c:polyc ( / *error* dia ent enx flg lst obj ocs off par pt1 pt2 pt3 )
   (defun *error* ( msg )
       (foreach grp lst (foreach ent grp (if (entget ent) (entdel ent))))
       (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
           (princ (strcat "\nError: " msg))
       )
       (princ)
   )
   
   (while
       (progn (setvar 'errno 0) (setq ent (car (entsel "\nSelect polyline: ")))
           (cond
               (   (= 7 (getvar 'errno))
                   (princ "\nMissed, try again.")
               )
               (   (null ent) nil)
               (   (/= "LWPOLYLINE" (cdr (assoc 0 (setq enx (entget ent)))))
                   (princ "\nSelected object is not a polyline.")
               )
           )
       )
   )
   (if (and (= 'ename (type ent))
            (setq obj (vlax-ename->vla-object ent))
            (setq off (getdistwithdefault "\nSpecify offset distance" 'polyc:off))
            (setq dia (getdistwithdefault "\nSpecify circle diameter" 'polyc:dia))
            (setq dia (/ dia 2.0)
                  ocs (assoc 210 enx)
            )
       )
       (if
           (apply 'and
               (setq lst
                   (mapcar
                       (function
                           (lambda ( x )
                               (apply 'append
                                   (mapcar
                                       (function
                                           (lambda ( y / r )
                                               (setq r
                                                   (apply 'append
                                                       (mapcar
                                                           (function
                                                               (lambda ( p )
                                                                   (cons (entmakex (list '(0 . "CIRCLE") p (cons 40 dia) ocs))
                                                                       (mapcar
                                                                           (function
                                                                               (lambda ( a )
                                                                                   (entmakex
                                                                                       (list
                                                                                          '(0 . "LINE")
                                                                                           (cons 10 (trans (mapcar '+ (cdr p) a) (cdr ocs) 0))
                                                                                           (cons 11 (trans (mapcar '+ (cdr p) (mapcar '- a)) (cdr ocs) 0))
                                                                                       )
                                                                                   )
                                                                               )
                                                                           )
                                                                           (list (list (* dia 1.5) 0.0) (list 0.0 (* dia 1.5)))
                                                                       )
                                                                   )
                                                               )
                                                           )
                                                           (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget (vlax-vla-object->ename y)))
                                                       )
                                                   )
                                               )
                                               (vla-delete y)
                                               r
                                           )
                                       )
                                       x
                                   )
                               )
                           )
                       )
                       (list
                           (catchapply 'vlax-invoke (list obj 'offset off))
                           (catchapply 'vlax-invoke (list obj 'offset (- off)))
                       )
                   )
               )
           )
           (progn
               (foreach ent (car lst) (entdel ent))
               (princ "\nChoose offset side: ")
               (while (= 5 (car (setq pt1 (grread t 13 0))))
                   (setq par (vlax-curve-getparamatpoint ent (vlax-curve-getclosestpointto ent (trans (cadr pt1) 1 0)))
                         pt2 (trans (vlax-curve-getpointatparam ent (fix par)) 0 1)
                         pt3 (trans (vlax-curve-getpointatparam ent (1+ (fix par))) 0 1)
                   )
                   (if (not (eq flg (setq flg (minusp (sin (- (angle pt2 (cadr pt1)) (angle pt2 pt3)))))))
                       (foreach grp lst (foreach ent grp (entdel ent)))
                   )
               )
           )
           (progn
               (princ "\nOffset distance too large - unable to perform internal offset.")
               (foreach x (apply 'append lst) (entdel x))
           )
       )
   )
   (princ)
)
(defun getdistwithdefault ( msg sym )
   (set sym (cond ((getdist (strcat msg (if (eval sym) (strcat " <" (rtos (eval sym)) ">: ") ": ")))) ((eval sym))))
)
(defun catchapply ( fun arg / rtn )
   (if (not (vl-catch-all-error-p (setq rtn (vl-catch-all-apply fun arg)))) rtn)
)
(vl-load-com) (princ)

'(0 . [color=MAROON]"LINE"[/color])
([color=BLUE]cons[/color] 10 ([color=BLUE]trans[/color] ([color=BLUE]mapcar[/color] '[color=BLUE]+[/color] ([color=BLUE]cdr[/color] p) a) ([color=BLUE]cdr[/color] ocs) 0))

'(0 . [color=MAROON]"LINE"[/color])
'(8 . [color=red]"Your Layer Here"[/color])
([color=BLUE]cons[/color] 10 ([color=BLUE]trans[/color] ([color=BLUE]mapcar[/color] '[color=BLUE]+[/color] ([color=BLUE]cdr[/color] p) a) ([color=BLUE]cdr[/color] ocs) 0))

(foreach grp lst (foreach ent grp (entdel ent)))