[编程交流] 我的一些lisp编码。。。

(vl-load-com)
(defun circ2poly
      (obj / ctr radio a b c d pts vla_poly color_use space)
 (if (wcmatch (getvar "acadver") "16*,17*,18*")
   (setq color_use (vla-get-colorindex (vla-get-truecolor obj))))
 (if (wcmatch (getvar "acadver") "15*")
   (setq color_use (vla-get-color obj)))
 (setq ctr (vlax-get obj 'center))
 (setq radio (vlax-get obj 'radius))
 (setq a (polar ctr pi radio))
 (setq b (polar ctr 0.0 radio))
 (setq c (polar ctr (* pi 0.5) radio))
 (setq d (polar ctr (* pi 1.5) radio))
 (setq pts (mapcar '2dpt (list a b)))
 (setq
   space (vla-objectidtoobject
    (vla-get-database obj)
    (vla-get-ownerid obj)))
 (if (not (vl-catch-all-error-p
     (setq vla_poly
     (vl-catch-all-apply
       'vla-addlightweightpolyline
       (list space
      (lstVariantarray (apply 'append pts)))))))
   (vla-put-closed vla_poly t))
 (vla-setbulge
   vla_poly
   0
   (getBulge a c b))
 (vla-setbulge
   vla_poly
   1
   (getBulge b d a))
 (putColor vla_poly color_use)
 vla_poly)
(defun 2dpt  (pt)
 (if (caddr pt)
   (list (car pt) (cadr pt))
   pt))
(defun putColor  (obj color_use)
 (if (wcmatch (getvar "acadver") "16*,17*,18*")
   (setq vla_truecolor
   (vla-getinterfaceobject
     (vlax-get-acad-object)
     (cond
       ((wcmatch (getvar "acadver") "16*")
 "AutoCAD.AcCmColor.16")
       ((wcmatch (getvar "acadver") "17*")
 "AutoCAD.AcCmColor.17")
       ((wcmatch (getvar "acadver") "18*")
 "AutoCAD.AcCmColor.18")))))
 (if (wcmatch (getvar "acadver") "16*,17*,18*")
   (progn
     (vla-put-colorindex
vla_truecolor
color_use)
     (if obj
(vla-put-truecolor obj vla_truecolor)))
   (if (wcmatch (getvar "acadver") "15*")
     (vla-put-color obj color_use)))
 (vlax-release-object vla_truecolor)
 (setq vla_truecolor nil))
(defun lstVariantarray  (ptslist / arrayspace sarray)
 (setq arrayspace
 (vlax-make-safearray
   vlax-vbdouble
   (cons 0
  (- (length ptslist) 1))))
 (setq sarray (vlax-safearray-fill arrayspace ptslist))
 (vlax-make-variant sarray))
(defun getBulge  (fromvertex midp p2 / ang chord midc alt)
 (setq ang   (angle fromvertex p2)
chord (distance fromvertex p2)
midc  (polar fromvertex ang (* chord 0.5))
alt   (distance midp midc))
 (cond
   ((zerop chord) 0.0)
   ((equal (angle midp midc)
    (rem (+ ang (* pi 0.5)) (* pi 2))
    1e-4)
    (/ alt chord 0.5))
   (t (/ alt chord -0.5))))
(defun ss2lst  (ss / i lst)
 (setq i (if ss
    (1- (sslength ss))
    -1))
 (while (>= i 0)
   (setq lst (cons
 (vlax-ename->vla-object
   (ssname ss i))
 lst)
  i   (1- i)))
 lst)
;; single
(defun C:SCIRC2POLY  (/ obj)
 (setq
   obj (vlax-ename->vla-object (car (entsel "\nSelect Circle: "))))
 (circ2poly obj))
;; multiple
(defun C:MCIRC2POLY  (/ ss lst)
 (if (setq ss (ssget '((0 . "CIRCLE"))))
   (progn
     (setq lst (ss2lst ss))
     (foreach obj lst (circ2poly obj))))
 (princ))
(princ)