为任意物体添加圆圈，非常好的函数，可惜括号出问题了

meja · 发表于 2023-6-8 11:57:34

本帖最后由 meja 于 2023-6-8 12:35 编辑

源码来自augi的论坛，不知道为何本地无法运行，请坛友清除BUG

(vl-load-com)
(defun c:cisel ( / *error* *adoc* 5px gr f ff k r n p pl ci cix s ss )
(defun *error* ( msg )
(if (entget ci)
(entdel ci)
)
(vla-endundomark *adoc*)
(if msg
(prompt msg)
)
(princ)
)
(setq *adoc* (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark *adoc*)
(setq 5px (* 5 (/ (getvar 'viewsize) (cadr (getvar 'screensize)))))
(prompt "\n"-" reduce circle; "+" increase circle; left mouse click - brush down, second click - brush up; right mouse click - deselecting mode\nESC - finish")
(while (or (= 5 (car (setq gr (grread t 5 1)))) (= 2 (car gr)) (= 3 (car gr)) (= 11 (car gr)) (= 25 (car gr)))
(if ci
(setq cix (entget ci))
)
(cond
( (= (car gr) 3)
(if (null f)
(setq f t ff nil)
(setq f nil ff nil)
)
)
( (or (= (car gr) 11) (= (car gr) 25))
(if (null ff)
(setq ff t f nil)
(setq ff nil f nil)
)
)
)
(if (null k)
(setq k 3)
)
(cond
( (equal gr (list 2 (ascii "+")))
(setq k (1+ k))
)
( (equal gr (list 2 (ascii "-")))
(setq k (1- k))
(if (zerop k)
(setq k 1)
)
)
)
(setq r (* k 5px))
(if (and ci (or (equal gr (list 2 (ascii "+"))) (equal gr (list 2 (ascii "-")))))
(setq cix (subst (cons 40 r) (assoc 40 cix) cix))
)
(setq n -1)
(if (= (car gr) 5)
(progn
(repeat 36
(setq p (polar (cadr gr) (* (setq n (1+ n)) (/ pi 18)) r))
(setq pl (cons p pl))
)
(if (null ci)
(setq ci (entmakex (list '(0 . "CIRCLE") (cons 10 (cadr gr)) (cons 40 r) '(62 . 2))))
(setq cix (subst (cons 10 (cadr gr)) (assoc 10 cix) cix))
)
)
)
(if pl
(progn
(if (setq s (ssget "_CP" pl))
(if ci
(ssdel ci s)
)
(setq s (ssadd))
)
(if (/= (sslength s) 0)
(progn
(setq cix (subst (cons 62 1) (assoc 62 cix) cix))
(cond
( f
(setq ss (acet-ss-union (list s ss)))
)
( ff
(setq ss (acet-ss-remove s ss))
)
)
)
(setq cix (subst (cons 62 2) (assoc 62 cix) cix))
)
)
)
(cond
( f
(setq cix (subst (cons 62 (+ (cdr (assoc 62 cix)) 2)) (assoc 62 cix) cix))
)
( ff
(setq cix (subst (cons 62 (+ (cdr (assoc 62 cix)) 4)) (assoc 62 cix) cix))
)
)
(if (and cix (not (equal cix (entget ci) 1e-))
(entupd (cdr (assoc -1 (entmod cix))))
)
(if ss
(sssetfirst nil ss)
)
(setq pl nil)
)
(*error* nil)
)
(princ)
)

(vl-load-com) 
 
