★★★【增强框选圆角】★★★

lyy

;;也发一个全功能的框选圆角程序

;;对十字交叉的线可感知圆角方向

;;部分代码参考了网上的程序

(defun c:yad_fillet(/ yad-dxf yad-entsel yad-movetotop yad-interpt goto_fillet 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_fillet(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 "_.fillet" (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 "_.fillet" 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" 0)
  (setvar "cmdecho" 0)
  (setvar "errno" 0)
  (vl-cmdf "_.undo" "_c" "_n" "_.undo" "")
  (while (/= (getvar "errno") 52)
    (princ "\n当前设置：模式 = ")
    (princ (if (= (setq trm (getvar "trimmode")) 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_fillet (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_fillet 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_fillet p1 nil)
            (princ "\n圆角需要直线、圆弧、圆、椭圆、多段线或样条曲线！")
          )
          (vla-endundomark acaddoc)
        )
      )
    )
  )
  (setvar "peditaccept" oldpedit)
  (setvar "osmode" oldos)
  (princ)
)
(princ "\n框选圆角命令：yad_fillet")
(princ)

xj6019

好程序顶一下，楼主能改一下吗，框选的时候好不好实现预览功能啊，试用了一下，判断错误率太高了，除非点选可以，框选每次都很难把握规律，如果鼠标动就能暗线或者虚线显示裁剪下去的内容，到自己想要的位置的时候鼠标再点一下就确认，那样就会方便多了，现在的判断规律我试了很多回 也没发现啥规律。
楼主能看到回帖的话给弄一下吧，如果鼠标移动就能提前看到效果，就基本不错了。能看到，就再弄弄呗，毕竟太久的经典代码了

下文没句号。

有点不懂？命令是什么的？yad_fillet  是这个吗？那我自己可以改简单点吧。

87825877

感谢楼主，是不是只能选两条线？如果可以多选的话，更好用

caoyin

顶一下，不支持相交的spline嘛

lyy

caoyin发表于2008-12-17 12:41:00顶一下，不支持相交的spline嘛

漏了，已补上！

jxlsp

非常值得学习一下.

lyy

liminnet发表于2008-12-17 14:09:00还是不支持SPLINE呢，老大

不好意思，这回真的补上了！

wuxuloveguo

支持好东西!如LS所说多样线的倒角存在BUG!