带grread捕捉绘制螺纹孔程序
本帖最后由 langjs 于 2022-2-14 13:03 编辑有很多人觉得 grread加捕捉挺难，以前研究过大神的程序，自己整了个grread带捕捉的子函数，感觉挺好用，需要grread带捕捉功能直接调用子函数。下面是我最新编的画螺纹孔程序用到了，发出来仅供参考。
;;; ===================================================
;;; 功能：螺纹孔程序
;;; 作者：langjs 命令:lwk 日期:2022年02月14日
;;; ===================================================
(defun c:lwk (/ #err $orr bl code color d dbl dd ent ent1 ent2 ent3 ent4 gr h i k loop lst n name1 name2 name3 name4 nearpt
nearpt2 old_lay osmo p pt pt1 pt2 pt3 pt4 pt5 ptx pty ss x
)
(defun osnappt (ss pt / color d h i k lst nearpt nearpt2 osmo pt1 pt2 pt3 pt4 pt5 ptx pty x) ; grread捕捉子函数
(if (= (type ss) 'ename)
(entdel ss)
)
(if (= (type ss) 'pickset)
(repeat (setq i (sslength ss))
(entdel (ssname ss (setq i (1- i))))
)
)
(redraw)
(if (< (getvar "osmode") 16384)
(progn
(setq color (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences (vlax-get-acad-object))))
h (/ (getvar "viewsize") (cadr (getvar "screensize")))
d (getvar "pickbox")
lst (list (* d h) (* (- d 0.5) h) (* (+ d 0.5) h))
k (* 1.5 d h)
)
(if (setq nearpt (osnap pt "_END,_CEN,_NOD,_QUA,_INS,_TAN,_EXT"))
(setq osmo 1)
)
(if (and
(setq nearpt2 (osnap pt "_NEA"))
(not (equal nearpt nearpt2 k))
)
(setq osmo 2
nearpt nearpt2
)
)
(if (and
(setq nearpt2 (osnap pt "_MID"))
(equal nearpt nearpt2 k)
)
(setq osmo 3
nearpt nearpt2
)
)
(if (and
(setq nearpt2 (osnap pt "_INT"))
(equal nearpt nearpt2 k)
)
(setq osmo 4
nearpt nearpt2
)
)
)
)
(if (= (type ss) 'ename)
(entdel ss)
)
(if (= (type ss) 'pickset)
(repeat (setq i (sslength ss))
(entdel (ssname ss (setq i (1- i))))
)
)
(if nearpt
(progn
(setq ptx (car nearpt)
pty (cadr nearpt)
)
(foreach x lst
(setq pt1 (list (- ptx x) (- pty x))
pt2 (list (+ ptx x) (- pty x))
pt3 (list (+ ptx x) (+ pty x))
pt4 (list (- ptx x) (+ pty x))
pt5 (list ptx (+ pty x))
)
(cond
((= osmo 1) ; 正方形
(grvecs (list color pt1 pt2 pt2 pt3 pt3 pt4 pt4 pt1))
)
((= osmo 2) ; 俩三角
(grvecs (list color pt1 pt2 pt2 pt4 pt3 pt4 pt3 pt1))
)
((= osmo 3) ; 三角
(grvecs (list color pt1 pt2 pt2 pt5 pt5 pt1))
)
((= osmo 4) ; 交叉
(grvecs (list color pt1 pt3 color pt2 pt4))
)
)
)
(setq pt nearpt)
)
)
pt
)
(defun emod (ent i n) ; 更新图元函数
(subst
(cons i n)
(assoc i ent)
ent
)
)
(defun #err (s / i) ; 出错处理子函数
(redraw)
(if ss
(repeat (setq i (sslength ss))
(entdel (ssname ss (setq i (1- i))))
)
)
(command ".UNDO" "E")
(setq *error* $orr)
)
(setq $orr *error*)
(setq *error* #err)
(setvar "cmdecho" 0)
(command ".UNDO" "BE")
(setq old_lay (getvar "clayer"))
(if (not (tblsearch "layer" "02细实线层"))
(vl-cmdf "_layer" "make" "02细实线层" "Color" 3 "" "L" "Continuous" "" "")
)
(if (not (tblsearch "layer" "03中心线层"))
(vl-cmdf "_layer" "make" "03中心线层" "Color" 5 "" "L" "CENTER" "" "")
)
(setvar "clayer" old_lay)
(if (null d)
(setq d (getreal "\n螺纹孔尺寸M："))
)
(princ (strcat "\n螺纹孔尺寸：<M" (rtos d 2 2) ">"))
(setq lst (list '(1.2 0.25) '(1.4 0.3) '(1.8 0.35) '(2 0.4) '(2.5 0.45) '(3 0.5) '(3.5 0.6) '(4 0.7) '(4.5 0.75) '
(5.5 0.8) '(6 1) '(9 1.25) '(11 1.5) '(12 1.75) '(16 2) '(22 2.5) '(27 3) '(33 3.5) '(39 4) '(45 4.5) '
(52 5) '(60 5.5) '(149 6) '(1000000 8)
)
)
(foreach x lst
(if (and
(null p)
(<= d (car x))
)
(setq p (cadr x))
)
)
(if (<= d 1.2)
(setq p (* 0.2 d))
)
(setq dbl (getvar "DIMSCALE"))
(if (< d (* 3 dbl))
(setq dd d)
(setq dd (+ (* 0.5 d) (* 3 dbl)))
)
(if (< (setq n (* 2 dd))
(* 2 dbl)
)
(setq bl (/ n (cdr (assoc 40 (tblsearch "ltype" "CENTER"))) (getvar "LTSCALE")))
(setq bl (/ (* 2 dbl) (cdr (assoc 40 (tblsearch "ltype" "CENTER"))) (getvar "LTSCALE")))
)
(setq ss (ssadd))
(entmake (list '(0 . "LINE") (cons 8 "03中心线层") (cons 48 bl) (cons 10 '(0.0 0.0)) (cons 11 '(0.0 0.0))))
(setq name1 (entlast)
ent1 (entget name1)
ss (ssadd)
ss (ssadd name1 ss)
)
(entmake (list '(0 . "LINE") (cons 8 "03中心线层") (cons 48 bl) (cons 10 '(0.0 0.0)) (cons 11 '(0.0 0.0))))
(setq name2 (entlast)
ss (ssadd name2 ss)
ent2 (entget name2)
)
(entmake (list '(0 . "ARC") (cons 8 "02细实线层") (cons 10 '(0.0 0.0)) (cons 40 (* 0.5 d)) (cons 50 (* 1.5 pi))
(cons 51 pi)
)
)
(setq name3 (entlast)
ent3 (entget name3)
ss (ssadd name3 ss)
)
(entmake (list '(0 . "CIRCLE") (cons 10 '(0.0 0.0)) (cons 40 (* 0.5 (- d p)))))
(setq name4 (entlast)
ent4 (entget name4)
ss (ssadd name4 ss)
)
(setq loop t)
(while loop
(setq gr (grread t 15 1)
code (car gr)
pt (cadr gr)
)
(cond
((= code 5) ; 鼠标移动
(redraw)
(setq pt (osnappt ss pt)) ; 取得grread捕捉点
(setq ent1 (emod ent1 10 (polar pt 0.0 dd)))
(entmod (emod ent1 11 (polar pt pi dd)))
(setq ent2 (emod ent2 10 (polar pt (* 0.5 pi) dd)))
(entmod (emod ent2 11 (polar pt (* -0.5 pi) dd)))
(entmod (emod ent3 10 pt))
(entmod (emod ent4 10 pt))
)
((= code 3) ; 鼠标左键
(redraw)
(setq pt (osnappt ss pt))
(entmake (list '(0 . "LINE") (cons 8 "03中心线层") (cons 48 bl) (cons 10 (polar pt 0.0 dd)) (cons 11 (polar pt pi dd))))
(entmake (list '(0 . "LINE") (cons 8 "03中心线层") (cons 48 bl) (cons 10 (polar pt (* 0.5 pi) dd)) (cons 11
(polar pt
(* -0.5
pi
) dd
)
)
)
)
(entmake (list '(0 . "ARC") (cons 8 "02细实线层") (cons 10 pt) (cons 40 (* 0.5 d)) (cons 50 (* 1.5 pi)) (cons 51 pi)))
(entmake (list '(0 . "CIRCLE") (cons 10 pt) (cons 40 (* 0.5 (- d p)))))
)
((member code '(11 25)) ; 鼠标右击
(redraw)
(setq loop nil)
(repeat (setq i (sslength ss))
(entdel (ssname ss (setq i (1- i))))
)
)
)
)
(setq *error* $orr)
(command ".UNDO" "E")
(princ)
)
感谢分享，牛牛牛 ((= code 3)(setq loop nil) )这样就行了不需要再生成，然后删除原来的。速度还会更快 命令: LWK
螺纹孔尺寸 M：30
螺纹孔尺寸：<M30>参数太少
这是怎么回事 谢谢! langjs 分享程序!!! 谢谢! langjs 分享程序!!! 学习一下grread函数！ 刚测试 捕捉不到端点 感谢分享精神 我对 grread 命令没有什么认识，需要好好学习。
请问lang大师，图中元素数量比较多的时候，捕捉子程序的速度怎么样啊？ 捕捉端点会跑偏
页:
[1]
2