请大师帮忙优化下-标记圆角

飞雪神光 · 发表于 2024-11-7 11:53:25

ninja37 发表于 2024-11-7 10:34
大师能不能再出手改一下把标记出来的结果用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)
)

;标示圆角 
(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) 
)

ninja37 · 发表于 2024-11-16 12:39:20

飞雪神光发表于 2024-11-7 11:53

谢谢大师，很好用，现在方便多了

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