大师能不能再出手改一下把标记出来的结果 用group编成组这样看完后方便删掉结果
;标示圆角
(defun c:bjyj(/ a dxf i len name pt pts r r1 ss tao-make-layer tao-make-line tao-make-text tao-make-textstyle test typ ureal xyp-subupd)
(DEFUN UREAL (BIT KWD MSG DEF / INP)
(if DEF
(PROGN (setq MSG (STRCAT "\n" MSG "<" (RTOS DEF 2) ">: "))
(setq BIT (* 2 (FIX (/ BIT 2))))
)
(PROGN (setq MSG (STRCAT "\n" MSG ": ")))
)
(INITGET BIT KWD)
(setq INP (GETREAL MSG))
(if INP
(PROGN INP)
(PROGN DEF)
)
)
(DEFUN DXF (CODE ENAME / ENT LST A)
(if (= (TYPE CODE) 'LIST)
(PROGN (setq ENT (ENTGET ENAME))
(setq LST nil)
(FOREACH A CODE
(setq LST (CONS (LIST A (CDR (ASSOC A ENT))) LST))
)
(REVERSE LST)
)
(PROGN (if (= CODE -3)
(PROGN (CDR (ASSOC CODE (ENTGET ENAME '("*")))))
(PROGN (CDR (ASSOC CODE (ENTGET ENAME))))
)
)
)
)
(DEFUN TAO-MAKE-TEXTSTYLE (STYNAME STY / A TEXTSTYLES TEXTSTYLE)
(setq A (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq TEXTSTYLES (vla-get-TextStyles A))
(setq TEXTSTYLE (vla-Add TEXTSTYLES STYNAME))
(vla-SetFont TEXTSTYLE STY :vlax-false :vlax-false 1 0)
(PRINC)
)
(DEFUN TAO-MAKE-LAYER (LNAME LCOLOR / LAYER LAYERS ADOC)
(setq ADOC (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq LAYERS (vla-get-Layers ADOC))
(setq LAYER (vla-Add LAYERS LNAME))
(vla-put-Color LAYER LCOLOR)
(vla-put-ActiveLayer ADOC LAYER)
(PRINC)
)
(DEFUN TAO-MAKE-LINE (PT1 PT2)
(ENTMAKE (LIST (CONS 0 "LINE")
(CONS 62 256)
(CONS 10 PT1)
(CONS 11 PT2)
)
)
)
(DEFUN TAO-MAKE-TEXT (PT STR JUS H STY)
(ENTMAKEX (LIST (CONS 0 "TEXT")
(CONS 100 "AcDbEntity")
(CONS 62 256)
(CONS 100 "AcDbText")
(if (= JUS 0)
(PROGN (CONS 10 PT))
(PROGN (LIST 10 0.0 0.0 0.0))
)
(CONS 40 H)
(CONS 1 STR)
(CONS 50 0)
(CONS 7 STY)
(CONS 72
(COND
((= JUS 0) 0)
((= JUS 1) 1)
((= JUS 2) 1)
((= JUS 3) 2)
)
)
(if (= JUS 0)
(PROGN (LIST 11 0.0 0.0 0.0))
(PROGN (CONS 11 PT))
)
(CONS 100 "AcDbText")
(CONS 73
(COND
((= JUS 0) 0)
((= JUS 1) 2)
((= JUS 2) 3)
((= JUS 3) 2)
)
)
)
)
)
(DEFUN XYP-SUBUPD (ENAME CODE VAL / ENT X Y I S1)
(COND
((= (TYPE ENAME) 'ENAME)
(setq ENT (ENTGET ENAME))
(if (AND (= (TYPE CODE) 'LIST) (= (TYPE VAL) 'LIST))
(PROGN
(MAPCAR '(LAMBDA (X Y) (XYP-SUBUPD ENAME X Y)) CODE VAL)
)
(PROGN
(if (= (DXF CODE ENAME) nil)
(PROGN (ENTMOD (APPEND ENT (LIST (CONS CODE VAL)))))
(PROGN (ENTMOD (SUBST (CONS CODE VAL) (ASSOC CODE ENT) ENT))
)
)
(ENTUPD ENAME)
)
)
)
((= (TYPE ENAME) 'PICKSET)
(setq I -1)
(while (and (setq S1 (SSNAME ENAME (setq I (1+ I)))))
(XYP-SUBUPD S1 CODE VAL)
)
)
((= (TYPE ENAME) 'LIST)
(FOREACH S1 ENAME (XYP-SUBUPD S1 CODE VAL))
)
)
ENAME
)
(defun ss-enlst (ss / enlst)
(cond
((= (type ss) 'PICKSET)
(vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
)
((= (type ss) 'LIST)
(setq enlst (ssadd))
(last (mapcar '(lambda (x) (ssadd x enlst)) ss))
)
)
)
(defun lm-make-group (Objlst)
(setq Objlst (mapcar 'vlax-ename->vla-object Objlst))
(vla-appenditems
(vla-add (vla-get-groups
(vla-get-activedocument (vlax-get-acad-object))
)
"*"
)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbobject
(cons 0 (1- (length objlst)))
)
objlst
)
)
)
)
(setq r(ureal 1 "" "临界圆角半径:" 0.2))
(if (setq ss(ssget '((0 . "*POLYLINE,REGION,ARC"))))
(progn
(setq i -1 pts'())
(repeat(sslength ss)
(setq
name(ssname ss(setq i(1+ i)))
typ(dxf 0 name)
r1(if(= typ "ARC")(dxf 40 name)nil)
)
(if (and r1(< r1 r)) (setq pts(cons (list(dxf 10 name)r1) pts)))
)
(if(setq ss(ssget "p"'((0 . "*POLYLINE,REGION"))))
(progn
(setq test T)
(command "_.undo" "be");;
(command
"QAFLAGS" 1 ;＝1，可以炸开选择集所有实体。这个变量不影响标准的EXPLODE命令的执行。
".EXPLODE" ss ""
) ;如果QAFLAGS＝0，那么用LISP执行 explode 的时候仅仅能炸开选择集的第一个实体，其他实体炸不了.n)
)
)
)
)
(if test
(progn
(if(setq ss (ssget"P"(list(cons 0 "ARC")(cons -4 "<")(cons 40 r))))
(progn
(setq i -1)
(repeat(sslength ss)
(setq
name(ssname ss(setq i(1+ i)))
pts(cons (list(dxf 10 name)(dxf 40 name)) pts)
)
)
)
)
(command "_.undo" "e")
(command ".undo" 1)
)
)
(setq len(length pts))
(if(> len 0)
(progn
(APPEND(list '("cmdecho" 0 "osmode" 0 "dimzin"8 "clayer" "0")0 nil))
(if(null(tblsearch "style" "宋体"))(tao-make-textstyle "宋体" "宋体"))
(tao-make-layer "F6" 6)
(setq ss(ssadd))
(foreach n pts
(setq pt(car n)r(cadr n))
(entmake (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (cons 62 4) (cons 10 pt) (cons 40 r)))
(setq ss (ssadd (entlast) ss))
(tao-make-text pt (rtos r 2) 1 r "宋体")
(setq ss (ssadd (entlast) ss))
)
(tao-make-text '(0 0 0) (strcat "检测到 " (itoa len) " 个小R") 1 (/ (getvar "viewsize") 45) "宋体")
(setq ss (ssadd (entlast) ss))
(setq a(entlast))
(while (= 5 (car (setq pt (grread t 4 0))))
(setq pt (trans(cadr pt)1 0))
(xyp-subupd a 40 (/ (getvar "viewsize") 45))
(xyp-subupd a 11 pt)
)
(lm-make-group (ss-enlst ss))
;(setvar"PICKSTYLE" 1)
)
)
(princ)
)
飞雪神光 发表于 2024-11-7 11:53
谢谢大师，很好用，现在方便多了
页:
1
[2]