求框选倒角程序~~

feng67333254

如图所示，图中的三角形的连接点是断开的，能否一次性框选倒角，论坛里我也找了，确实没有看到有这个。在此请大神们发LISP程序，本人小白，谢谢！！

wangshuping42

要定制可以联系我。
企鹅:41二802711

q3_2006

这个不太难....

feng67333254

可我不懂呀，也请大师给个解决文件呀~~~

coco08

我也跪求，我这个有时候失灵，希望可以互相交流
(defun c:C1(/ yad-dxf yad-entsel yad-movetotop yad-interpt goto_chamfer oldpedit oldos acaddoc mspace trm p1 p2 prom lprom r boxlen ss l_bak l_pt ent i)
  (defun yad-dxf(en val) (cdr (assoc val (entget en))))
  (defun yad-entsel(msg filter / ext ent pt s)
    (while (not ext)
      (setq ent (entsel msg))
      (cond
        ((= (getvar "errno") 52) (setq ext T) (setvar "errno" 0) nil)
        ((and ent (setq s (ssget "_c" (polar (setq pt (cadr ent)) (* pi 1.25) boxlen) (polar pt (/ pi 4) boxlen) filter)) (setq ext T)) (list (ssname s 0) pt))
        (T (prompt "\n圆角需要直线、圆弧、圆或多段线！"))
      )
    )
  )
  (defun yad-movetotop(l_ent / extdic tbl)
    (setq l_ent (mapcar 'vlax-ename->vla-object l_ent))
    (setq extdic (vla-getextensiondictionary mspace))
    (if (vl-catch-all-error-p (setq tbl (vl-catch-all-apply 'vla-item (list extdic "acad_sortents"))))
      (setq tbl (vla-addobject extdic "acad_sortents" "acdbsortentstable"))
    )
    (vlax-invoke tbl "MoveToTop" l_ent)
  )
  (defun yad-interpt(obj s / n ent ipt pt l_p)
    (setq obj (vlax-ename->vla-object obj) n -1)
    (repeat (sslength s)
      (setq ent (vlax-ename->vla-object (ssname s (setq n (1+ n)))) ipt (vlax-variant-value (vla-intersectwith obj ent 0)))
      (if (and (> (vlax-safearray-get-u-bound ipt 1) 0) (setq ipt (vlax-safearray->list ipt)))
        (while (> (length ipt) 0)
          (setq pt (list (car ipt) (cadr ipt) (caddr ipt)) ipt (cdddr ipt))
          (if (not (vl-member-if '(lambda(e) (equal e pt boxlen)) l_p)) (setq l_p (cons pt l_p)))
        )
      )
    )
    (vla-delete obj)
    l_p
  )
  (defun goto_chamfer(p1 p2 / ent1 ent2 wid ent2ispl s oldent newent)
    (setq ent1 (car p1))
    (if (not p2) (redraw ent1 3))
    (if (or p2 (setq p2 (yad-entsel "\n选择第二个对象：" '((0 . "LINE,XLINE,RAY,LWPOLYLINE,SPLINE,ARC,CIRCLE,ELLIPSE")))))
      (if (and (setq ent2 (car p2)) (member "LWPOLYLINE" (mapcar '(lambda(e) (yad-dxf e 0)) (list ent1 ent2))))
        (progn
          (redraw ent1 4)
          (if (= (yad-dxf ent2 0) "LWPOLYLINE")
            (setq ent1 p2 p2 (cadr p1) ent2 (car p1) p1 (cadr ent1) ent1 (car ent1))
            (setq p1 (cadr p1) p2 (cadr p2))
          )
          (setq wid (yad-dxf ent1 40) ent2ispl (= (yad-dxf ent2 0) "LWPOLYLINE"))
          (if (= trm 0)
            (progn
              (vla-copy (vlax-ename->vla-object ent1))
              (if (and ent2ispl (not (equal ent1 ent2))) (vla-copy (vlax-ename->vla-object ent2)))
              (yad-movetotop (if (equal ent1 ent2) (list ent1) (list ent1 ent2)))
            )
            (vl-cmdf "_.undo" "_m")
          )
          (setvar "qaflags" 1)
          (if ent2ispl (vl-cmdf "_.explode" ent1 ent2 "") (vl-cmdf "_.explode" ent1 ""))
          (setq s (ssget "_p") oldent (entlast))
          (setvar "qaflags" 0)
          (vl-catch-all-apply 'vl-cmdf (list "_.chamfer" (setq ent1 (nentselp p1)) (setq ent2 (nentselp p2))))
          (cond
            ((= trm 0))
            ((and (equal (setq newent (entlast)) oldent) (/= (getvar "filletrad") 0)) (vl-cmdf "_.undo" "_b"))
            (T (vl-catch-all-apply 'vl-cmdf (append (list "_.pedit" (car ent1) "_j")
                                                    (if (equal newent oldent) nil (list newent))
                                                    (if (= (yad-dxf (setq ent2 (car ent2)) 0) "CIRCLE") nil (list ent2))
                                                    (list s "" "_w" wid "")))
            )
          )
          (vl-cmdf "_.erase" s "")
        )
        (vl-catch-all-apply 'vl-cmdf (list "_.chamfer" p1 p2))
      )
      (redraw ent1 4)
    )
  )
  (vl-load-com)
  (setq oldpedit (getvar "peditaccept") oldos (getvar "osmode")
        mspace (vla-get-modelspace (setq acaddoc (vla-get-activedocument (vlax-get-acad-object))))
  )
  (setvar "peditaccept" 1)
  (setvar "osmode" 16383)
  (setvar "cmdecho" 0)
  (setvar "errno" 0)
  (vl-cmdf "_.undo" "_c" "_n" "_.undo" "")
  (while (/= (getvar "errno") 52)
    (princ "\n当前设置：模式 = ")
    (princ (if (= (setq trm (getvar "chammode")) 1) "修剪" "不修剪"))
    (princ "，倒角距离 = ")
    (princ (getvar "filletrad"))
    (initget (if (= trm 1) "U N" "U T"))
    (setq p1 (entsel (strcat "\n" (setq prom (strcat "选择对象或指定倒角距离或[放弃(U)/" (if (= trm 1) "不修剪对象(N)" "修剪对象(T)")"]：")))))
    (princ "\n请选择框选范围")
    (setq lprom (getvar "lastprompt") r (substr lprom (1+ (vl-string-mismatch prom lprom)))
          boxlen (abs (/ (* (/ (getvar "pickbox") (cadr (getvar "screensize"))) (getvar "viewsize")) (sin (/ pi 4))))
    )
    (if (numberp (setq r (read r)))
      (setvar "filletrad" (abs r))
      (cond
        ((= p1 "U") (vl-cmdf "_.u"))
        ((= p1 "T") (setvar "trimmode" 1))
        ((= p1 "N") (setvar "trimmode" 0))
        ((and (not p1) (/= (getvar "errno") 52) (setq p2 (getcorner (setq p1 (cadr (grread T 6 2))) "\n指定对角点：")))
          (vla-startundomark acaddoc)
          (setq ss nil l_bak nil l_pt nil)
          (cond
            ((and (setq ss (ssget "_f" (list p1 p2) '((0 . "LINE,XLINE,RAY,LWPOLYLINE,SPLINE,ARC,CIRCLE,ELLIPSE"))))
                  (vla-addline mspace (vlax-3d-point p1) (vlax-3d-point p2))
                  (setq l_bak (list ss (setq l_pt (yad-interpt (entlast) ss))))
                  (> (sslength ss) 1) (> (length l_pt) 1)
             )
            )
            ((and (setq ss (ssget "_f" (list p1 (list (car p1) (cadr p2)) p2 (list (car p2) (cadr p1)) p1) '((0 . "LINE,XLINE,RAY,LWPOLYLINE,SPLINE,ARC,CIRCLE,ELLIPSE"))))
                  (vl-cmdf "_.rectang" "_f" 0 p1 p2)
                  (setq l_pt (yad-interpt (entlast) ss))
             )
            )
          )
          (if (and l_bak (or (< (length l_pt) 2) (and (= (sslength ss) 1) (> (length (cadr l_bak)) 1)))) (setq ss (car l_bak) l_pt (cadr l_bak)))
          (cond
            ((not ss)
              (princ "\n没有交叉框选到直线、圆弧、圆、椭圆、多段线或样条曲线！")
            )
            ((or (= (sslength ss) 1) (= (length l_pt) 1))
              (goto_chamfer (list (setq ent (ssname ss 0)) (car l_pt)) (if (and (= (yad-dxf ent 0) "LWPOLYLINE") (> (length l_pt) 1)) (list ent (cadr l_pt)) nil))
            )
            (T
              (setq p1 (nentselp (car l_pt)) l_pt (cdr l_pt) i -1)
              (while (and (setq p2 (nth (setq i (1+ i)) l_pt)) (setq p2 (nentselp p2)) (equal (car p2) (car p1))))
              (goto_chamfer p1 p2)
            )
          )
          (vla-endundomark acaddoc)
        )
        ((and p1 (= (type (setq ent (car p1))) 'ename))
          (vla-startundomark acaddoc)
          (if (wcmatch (yad-dxf ent 0) "LINE,XLINE,RAY,LWPOLYLINE,SPLINE,ARC,CIRCLE,ELLIPSE")
            (goto_chamfer p1 nil)
            (princ "\n圆角需要直线、圆弧、圆、椭圆、多段线或样条曲线！")
          )
          (vla-endundomark acaddoc)
        )
      )
    )
  )
  (setvar "peditaccept" oldpedit)
  (setvar "osmode" oldos)
  (princ)
)
(princ "\n框选倒角命令：yad_chamfer")
(princ)