grread下的扑捉问题（已支持象限扑捉）
本帖最后由 尘缘一生 于 2024-7-1 09:57 编辑新开一贴，对于这个问题，希望在本帖要解决了它，
什么问题呢？那就是，grread下支持扑捉象限点，这个问题
请大家移步先看技术帖子，再来进一步的研究...
顾版的
http://bbs.mjtd.com/forum.php?mo ... 91&highlight=grread
廊大师的
http://bbs.mjtd.com/forum.php?mo ... 90&highlight=grread
下面代码，是我今上午改写的，尝试一下，还不完美，
;;grread图元捕捉子函数-----(一级)------有缺憾，会闪烁
;;name为移动的图元、选择集，pt为光标点
;;有捕捉点则返回捕捉点，无返回光标点
(defun slosnappt (name pt / cl osmo d h k lst nearpt p0 p00 p1 p2 p3 p4 p5 ptx pty x newe)
(redraw)
(if (< (getvar "OSMODE") 16384) ;;打开捕捉
(progn
(cond
((= (type name) 'ENAME) (entdel name)) ;图元先删除
((= (type name) 'PICKSET) ;选择集
(sl-sel-redrawsel name 2) ;先隐藏
)
)
(setq
p1 nil p2 nil
cl (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences *Acad*)))
h (p2uu 1.0) d (getvar "PICKBOX")
lst (list (* d h) (* (- d 0.5) h) (* (+ d 0.5) h)) k (* 30.0 d h)
p1 (cadr (grread 5))
)
;下面三行，此时如果扑捉到实体，取得它中心p2
(if (setq newe (car (nentselp pt)))
(setq p2 (e-mid newe))
)
;;这是第一步，取得扑捉点
(if (setq p0 (osnap pt "_NEA,_MID,_END,_INT,_CEN,_NOD,_QUA,_INS,_PER,_TAN,_APP,_EXT,_PAR"))
(setq osmo 1 nearpt p0)
)
;;如果是NEA只不过是判定osmo罢了吗？值得进行下去if，如果能模拟到和CAD一样丝滑，建议osmo仅仅一个好了，那就是osmo=1 ,画个矩形
(if (and (setq p0 (osnap pt "_NEA")) (equal nearpt p0 k))
(setq osmo 2 nearpt p0)
)
(if (and (setq p0 (osnap pt "_MID")) (equal nearpt p0 k))
(setq osmo 3 nearpt p0)
)
(if (and (setq p0 (osnap pt "_INT")) (equal nearpt p0 k))
(setq osmo 4 nearpt p0)
)
;;下面三句吗，我尝试给于象限点p2，并设为OSMO=4，画交叉矢量线，可以是可以，但是操作不如CAD本身丝滑
(if (and p2 nearpt (not (equal nearpt p2 k)))
(setq osmo 4 nearpt p2)
)
(cond
((= (type name) 'ENAME) (entdel name)) ;图元恢复
((= (type name) 'PICKSET) ;选择集
(sl-sel-redrawsel name 1) ;恢复显示
)
)
(if nearpt
(progn
(setq ptx (car nearpt) pty (cadr nearpt))
(while lst
(setq x (car lst) p1 (list (- ptx x) (- pty x)) p2 (list (+ ptx x) (- pty x))
p3 (list (+ ptx x) (+ pty x)) p4 (list (- ptx x) (+ pty x))
p5 (list ptx (+ pty x))
)
(cond
((= osmo 1) (grvecs (list cl p1 p2 p2 p3 p3 p4 p4 p1))) ;正方形
((= osmo 2) (grvecs (list cl p1 p2 p2 p4 p3 p4 p3 p1))) ;俩三角
((= osmo 3) (grvecs (list cl p1 p2 p2 p5 p5 p1))) ;三角
((= osmo 4) (grvecs (list cl p1 p3 cl p2 p4)));交叉
)
(setq lst (cdr lst))
)
(setq pt nearpt)
)
)
)
)
pt
)下面为了大家能更好的解决这个问题，贴上另一种优秀代码，还没来得及尝试扑捉象限点的改写
;;重画选择集中的对象-----(一级)-----
;;Sel为选择集或图元名; mode为方式码
;;mode 1 在屏幕重画该选择集对象
;;mode 2 隐藏该选择集对象
;;mode 3 <醒目显示> 该选择集对象
;;mode 4 取消<醒目显示>该选择集对象
(defun sl-sel-redrawsel (sel mode / n)
(if sel
(cond
((= 'PICKSET (type sel))
(repeat (setq n (sslength sel))
(redraw (ssname sel (setq n (1- n))) mode)
)
)
((= 'ENAME (type sel))
(redraw sel mode)
)
)
)
t
)
;;grread图元捕捉子函数-----(一级)------
;;name为移动的图元、选择集,pt为光标点
;;有捕捉点则返回捕捉点,无返回光标点
(defun slosnappt (name pt / p mode osmod osmode size k)
(defun sldectobin (n m / c f) ;;十进制转二进制
(setq f (if (< n 0) 1 0) n (abs n))
(while (> (setq c (cons (rem n 2) c) n (* n 0.5)) 0))
(while (< (length c) (1- m)) (setq c (cons 0 c)))
(cons f c)
)
;;------------------
(defun sldrawvecs (pt vecs size cl / xdir)
(setq xdir (getvar 'ucsxdir)
vecs (mapcar '(lambda (x) (mapcar '(lambda (a) (mapcar '+ pt (mapcar '* (setq a (trans a 0 xdir) a (list (caddr a) (car a))) (list size size)))) x)) vecs)
)
(grvecs (apply 'append (mapcar 'cons (mapcar (function (lambda (x) cl)) vecs) vecs)))
)
;;----------------
(if (< (getvar "OSMODE") 16384) ;;打开捕捉
(progn
(if name (progn (sl-sel-redrawsel name 2) (setq k t))) ;隐藏
(if (setq
osmod '("_NEA," "_QUA," "_END," "_MID," "_CEN," "_NOD," "_INT," "_INS," "_PER," "_TAN," "_APP," "_EXT," "_PAR")
osmode (reverse (sldectobin (getvar 'osmode) 1))
size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX"))
p (osnap pt (apply 'strcat (mapcar '(lambda (x y) (if (zerop x) "" y)) osmode osmod)))
mode (cdr (assoc (if p
(vl-some '(lambda (x) (if (equal p (cdr x) 1e-8) (car x)))
(vl-remove 'nil (mapcar '(lambda (x y / p) (if (zerop x) nil (if (setq p (osnap pt y)) (cons y p)))) osmode osmod)))
)
'(("_END," ((-1 1)(-1 -1))((-1 -1)(1 -1))((1 -1) (1 1))((1 1) (-1 1)))
("_MID," ((0 1.414) (-1.225 -0.707)) ((-1.225 -0.707)(1.225 -0.707))((1.225 -0.707) (0 1.414)))
("_CEN," ((0 1) (-0.707 0.707))((-0.707 0.707)(-1 0))((-1 0) (-0.707 -0.707))((-0.707 -0.707)(0 -1))
((0 -1)(0.707 -0.707))((0.707 -0.707)(1 0)) ((1 0) (0.707 0.707))((0.707 0.707) (0 1)))
("_NOD," ((0 1) (-0.707 0.707))((-0.707 0.707)(-1 0))((-1 0)(-0.707 -0.707))((-0.707 -0.707)(0 -1))((0 -1)(0.707 -0.707))
((0.707 -0.707)(1 0))((1 0)(0.707 0.707))((0.707 0.707)(0 1))((-1 1)(1 -1))((-1 -1)(1 1)))
("_QUA," ((0 1.414)(-1.414 0))((-1.414 0)(0 -1.414))((0 -1.414)(1.414 0))((1.414 0)(0 1.414)))
("_INT," ((-1 1)(1 -1))((-1 -1)(1 1))((1 0.859)(-0.859 -1))((-1 0.859)(0.859 -1))((0.859 1)(-1 -0.859))((-0.859 1)(1 -0.859)))
("_INS," ((-1 1)(-1 -0.1))((-1 -0.1)(0 -0.1))((0 -0.1)(0 -1.0))((0 -1.0)(1 -1))
((1 -1)(1 0.1))((1 0.1)(0 0.1))((0 0.1) (0 1.0))((0 1.0)(-1 1)))
("_PER," ((-1 1)(-1 -1))((-1 -1)(1 -1))((0 -1)(0 0))((0 0)(-1 0)))
("_TAN," ((0 1)(-0.707 0.707))((-0.707 0.707)(-1 0))((-1 0)(-0.707 -0.707))((-0.707 -0.707)(0 -1))
((0 -1)(0.707 -0.707))((0.707 -0.707)(1 0))((1 0)(0.707 0.707))((0.707 0.707)(0 1))((1 1)(-1 1)))
("_NEA," ((-1 1)(1 -1))((1 -1)(-1 -1))((-1 -1)(1 1))((1 1)(-1 1)))
("_APP," ((-1 1)(-1 -1))((-1 -1)(1 -1))((1 -1)(1 1))((1 1)(-1 1))((-1 1)(1 -1))((-1 -1)(1 1)))
("_EXT," ((0.1 0)(0.13 0))((0.2 0)(0.23 0))((0.3 0)(0.33 0)))
("_PAR" ((0 1)(-1 -1))((1 1)(0 -1)))
)
)
)
)
(sldrawvecs (setq p (if p p pt)) mode size (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences *Acad*))))
)
(if k (sl-sel-redrawsel name 1)) ;恢复显示
)
)
(if p p pt)
)
本帖最后由 尘缘一生 于 2024-7-23 13:26 编辑
最终结果
;;grread图元捕捉函数-----(一级)------
;;name为移动的图元、选择集,pt为光标点
;;有捕捉点则返回捕捉点,无返回光标点
(defun sl-osnappt (pt / p mode osmod osmode size cl)
(defun sldectobin (n m / c f) ;;十进制转二进制
(setq f (if (< n 0) 1 0) n (abs n))
(while (> (setq c (cons (rem n 2) c) n (* n 0.5)) 0))
(while (< (length c) (1- m)) (setq c (cons 0 c)))
(cons f c)
)
;;------------------
(defun sldrawvecs (pt vecs size cl / xdir)
(setq xdir (getvar 'ucsxdir)
vecs (mapcar '(lambda (x) (mapcar '(lambda (a) (mapcar '+ pt (mapcar '* (setq a (trans a 0 xdir) a (list (caddr a) (car a))) (list size size)))) x)) vecs)
)
(grvecs (apply 'append (mapcar 'cons (mapcar (function (lambda (x) cl)) vecs) vecs)))
)
;;------------------
(if (setq
size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX"))
cl (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences *Acad*)))
osmod '("_NEA," "_QUA," "_END," "_MID," "_CEN," "_NOD," "_INT," "_INS," "_PER," "_TAN," "_APP," "_EXT," "_PAR")
osmode (reverse (sldectobin (getvar 'osmode) 1))
p (osnap pt (apply 'strcat (mapcar '(lambda (x y) (if (zerop x) "" y)) osmode osmod)))
mode (cdr (assoc (if p
(vl-some '(lambda (x) (if (equal p (cdr x) 1e-8) (car x)))
(vl-remove 'nil (mapcar '(lambda (x y / p) (if (zerop x) nil (if (setq p (osnap pt y)) (cons y p)))) osmode osmod)))
)
'(("_END," ((-1 1)(-1 -1))((-1 -1)(1 -1))((1 -1) (1 1))((1 1) (-1 1)))
("_MID," ((0 1.414) (-1.225 -0.707)) ((-1.225 -0.707)(1.225 -0.707))((1.225 -0.707) (0 1.414)))
("_CEN," ((0 1) (-0.707 0.707))((-0.707 0.707)(-1 0))((-1 0) (-0.707 -0.707))((-0.707 -0.707)(0 -1))
((0 -1)(0.707 -0.707))((0.707 -0.707)(1 0)) ((1 0) (0.707 0.707))((0.707 0.707) (0 1)))
("_NOD," ((0 1) (-0.707 0.707))((-0.707 0.707)(-1 0))((-1 0)(-0.707 -0.707))((-0.707 -0.707)(0 -1))((0 -1)(0.707 -0.707))
((0.707 -0.707)(1 0))((1 0)(0.707 0.707))((0.707 0.707)(0 1))((-1 1)(1 -1))((-1 -1)(1 1)))
("_QUA," ((0 1.414)(-1.414 0))((-1.414 0)(0 -1.414))((0 -1.414)(1.414 0))((1.414 0)(0 1.414)))
("_INT," ((-1 1)(1 -1))((-1 -1)(1 1))((1 0.859)(-0.859 -1))((-1 0.859)(0.859 -1))((0.859 1)(-1 -0.859))((-0.859 1)(1 -0.859))) ;X
("_INS," ((-1 1)(-1 -0.1))((-1 -0.1)(0 -0.1))((0 -0.1)(0 -1.0))((0 -1.0)(1 -1))
((1 -1)(1 0.1))((1 0.1)(0 0.1))((0 0.1) (0 1.0))((0 1.0)(-1 1))) ;双方形
("_PER," ((-1 1)(-1 -1))((-1 -1)(1 -1))((0 -1)(0 0))((0 0)(-1 0)))
("_TAN," ((0 1)(-0.707 0.707))((-0.707 0.707)(-1 0))((-1 0)(-0.707 -0.707))((-0.707 -0.707)(0 -1))
((0 -1)(0.707 -0.707))((0.707 -0.707)(1 0))((1 0)(0.707 0.707))((0.707 0.707)(0 1))((1 1)(-1 1)))
("_NEA," ((-1 1)(1 -1))((1 -1)(-1 -1))((-1 -1)(1 1))((1 1)(-1 1)))
("_APP," ((-1 1)(-1 -1))((-1 -1)(1 -1))((1 -1)(1 1))((1 1)(-1 1))((-1 1)(1 -1))((-1 -1)(1 1)))
("_EXT," ((0.1 0)(0.13 0))((0.2 0)(0.23 0))((0.3 0)(0.33 0)))
("_PAR" ((0 1)(-1 -1))((1 1)(0 -1)))
)
)
)
)
(sldrawvecs (setq p (if p p pt)) mode size cl)
)
(if p p pt)
)
;;grread图元捕捉子函数-----(一级)------
;;name为移动的图元、选择集,pt为光标点
;;有捕捉点则返回捕捉点,无返回光标点
(defun slosnappt (name pt / p0 p1 p2 newe ss size k cl d)
(setq d (getvar "OSMODE"))
(if (and (< d 16384) (> d 0));;打开捕捉
(progn
(if name (progn (setq k t)(sl-sel-redrawsel name 2))) ;隐藏
(setq size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX")))
(if (setq ss (ssget "C" (polar pt 5pi4 size) (polar pt pi4 size)))
(progn
(setq newe (ssname ss 0)
p0 (e9pt newe 5)
ss (ssget "C" (polar p0 5pi4 size) (polar p0 pi4 size))
)
(if (and (or (null ss) (and ss (< (sslength ss) 2))) (> (distance p0 pt) (* 10.0 size)))
(progn
(if ss
(setq cl (abs (- 250 (sl-getcolor (ssname ss 0)))))
(setq cl (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences *Acad*))))
)
(setq p1 (polar p0 pi size) p2 (polar p0 0 size))
(entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "f-i-n-d") (cons 62 cl)))
(setq p1 (polar p0 pi2 size) p2 (polar p0 3pi2 size))
(entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "f-i-n-d") (cons 62 cl)))
)
)
)
)
(setq pt (sl-osnappt pt))
(if k (sl-sel-redrawsel name 1)) ;恢复显示
)
)
pt
) 函数看字眼就知道是个啥，自理去即可，我发的是“理念”，就是问题是个啥子，不是代码本身，代码本身没什么意思，会写的很多。这个问题，也是有人问我要这个支持，才发现的，就是扑捉时候，要能扑捉到中心支持，要扑捉这个实体的中心定位，扩展这一功能。
如果前面支持，那好，恭喜了，用即可。我得帖子，记住了，不是给外行看的。
为支持象限扑捉的改写，可以用了
;;grread图元捕捉子函数-----(一级)------
;;name为移动的图元、选择集,pt为光标点
;;有捕捉点则返回捕捉点,无返回光标点
(defun sl-osnappt (pt / p mode osmod osmode size cl)
(defun sldectobin (n m / c f) ;;十进制转二进制
(setq f (if (< n 0) 1 0) n (abs n))
(while (> (setq c (cons (rem n 2) c) n (* n 0.5)) 0))
(while (< (length c) (1- m)) (setq c (cons 0 c)))
(cons f c)
)
;;------------------
(defun sldrawvecs (pt vecs size cl / xdir)
(setq xdir (getvar 'ucsxdir)
vecs (mapcar '(lambda (x) (mapcar '(lambda (a) (mapcar '+ pt (mapcar '* (setq a (trans a 0 xdir) a (list (caddr a) (car a))) (list size size)))) x)) vecs)
)
(grvecs (apply 'append (mapcar 'cons (mapcar (function (lambda (x) cl)) vecs) vecs)))
)
;;------------------
(if (setq
size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX"))
cl (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences *Acad*)))
osmod '("_NEA," "_QUA," "_END," "_MID," "_CEN," "_NOD," "_INT," "_INS," "_PER," "_TAN," "_APP," "_EXT," "_PAR")
osmode (reverse (sldectobin (getvar 'osmode) 1))
p (osnap pt (apply 'strcat (mapcar '(lambda (x y) (if (zerop x) "" y)) osmode osmod)))
mode (cdr (assoc (if p
(vl-some '(lambda (x) (if (equal p (cdr x) 1e-8) (car x)))
(vl-remove 'nil (mapcar '(lambda (x y / p) (if (zerop x) nil (if (setq p (osnap pt y)) (cons y p)))) osmode osmod)))
)
'(("_END," ((-1 1)(-1 -1))((-1 -1)(1 -1))((1 -1) (1 1))((1 1) (-1 1)))
("_MID," ((0 1.414) (-1.225 -0.707)) ((-1.225 -0.707)(1.225 -0.707))((1.225 -0.707) (0 1.414)))
("_CEN," ((0 1) (-0.707 0.707))((-0.707 0.707)(-1 0))((-1 0) (-0.707 -0.707))((-0.707 -0.707)(0 -1))
((0 -1)(0.707 -0.707))((0.707 -0.707)(1 0)) ((1 0) (0.707 0.707))((0.707 0.707) (0 1)))
("_NOD," ((0 1) (-0.707 0.707))((-0.707 0.707)(-1 0))((-1 0)(-0.707 -0.707))((-0.707 -0.707)(0 -1))((0 -1)(0.707 -0.707))
((0.707 -0.707)(1 0))((1 0)(0.707 0.707))((0.707 0.707)(0 1))((-1 1)(1 -1))((-1 -1)(1 1)))
("_QUA," ((0 1.414)(-1.414 0))((-1.414 0)(0 -1.414))((0 -1.414)(1.414 0))((1.414 0)(0 1.414)))
("_INT," ((-1 1)(1 -1))((-1 -1)(1 1))((1 0.859)(-0.859 -1))((-1 0.859)(0.859 -1))((0.859 1)(-1 -0.859))((-0.859 1)(1 -0.859))) ;X
("_INS," ((-1 1)(-1 -0.1))((-1 -0.1)(0 -0.1))((0 -0.1)(0 -1.0))((0 -1.0)(1 -1))
((1 -1)(1 0.1))((1 0.1)(0 0.1))((0 0.1) (0 1.0))((0 1.0)(-1 1))) ;双方形
("_PER," ((-1 1)(-1 -1))((-1 -1)(1 -1))((0 -1)(0 0))((0 0)(-1 0)))
("_TAN," ((0 1)(-0.707 0.707))((-0.707 0.707)(-1 0))((-1 0)(-0.707 -0.707))((-0.707 -0.707)(0 -1))
((0 -1)(0.707 -0.707))((0.707 -0.707)(1 0))((1 0)(0.707 0.707))((0.707 0.707)(0 1))((1 1)(-1 1)))
("_NEA," ((-1 1)(1 -1))((1 -1)(-1 -1))((-1 -1)(1 1))((1 1)(-1 1)))
("_APP," ((-1 1)(-1 -1))((-1 -1)(1 -1))((1 -1)(1 1))((1 1)(-1 1))((-1 1)(1 -1))((-1 -1)(1 1)))
("_EXT," ((0.1 0)(0.13 0))((0.2 0)(0.23 0))((0.3 0)(0.33 0)))
("_PAR" ((0 1)(-1 -1))((1 1)(0 -1)))
)
)
)
)
(sldrawvecs (setq p (if p p pt)) mode size cl)
)
;(if (and p0 p (not (equal p pt size)))
;(progn
; (setq p p0)
; (sldrawvecs p0 '(((-1 1)(1 -1))((-1 -1)(1 1))((1 0.859)(-0.859 -1))((-1 0.859)(0.859 -1))((0.859 1)(-1 -0.859))((-0.859 1)(1 -0.859))) size cl)
;)
;)
(if p p pt)
)
;;grread图元捕捉函数-----(一级)------
;;name为移动的图元、选择集,pt为光标点
;;有捕捉点则返回捕捉点,无返回光标点
;;支持象限点 三领设计 V3.0 Modify by 尘缘一生QQ:15290049 2024.7.1(精简后代码)
(defun slosnappt (name pt / p0 p1 p2 newe size k)
(if (< (getvar "OSMODE") 16384) ;;打开捕捉
(progn
(if name (progn (sl-sel-redrawsel name 2) (setq k t))) ;隐藏
(if (setq newe (car (nentselp pt)))
(progn
(setq p0 (e9pt newe 5))
(if (= (nentselp p0) nil)
(progn
(setq size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX")))
(setq p1 (polar p0 pi size) p2 (polar p0 0 size))
(entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "f-i-n-d"))) ;产生的象限临时线，需在函数体外删除，目前没解决函数体内删除问题
(setq p1 (polar p0 pi2 size) p2 (polar p0 3pi2 size))
(entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "f-i-n-d"))) ;产生的象限临时线，需在函数体外删除，目前没解决函数体内删除问题
)
)
)
)
(setq pt (sl-osnappt pt))
(if k (sl-sel-redrawsel name 1)) ;恢复显示
)
)
pt
)
;;;返回捕捉模式字串
;"_END,_MID,_CEN,_NOD,_QUA,_INT,_INS,_PER,_TAN,_NEA,_QUI,_APP,_EXT,_PAR"
(defun get_osmode (/ cur_mode mode) ;(get_osmode)
(setq mode "")
(if (< 0 (setq cur_mode (getvar "osmode")) 16384)
(mapcar
(function
(lambda (x)
(if (not (zerop (logand cur_mode (car x))))
(if (zerop (strlen mode))
(setq mode (cadr x))
(setq mode (strcat mode "," (cadr x)))
)
)
)
)
'((1 "_END")
(2 "_MID")
(4 "_CEN")
(8 "_NOD")
(16 "_QUA")
(32 "_INT")
(64 "_INS")
(128 "_PER")
(256 "_TAN")
(512 "_NEA")
(1024 "_QUI")
(2048 "_APP")
(4096 "_EXT")
(8192 "_PAR")
)
)
)
mode
)
;;grread图元捕捉子函数-----(一级)------有缺憾，会闪烁
;;name为移动的图元、选择集，pt为光标点
;;有捕捉点则返回捕捉点，无返回光标点
(defun slosnappt (name pt / cl osmo d h k kk lst nearpt p0 p00 p1 p2 p3 p4 p5 ptx pty x newe)
(if (< (getvar "OSMODE") 16384) ;;打开捕捉
(progn
(if name (progn (sl-sel-redrawsel name 2) (setq kk t))) ;隐藏
(setq
p1 nil p2 nil
cl (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences *Acad*)))
h (p2uu 1.0) d (getvar "PICKBOX")
lst (list (* d h) (* (- d 0.5) h) (* (+ d 0.5) h)) k (* 30.0 d h)
p1 (cadr (grread 5))
)
(if (setq newe (car (nentselp pt)))
(setq p2 (e9pt newe 5))
)
(if (setq p0 (osnap pt (get_osmode)))
(setq osmo 1 nearpt p0)
)
(if (and (setq p0 (osnap pt "_NEA")) (equal nearpt p0 k))
(setq osmo 2 nearpt p0)
)
(if (and (setq p0 (osnap pt "_MID")) (equal nearpt p0 k))
(setq osmo 3 nearpt p0)
)
(if (and (setq p0 (osnap pt "_INT")) (equal nearpt p0 k))
(setq osmo 4 nearpt p0)
)
(if (and p2 nearpt (not (equal nearpt p2 k)))
(setq osmo 4 nearpt p2)
)
(if kk (sl-sel-redrawsel name 1)) ;恢复显示
)
(if nearpt
(progn
(setq ptx (car nearpt) pty (cadr nearpt))
(while lst
(setq x (car lst) p1 (list (- ptx x) (- pty x)) p2 (list (+ ptx x) (- pty x))
p3 (list (+ ptx x) (+ pty x)) p4 (list (- ptx x) (+ pty x))
p5 (list ptx (+ pty x))
)
(cond
((= osmo 1) (grvecs (list cl p1 p2 p2 p3 p3 p4 p4 p1))) ;正方形
((= osmo 2) (grvecs (list cl p1 p2 p2 p4 p3 p4 p3 p1))) ;俩三角
((= osmo 3) (grvecs (list cl p1 p2 p2 p5 p5 p1))) ;三角
((= osmo 4) (grvecs (list cl p1 p3 cl p2 p4)));交叉
)
(setq lst (cdr lst))
)
(setq pt nearpt)
)
)
)
pt
)
楼主是老当益壮啊，我们都老了，都要注意身体 睡得太晚了
新手前来学习下，grread我现在就只用过一次
外壳部分再作一下
;;grread图元捕捉子函数-----(一级)------
;;name为移动的图元、选择集,pt为光标点
;;有捕捉点则返回捕捉点,无返回光标点
;;三领设计 尘缘一生 QQ:15290049
(defun slosnappt (name pt / p0 p1 p2 newe ss size k)
(if (< (getvar "OSMODE") 16384) ;;打开捕捉
(progn
(if name (progn (sl-sel-redrawsel name 2) (setq k t))) ;隐藏
(if (setq newe (car (nentselp pt)))
(progn
(setq size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX"))
p0 (e9pt newe 5)
ss (ssget "C" (polar p0 5pi4 size) (polar p0 pi4 size))
)
(if (or (null ss) (and ss (< (sslength ss) 2)))
(progn
(setq p1 (polar p0 pi size) p2 (polar p0 0 size))
(entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "f-i-n-d")))
(setq p1 (polar p0 pi2 size) p2 (polar p0 3pi2 size))
(entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "f-i-n-d")))
)
)
)
)
(vl-catch-all-apply '(lambda () (setq pt (sl-osnappt pt))))
(if k (sl-sel-redrawsel name 1)) ;恢复显示
)
)
pt
)
老师，请问最终完全体版本是哪个呢？想学习一下 本帖最后由 gzcsun 于 2024-7-23 10:47 编辑
本来不想说
实在忍不住
Gu_xl
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=91191&highlight=grread
langjs
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=176190&highlight=grread
楼主
llsheng_73
楼主
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=176190&highlight=grread
2楼
建议 (osnap pt "_END,_CEN,_NOD,_QUA,_INS,_TAN,_EXT")根据当前的捕捉设置来
我把G版那个按我的习惯修改了一下，没有对正交等模式进行处理
(defun dectobin(n m / c f);;十进制转二进制
(setq f(if(< n 0)1 0)n(abs n))
(while(>(setq c(cons(rem n 2)c)n(/ n 2))0))
(while(<(length c)(1- m))(setq c(cons 0 c)))
(cons f c))
(DEFUN DrawVecs(Pt Vecs Size Color / xdir);;;G版函数绘制矢量
(setq xdir(getvar'ucsxdir)
Vecs(mapcar'(lambda(x)(mapcar'(lambda(a)(mapcar'+ pt(mapcar'*(setq a(trans a 0 xdir)a(list(caddr a)(car a)))(List size size))))x))Vecs))
(GRVECS(APPLY 'APPEND(MAPCAR 'CONS(MAPCAR(FUNCTION (LAMBDA (x)Color))Vecs)Vecs))))
(defun myosnap(pt / p mode osmod osmode Draftobj Size);;;修改G版函数带捕捉grread
(if(setq Draftobj(VLA-GET-DRAFTING(VLA-GET-PREFERENCES(VLAX-GET-ACAD-OBJECT)))
osmod'("_END," "_MID," "_CEN," "_NOD," "_QUA," "_INT," "_INS," "_PER," "_TAN," "_NEA," "_NON," "_APP," "_EXT," "_PAR")
osmode(reverse(DECTOBIN (getvar'osmode) 1))
size(*(/(getvar "viewsize")(cadr(getvar "screensize")))(VLA-GET-AUTOSNAPMARKERSIZE Draftobj))
p(osnap pt(apply'strcat(mapcar'(lambda(x y)(if(zerop x)""y))osmode osmod)))
mode(CDR(ASSOC
(if p(vl-some'(lambda(x)(if(equal p(cdr x)1e-8)(car x)))
(vl-remove'nil(mapcar'(lambda(x y / p)(if(zerop x)nil(if(setq p(osnap pt y))(cons y p))))osmode osmod)))"_NON,")
'(("_END,"((-1 1)(-1 -1))((-1 -1)(1 -1))((1 -1) (1 1))((1 1) (-1 1)))
("_MID,"((0 1.414) (-1.225 -0.707)) ((-1.225 -0.707)(1.225 -0.707))((1.225 -0.707) (0 1.414)))
("_CEN,"((0 1) (-0.707 0.707))((-0.707 0.707)(-1 0))((-1 0) (-0.707 -0.707))((-0.707 -0.707)(0 -1))
((0 -1)(0.707 -0.707))((0.707 -0.707)(1 0)) ((1 0) (0.707 0.707))((0.707 0.707) (0 1)))
("_NOD,"((0 1) (-0.707 0.707))((-0.707 0.707)(-1 0))((-1 0)(-0.707 -0.707))((-0.707 -0.707)(0 -1))((0 -1)(0.707 -0.707))
((0.707 -0.707)(1 0))((1 0)(0.707 0.707))((0.707 0.707)(0 1))((-1 1)(1 -1))((-1 -1)(1 1)))
("_QUA,"((0 1.414)(-1.414 0))((-1.414 0)(0 -1.414))((0 -1.414)(1.414 0))((1.414 0)(0 1.414)))
("_INT,"((-1 1)(1 -1))((-1 -1)(1 1))((1 0.859)(-0.859 -1))((-1 0.859)(0.859 -1))((0.859 1)(-1 -0.859))((-0.859 1)(1 -0.859)))
("_INS,"((-1 1)(-1 -0.1))((-1 -0.1)(0 -0.1))((0 -0.1)(0 -1.0))((0 -1.0)(1 -1))
((1 -1)(1 0.1))((1 0.1)(0 0.1))((0 0.1) (0 1.0))((0 1.0)(-1 1)))
("_PER,"((-1 1)(-1 -1))((-1 -1)(1 -1))((0 -1)(0 0))((0 0)(-1 0)))
("_TAN,"((0 1)(-0.707 0.707))((-0.707 0.707)(-1 0))((-1 0)(-0.707 -0.707))((-0.707 -0.707)(0 -1))
((0 -1)(0.707 -0.707))((0.707 -0.707)(1 0))((1 0)(0.707 0.707))((0.707 0.707)(0 1))((1 1)(-1 1)))
("_NEA,"((-1 1)(1 -1))((1 -1)(-1 -1))((-1 -1)(1 1))((1 1)(-1 1)))
("_NON,")
("_APP,"((-1 1)(-1 -1))((-1 -1)(1 -1))((1 -1)(1 1))((1 1)(-1 1))((-1 1)(1 -1))((-1 -1)(1 1)))
("_EXT,"((0.1 0)(0.13 0))((0.2 0)(0.23 0))((0.3 0)(0.33 0)))
("_PAR"((0 1)(-1 -1))((1 1)(0 -1)))))))
(DrawVecs(setq p(if p p pt))mode size(VLA-GET-AUTOSNAPMARKERCOLOR Draftobj)))
(if p p pt))
(defun c:tt(/ e p) ;;选择一个圆进行移动
(while(setq e(ssget":E:S"'((0 . "circle"))))
(setq e(entget(ssname e 0)))
(while(/=(car(setq p(grread t 15 0)))3)(redraw)
(if(=(car p)5)(entmod(append e(list(cons 10(myosnap(cadr p)))))))
))
)
llsheng_73 象限捕捉早就可以支持，
你还抄作业乱改，
乱改算了，还发出来，
发出来算了，不支持象限捕捉还自己说是优秀代码，还要缺函数。
本帖最后由 尘缘一生 于 2024-7-23 13:21 编辑
gzcsun 发表于 2024-7-23 10:41
本来不想说
实在忍不住忍不住，最好学习，看明白了，这是解决什么问题的事。
函数代码写的支持，没用，不支持，无效。使用起来就不是了。
'("_END," "_MID," "_CEN," "_NOD," "_QUA," "_INT," "_INS," "_PER," "_TAN," "_NEA," "_NON," "_APP," "_EXT," "_PAR")
被前面截取先登！ "_QUA,"如果放在第一个，有可能可以，这是我得怀疑，也没测试，
实际这个问题，也就是，不能做到和CAD完全一样，没有做到，代码看着行，实际办不到。
我再次说明，我帖子，别回复，只管看好了，有人看得明白咋回事！！！！
正中心的那个小正交线，定位在这里的要求。
页:
[1]
2