(defun c:cisel ( / *error* *adoc* 5px gr f ff k r n p pl ci cix s ss ) 
 
 (defun *error* ( msg ) 
   (if (entget ci) 
     (entdel ci) 
   ) 
   (vla-endundomark *adoc*) 
   (if msg 
     (prompt msg) 
   ) 
   (princ) 
 ) 
 
 (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))) 
 (vla-startundomark *adoc*) 
 (setq 5px (* 5 (/ (getvar 'viewsize) (cadr (getvar 'screensize))))) 
 (prompt "\n"-" reduce circle; "+" increase circle; left mouse click - brush down, second click - brush up; right mouse click - deselecting mode\nESC - finish") 
 (while (or (= 5 (car (setq gr (grread t 5 1)))) (= 2 (car gr)) (= 3 (car gr)) (= 11 (car gr)) (= 25 (car gr))) 
   (if ci 
     (setq cix (entget ci)) 
   ) 
   (cond 
     ( (= (car gr) 3) 
       (if (null f) 
         (setq f t ff nil) 
         (setq f nil ff nil) 
       ) 
     ) 
     ( (or (= (car gr) 11) (= (car gr) 25)) 
       (if (null ff) 
         (setq ff t f nil) 
         (setq ff nil f nil) 
       ) 
     ) 
   ) 
   (if (null k) 
     (setq k 3) 
   ) 
   (cond 
     ( (equal gr (list 2 (ascii "+"))) 
       (setq k (1+ k)) 
     ) 
     ( (equal gr (list 2 (ascii "-"))) 
       (setq k (1- k)) 
       (if (zerop k) 
         (setq k 1) 
       ) 
     ) 
   ) 
   (setq r (* k 5px)) 
   (if (and ci (or (equal gr (list 2 (ascii "+"))) (equal gr (list 2 (ascii "-"))))) 
     (setq cix (subst (cons 40 r) (assoc 40 cix) cix)) 
   ) 
   (setq n -1) 
   (if (= (car gr) 5) 
     (progn 
       (repeat 36 
         (setq p (polar (cadr gr) (* (setq n (1+ n)) (/ pi 18)) r)) 
         (setq pl (cons p pl)) 
       ) 
       (if (null ci) 
         (setq ci (entmakex (list '(0 . "CIRCLE") (cons 10 (cadr gr)) (cons 40 r) '(62 . 2)))) 
         (setq cix (subst (cons 10 (cadr gr)) (assoc 10 cix) cix)) 
       ) 
     ) 
   ) 
   (if pl 
     (progn 
       (if (setq s (ssget "_CP" pl)) 
         (if ci 
           (ssdel ci s) 
         ) 
         (setq s (ssadd)) 
       ) 
       (if (/= (sslength s) 0) 
         (progn 
           (setq cix (subst (cons 62 1) (assoc 62 cix) cix)) 
           (cond 
             ( f 
               (setq ss (acet-ss-union (list s ss))) 
             ) 
             ( ff 
               (setq ss (acet-ss-remove s ss)) 
             ) 
           ) 
         ) 
         (setq cix (subst (cons 62 2) (assoc 62 cix) cix)) 
       ) 
     ) 
   ) 
   (cond 
     ( f 
       (setq cix (subst (cons 62 (+ (cdr (assoc 62 cix)) 2)) (assoc 62 cix) cix)) 
     ) 
     ( ff 
       (setq cix (subst (cons 62 (+ (cdr (assoc 62 cix)) 4)) (assoc 62 cix) cix)) 
     ) 
   ) 
   (if (and cix (not (equal cix (entget ci) 1e-)) 
     (entupd (cdr (assoc -1 (entmod cix)))) 
   ) 
   (if ss 
     (sssetfirst nil ss) 
   ) 
   (setq pl nil) 
 ) 
 (*error* nil) 
) 
   (princ) 
 )

meja · 发表于 2023-6-10 19:58:08

无法运行

