为任意物体添加圆圈，非常好的函数，可惜括号出问题了
本帖最后由 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)
)
无法运行
(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-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))
))
vitalgg 发表于 2023-6-9 11:24
非常感谢指点:D- meja 发表于 2023-6-10 19:58
无法运行
(distance c (car box))
这一句多了一层括号。 还是运行不起来 vitalgg 发表于 2023-6-10 21:11
(distance c (car box))
这一句多了一层括号。
可以帮帮他吗
页:
[1]