(defun pickset:to-list (ss)
(if ss (vl-remove-if-not (quote p:enamep)
(mapcar (quote cadr)
(ssnamex ss)))
nil))
(defun p:vla-listp (lst)
(apply (quote and)
(mapcar (quote vlap)
lst)))
(defun p:ename-listp (lst)
(apply (quote and)
(mapcar (quote enamep)
lst)))
(defun entity:getbox (ent offset / lst obj p1 p2 p3 p4)
(if (= (quote pickset)
(type ent))
(pickset:getbox ent offset)
(progn (setq obj (vlax-ename->vla-object ent))
(vla-getboundingbox obj (quote p1)
(quote p3))
(setq p1 (vlax-safearray->list p1)
p3 (vlax-safearray->list p3))
(if (= "SPLINE"
(cdr (assoc 0 (entget ent))))
(progn (setq lst (mapcar (quote (lambda (a b)
(vlax-curve-getclosestpointtoprojection ent a b t)))
(list p1 (list (car p1)
(cadr p3)
(caddr p1))
p3 (list (car p3)
(cadr p1)
(caddr p1)))
(quote ((1.0 0 0)
(0 -1.0 0)
(-1.0 0 0)
(0 1.0 0)))))
(setq p1 (apply (quote mapcar)
(cons (quote min)
lst))
p3 (apply (quote mapcar)
(cons (quote max)
lst)))))
(if (or (not offset)
(equal offset 0 0.0001))
(list p1 p3)
(list (list:- p1 (list offset offset 0))
(list:+ p3 (list offset offset 0)))))))
(defun pickset:getbox (ss offset / ptlist)
(cond ((= (quote pickset)
(type ss))
(setq ss (pickset:to-list ss)))
((= (quote ename)
(type ss))
(setq ss (list ss)))
((p:vla-listp ss)
(setq ss (mapcar (quote o2e)
ss))))
(if (p:ename-listp ss)
(progn (setq ptlist (apply (quote append)
(mapcar (quote (lambda (x)
(entity:getbox x offset)))
ss)))
(list (apply (quote mapcar)
(cons (quote min)
ptlist))
(apply (quote mapcar)
(cons (quote max)
ptlist))))
(progn (@:log "ERROR"
"parameter is NOT pickset")
nil)))
(defun point:mid (pt1 pt2)
"求两点 pt1 pt2 的中点"
"中点坐标"
(mapcar (quote (lambda (x y)
(* 0.5 (+ x y))))
pt1 pt2))
(defun entity:make-circle (pts-cen num-rad)
"创建圆.如果圆心是点的列表或半径是数值的列表，可以同时创建多个圆"
"Ename"
"(entity:make-circle (list (getpoint)(getpoint))
'(3 5))"
(cond ((and (= (quote point)
(type-of pts-cen))
(numberp num-rad))
(entmakex (list (quote (0 . "circle"))
(quote (100 . "AcDbEntity"))
(quote (100 . "AcDbCircle"))
(cons 10 pts-cen)
(cons 40 num-rad))))
((and (listp pts-cen)
(apply (quote and)
(mapcar (function (lambda (x)
(= (quote point)
(type-of x))))
pts-cen)))
(foreach pt pts-cen (entity:make-circle pt num-rad)))
((and (listp num-rad)
(apply (quote and)
(mapcar (quote numberp)
num-rad)))
(foreach rad num-rad (entity:make-circle pts-cen rad)))))
(defun c:sscircle ( )
"将选择的图形用圆圈住"
;; 选择图形
(setq ss (ssget ))
;; 获取图形的包围盒
(setq box (pickset:getbox ss 0))
;; 用包围盒的中心点与中心点到角点为半径画圆
(entity:make-circle
(setq c (point:mid (car box)(cadr box)))
((distance c (car box)))
))

(defun pickset:to-list (ss) 
 
  (if ss (vl-remove-if-not (quote p:enamep) 
      (mapcar (quote cadr) 
        (ssnamex ss))) 
    nil)) 
 
(defun p:vla-listp (lst) 
 
  (apply (quote and) 
    (mapcar (quote vlap) 
      lst))) 
 
(defun p:ename-listp (lst) 
   
  (apply (quote and) 
    (mapcar (quote enamep) 
      lst))) 
 
(defun entity:getbox (ent offset / lst obj p1 p2 p3 p4) 
 
  (if (= (quote pickset) 
      (type ent)) 
    (pickset:getbox ent offset) 
    (progn (setq obj (vlax-ename->vla-object ent)) 
      (vla-getboundingbox obj (quote p1) 
        (quote p3)) 
      (setq p1 (vlax-safearray->list p1) 
        p3 (vlax-safearray->list p3)) 
      (if (= "SPLINE" 
          (cdr (assoc 0 (entget ent)))) 
        (progn (setq lst (mapcar (quote (lambda (a b) 
                  (vlax-curve-getclosestpointtoprojection ent a b t))) 
              (list p1 (list (car p1) 
                  (cadr p3) 
                  (caddr p1)) 
                p3 (list (car p3) 
                  (cadr p1) 
                  (caddr p1))) 
              (quote ((1.0 0 0) 
                  (0 -1.0 0) 
                  (-1.0 0 0) 
                  (0 1.0 0))))) 
          (setq p1 (apply (quote mapcar) 
              (cons (quote min) 
                lst)) 
            p3 (apply (quote mapcar) 
              (cons (quote max) 
                lst))))) 
      (if (or (not offset) 
          (equal offset 0 0.0001)) 
        (list p1 p3) 
        (list (list:- p1 (list offset offset 0)) 
          (list:+ p3 (list offset offset 0))))))) 
 
 
 
(defun pickset:getbox (ss offset / ptlist) 
 
  (cond ((= (quote pickset) 
        (type ss)) 
      (setq ss (pickset:to-list ss))) 
    ((= (quote ename) 
        (type ss)) 
      (setq ss (list ss))) 
    ((p:vla-listp ss) 
      (setq ss (mapcar (quote o2e) 
          ss)))) 
  (if (p:ename-listp ss) 
    (progn (setq ptlist (apply (quote append) 
          (mapcar (quote (lambda (x) 
                (entity:getbox x offset))) 
            ss))) 
      (list (apply (quote mapcar) 
          (cons (quote min) 
            ptlist)) 
        (apply (quote mapcar) 
          (cons (quote max) 
            ptlist)))) 
    (progn (@:log "ERROR" 
        "parameter is NOT pickset") 
      nil))) 
 
(defun point:mid (pt1 pt2) 
    "求两点 pt1 pt2 的中点" 
    "中点坐标" 
    (mapcar (quote (lambda (x y) 
                (* 0.5 (+ x y)))) 
        pt1 pt2)) 
 
(defun entity:make-circle (pts-cen num-rad) 
  "创建圆.如果圆心是点的列表或半径是数值的列表，可以同时创建多个圆" 
  "Ename" 
  "(entity:make-circle (list (getpoint)(getpoint)) 
    '(3 5))" 
  (cond ((and (= (quote point) 
          (type-of pts-cen)) 
        (numberp num-rad)) 
      (entmakex (list (quote (0 . "circle")) 
          (quote (100 . "AcDbEntity")) 
          (quote (100 . "AcDbCircle")) 
          (cons 10 pts-cen) 
          (cons 40 num-rad)))) 
    ((and (listp pts-cen) 
        (apply (quote and) 
          (mapcar (function (lambda (x) 
                (= (quote point) 
                  (type-of x)))) 
            pts-cen))) 
      (foreach pt pts-cen (entity:make-circle pt num-rad))) 
    ((and (listp num-rad) 
        (apply (quote and) 
          (mapcar (quote numberp) 
            num-rad))) 
      (foreach rad num-rad (entity:make-circle pts-cen rad))))) 
 
(defun c:sscircle ( ) 
  "将选择的图形用圆圈住" 
  ;; 选择图形 
  (setq ss (ssget )) 
  ;; 获取图形的包围盒 
  (setq box (pickset:getbox ss 0)) 
  ;; 用包围盒的中心点与 中心点到角点为半径画圆 
  (entity:make-circle 
    (setq c (point:mid (car box)(cadr box))) 
    ((distance c (car box))) 
  ))

vitalgg · 发表于 2023-6-9 11:24:58

本帖最后由 vitalgg 于 2023-6-10 21:11 编辑

(defun c:sscircle ()
"将选择的图形用圆圈住"
;; 选择图形
(setq ss (ssget ))
;; 获取图形的包围盒
(setq box (pickset:getbox ss 0))
;; 用包围盒的中心点与中心点到角点为半径画圆
(entity:make-circle
(setq c (point:mid (car box)(cadr box)))
(distance c (car box))
))

meja · 发表于 2023-6-10 19:30:54

vitalgg 发表于 2023-6-9 11:24

非常感谢指点

vitalgg · 发表于 2023-6-10 21:11:37

meja 发表于 2023-6-10 19:58
无法运行

(distance c (car box))

这一句多了一层括号。

meja · 发表于 2023-6-16 08:36:50

还是运行不起来

664571221 · 发表于 2024-5-9 16:21:38

vitalgg 发表于 2023-6-10 21:11
(distance c (car box))

这一句多了一层括号。

可以帮帮他吗

账号		自动登录	找回密码
密码			注册

[讨论] 为任意物体添加圆圈，非常好的函数，可惜括号出问题了

本帖子中包含更多资源