设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › grread下的扑捉问题（已支持象限扑捉）
12下一页
返回列表 发新帖
查看: 1130|回复: 14

[讨论] grread下的扑捉问题（已支持象限扑捉）

[复制链接]
尘缘一生
发表于 2024-6-30 23:47:22 | 显示全部楼层 |阅读模式
本帖最后由 尘缘一生 于 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

下面代码，是我今上午改写的，尝试一下，还不完美，
  2. ;;grread图元捕捉子函数-----(一级)------有缺憾，会闪烁
  3. ;;name为移动的图元、选择集，pt为光标点
  4. ;;有捕捉点则返回捕捉点，无返回光标点
  5. (defun slosnappt (name pt / cl osmo d h k lst nearpt p0 p00 p1 p2 p3 p4 p5 ptx pty x newe)
  6.   (redraw)
  7.   (if (< (getvar "OSMODE") 16384) ;;打开捕捉
  8.     (progn
  9.       (cond
  10.         ((= (type name) 'ENAME) (entdel name)) ;图元先删除
  11.         ((= (type name) 'PICKSET) ;选择集
  12.           (sl-sel-redrawsel name 2) ;先隐藏
  13.         )
  14.       )
  15.       (setq
  16.         p1 nil p2 nil
  17.         cl (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences *Acad*)))
  18.         h (p2uu 1.0) d (getvar "PICKBOX")
  19.         lst (list (* d h) (* (- d 0.5) h) (* (+ d 0.5) h)) k (* 30.0 d h)
  20.         p1 (cadr (grread 5))
  21.       )
  22.       ;下面三行，此时如果扑捉到实体，取得它中心p2
  23.       (if (setq newe (car (nentselp pt)))
  24.         (setq p2 (e-mid newe))
  25.       )
  26.       ;;这是第一步，取得扑捉点
  27.       (if (setq p0 (osnap pt "_NEA,_MID,_END,_INT,_CEN,_NOD,_QUA,_INS,_PER,_TAN,_APP,_EXT,_PAR"))
  28.         (setq osmo 1 nearpt p0)
  29.       )
  30.       ;;如果是NEA  只不过是判定osmo罢了吗？值得进行下去if，如果能模拟到和CAD一样丝滑，建议osmo仅仅一个好了，那就是osmo=1 ,画个矩形
  31.       (if (and (setq p0 (osnap pt "_NEA")) (equal nearpt p0 k))
  32.         (setq osmo 2 nearpt p0)
  33.       )
  34.       (if (and (setq p0 (osnap pt "_MID")) (equal nearpt p0 k))
  35.         (setq osmo 3 nearpt p0)
  36.       )
  37.       (if (and (setq p0 (osnap pt "_INT")) (equal nearpt p0 k))
  38.         (setq osmo 4 nearpt p0)
  39.       )
  40.       ;;下面三句吗，我尝试给于象限点p2，并设为OSMO=4，画交叉矢量线，可以是可以，但是操作不如CAD本身丝滑
  41.       (if (and p2 nearpt (not (equal nearpt p2 k)))
  42.         (setq osmo 4 nearpt p2)
  43.       )
  44.       (cond
  45.         ((= (type name) 'ENAME) (entdel name)) ;图元恢复
  46.         ((= (type name) 'PICKSET) ;选择集
  47.           (sl-sel-redrawsel name 1) ;恢复显示
  48.         )
  49.       )
  50.       (if nearpt
  51.         (progn
  52.           (setq ptx (car nearpt) pty (cadr nearpt))
  53.           (while lst
  54.             (setq x (car lst) p1 (list (- ptx x) (- pty x)) p2 (list (+ ptx x) (- pty x))
  55.               p3 (list (+ ptx x) (+ pty x)) p4 (list (- ptx x) (+ pty x))
  56.               p5 (list ptx (+ pty x))
  57.             )
  58.             (cond
  59.               ((= osmo 1) (grvecs (list cl p1 p2 p2 p3 p3 p4 p4 p1))) ;正方形
  60.               ((= osmo 2) (grvecs (list cl p1 p2 p2 p4 p3 p4 p3 p1))) ;俩三角
  61.               ((= osmo 3) (grvecs (list cl p1 p2 p2 p5 p5 p1))) ;三角
  62.               ((= osmo 4) (grvecs (list cl p1 p3 cl p2 p4)))  ;交叉
  63.             )
  64.             (setq lst (cdr lst))
  65.           )
  66.           (setq pt nearpt)
  67.         )
  68.       )  
  69.     )
  70.   )
  71.   pt
  72. )
下面为了大家能更好的解决这个问题，贴上另一种优秀代码，还没来得及尝试扑捉象限点的改写
  2. ;;重画选择集中的对象-----(一级)-----
  3. ;;Sel为选择集或图元名; mode为方式码
  4. ;;mode 1 在屏幕重画该选择集对象
  5. ;;mode 2 隐藏该选择集对象
  6. ;;mode 3 <醒目显示> 该选择集对象
  7. ;;mode 4 取消<醒目显示>该选择集对象
  8. (defun sl-sel-redrawsel (sel mode / n)
  9.   (if sel
  10.     (cond
  11.       ((= 'PICKSET (type sel))
  12.         (repeat (setq n (sslength sel))
  13.           (redraw (ssname sel (setq n (1- n))) mode)
  14.         )
  15.       )
  16.       ((= 'ENAME (type sel))
  17.         (redraw sel mode)
  18.       )
  19.     )
  20.   )
  21.   t
  22. )
  23. ;;grread图元捕捉子函数-----(一级)------
  24. ;;name为移动的图元、选择集,pt为光标点
  25. ;;有捕捉点则返回捕捉点,无返回光标点
  26. (defun slosnappt (name pt / p mode osmod osmode size k)
  27.   (defun sldectobin (n m / c f) ;;十进制转二进制
  28.     (setq f (if (< n 0) 1 0) n (abs n))
  29.     (while (> (setq c (cons (rem n 2) c) n (* n 0.5)) 0))
  30.     (while (< (length c) (1- m)) (setq c (cons 0 c)))
  31.     (cons f c)
  32.   )
  33.   ;;------------------
  34.   (defun sldrawvecs (pt vecs size cl / xdir)
  35.     (setq xdir (getvar 'ucsxdir)
  36.       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)
  37.     )
  38.     (grvecs (apply 'append (mapcar 'cons (mapcar (function (lambda (x) cl)) vecs) vecs)))
  39.   )
  40.   ;;----------------
  41.   (if (< (getvar "OSMODE") 16384) ;;打开捕捉
  42.     (progn
  43.       (if name (progn (sl-sel-redrawsel name 2) (setq k t))) ;隐藏
  44.       (if (setq
  45.             osmod '("_NEA," "_QUA," "_END," "_MID," "_CEN," "_NOD," "_INT," "_INS," "_PER," "_TAN," "_APP," "_EXT," "_PAR")
  46.             osmode (reverse (sldectobin (getvar 'osmode) 1))
  47.             size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX"))
  48.             p (osnap pt (apply 'strcat (mapcar '(lambda (x y) (if (zerop x) "" y)) osmode osmod)))
  49.             mode (cdr (assoc (if p
  50.                                (vl-some '(lambda (x) (if (equal p (cdr x) 1e-8) (car x)))
  51.                                  (vl-remove 'nil (mapcar '(lambda (x y / p) (if (zerop x) nil (if (setq p (osnap pt y)) (cons y p)))) osmode osmod)))
  52.                              )
  53.                         '(("_END," ((-1 1)(-1 -1))((-1 -1)(1 -1))((1 -1) (1 1))((1 1) (-1 1)))
  54.                            ("_MID," ((0 1.414) (-1.225 -0.707)) ((-1.225 -0.707)(1.225 -0.707))((1.225 -0.707) (0 1.414)))
  55.                            ("_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))
  56.                              ((0 -1)(0.707 -0.707))((0.707 -0.707)(1 0)) ((1 0) (0.707 0.707))((0.707 0.707) (0 1)))
  57.                            ("_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))
  58.                              ((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)))
  59.                            ("_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)))
  60.                            ("_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)))
  61.                            ("_INS," ((-1 1)(-1 -0.1))((-1 -0.1)(0 -0.1))((0 -0.1)(0 -1.0))((0 -1.0)(1 -1))
  62.                              ((1 -1)(1 0.1))((1 0.1)(0 0.1))((0 0.1) (0 1.0))((0 1.0)(-1 1)))
  63.                            ("_PER," ((-1 1)(-1 -1))((-1 -1)(1 -1))((0 -1)(0 0))((0 0)(-1 0)))
  64.                            ("_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))
  65.                              ((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)))
  66.                            ("_NEA," ((-1 1)(1 -1))((1 -1)(-1 -1))((-1 -1)(1 1))((1 1)(-1 1)))
  67.                            ("_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)))
  68.                            ("_EXT," ((0.1 0)(0.13 0))((0.2 0)(0.23 0))((0.3 0)(0.33 0)))
  69.                            ("_PAR" ((0 1)(-1 -1))((1 1)(0 -1)))
  70.                          )
  71.                       )
  72.                  )
  73.           )
  74.         (sldrawvecs (setq p (if p p pt)) mode size (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences *Acad*))))
  75.       )
  76.       (if k (sl-sel-redrawsel name 1)) ;恢复显示
  77.     )
  78.   )
  79.   (if p p pt)
  80. )


评分

参与人数 1明经币 +1 收起 理由
baitang36 + 1 师弟是夜猫子类型啊，这么晚了还发帖子

查看全部评分

"觉得好，就打赏"
打赏
还没有人打赏，支持一下
回复

使用道具 举报

尘缘一生
 楼主| 发表于 2024-7-23 11:02:42 | 显示全部楼层
本帖最后由 尘缘一生 于 2024-7-23 13:26 编辑

最终结果
  2. ;;grread图元捕捉函数-----(一级)------
  3. ;;name为移动的图元、选择集,pt为光标点
  4. ;;有捕捉点则返回捕捉点,无返回光标点
  5. (defun sl-osnappt (pt / p mode osmod osmode size cl)
  6.   (defun sldectobin (n m / c f) ;;十进制转二进制
  7.     (setq f (if (< n 0) 1 0) n (abs n))
  8.     (while (> (setq c (cons (rem n 2) c) n (* n 0.5)) 0))
  9.     (while (< (length c) (1- m)) (setq c (cons 0 c)))
  10.     (cons f c)
  11.   )
  12.   ;;------------------
  13.   (defun sldrawvecs (pt vecs size cl / xdir)
  14.     (setq xdir (getvar 'ucsxdir)
  15.       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)
  16.     )
  17.     (grvecs (apply 'append (mapcar 'cons (mapcar (function (lambda (x) cl)) vecs) vecs)))
  18.   )
  19.   ;;------------------
  20.   (if (setq
  21.         size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX"))
  22.         cl (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences *Acad*)))
  23.         osmod '("_NEA," "_QUA," "_END," "_MID," "_CEN," "_NOD," "_INT," "_INS," "_PER," "_TAN," "_APP," "_EXT," "_PAR")
  24.         osmode (reverse (sldectobin (getvar 'osmode) 1))
  25.         p (osnap pt (apply 'strcat (mapcar '(lambda (x y) (if (zerop x) "" y)) osmode osmod)))
  26.         mode (cdr (assoc (if p
  27.                            (vl-some '(lambda (x) (if (equal p (cdr x) 1e-8) (car x)))
  28.                              (vl-remove 'nil (mapcar '(lambda (x y / p) (if (zerop x) nil (if (setq p (osnap pt y)) (cons y p)))) osmode osmod)))
  29.                          )
  30.                     '(("_END," ((-1 1)(-1 -1))((-1 -1)(1 -1))((1 -1) (1 1))((1 1) (-1 1)))
  31.                        ("_MID," ((0 1.414) (-1.225 -0.707)) ((-1.225 -0.707)(1.225 -0.707))((1.225 -0.707) (0 1.414)))
  32.                        ("_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))
  33.                          ((0 -1)(0.707 -0.707))((0.707 -0.707)(1 0)) ((1 0) (0.707 0.707))((0.707 0.707) (0 1)))
  34.                        ("_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))
  35.                          ((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)))
  36.                        ("_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)))
  37.                        ("_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
  38.                        ("_INS," ((-1 1)(-1 -0.1))((-1 -0.1)(0 -0.1))((0 -0.1)(0 -1.0))((0 -1.0)(1 -1))
  39.                          ((1 -1)(1 0.1))((1 0.1)(0 0.1))((0 0.1) (0 1.0))((0 1.0)(-1 1))) ;双方形
  40.                        ("_PER," ((-1 1)(-1 -1))((-1 -1)(1 -1))((0 -1)(0 0))((0 0)(-1 0)))
  41.                        ("_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))
  42.                          ((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)))
  43.                        ("_NEA," ((-1 1)(1 -1))((1 -1)(-1 -1))((-1 -1)(1 1))((1 1)(-1 1)))
  44.                        ("_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)))
  45.                        ("_EXT," ((0.1 0)(0.13 0))((0.2 0)(0.23 0))((0.3 0)(0.33 0)))
  46.                        ("_PAR" ((0 1)(-1 -1))((1 1)(0 -1)))
  47.                      )
  48.                   )
  49.              )
  50.       )
  51.     (sldrawvecs (setq p (if p p pt)) mode size cl)
  52.   )
  53.   (if p p pt)
  54. )
  55. ;;grread图元捕捉子函数-----(一级)------
  56. ;;name为移动的图元、选择集,pt为光标点
  57. ;;有捕捉点则返回捕捉点,无返回光标点
  58. (defun slosnappt (name pt / p0 p1 p2 newe ss size k cl d)
  59.   (setq d (getvar "OSMODE"))
  60.   (if (and (< d 16384) (> d 0));;打开捕捉
  61.     (progn
  62.       (if name (progn (setq k t)(sl-sel-redrawsel name 2))) ;隐藏
  63.       (setq size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX")))
  64.       (if (setq ss (ssget "C" (polar pt 5pi4 size) (polar pt pi4 size)))
  65.         (progn
  66.           (setq newe (ssname ss 0)
  67.             p0 (e9pt newe 5)
  68.             ss (ssget "C" (polar p0 5pi4 size) (polar p0 pi4 size))
  69.           )
  70.           (if (and (or (null ss) (and ss (< (sslength ss) 2))) (> (distance p0 pt) (* 10.0 size)))
  71.             (progn
  72.               (if ss
  73.                 (setq cl (abs (- 250 (sl-getcolor (ssname ss 0)))))
  74.                 (setq cl (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences *Acad*))))
  75.               )
  76.               (setq p1 (polar p0 pi size) p2 (polar p0 0 size))
  77.               (entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "f-i-n-d") (cons 62 cl)))
  78.               (setq p1 (polar p0 pi2 size) p2 (polar p0 3pi2 size))
  79.               (entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "f-i-n-d") (cons 62 cl)))
  80.             )
  81.           )
  82.         )
  83.       )
  84.       (setq pt (sl-osnappt pt))
  85.       (if k (sl-sel-redrawsel name 1)) ;恢复显示
  86.     )
  87.   )
  88.   pt
  89. )
    函数看字眼就知道是个啥，自理去即可，我发的是“理念”，就是问题是个啥子，不是代码本身，代码本身没什么意思，会写的很多。这个问题，也是有人问我要这个支持，才发现的，就是扑捉时候，要能扑捉到中心支持，要扑捉这个实体的中心定位，扩展这一功能。
     如果前面支持，那好，恭喜了，用即可。我得帖子，记住了，不是给外行看的。



回复 支持 反对

使用道具 举报

尘缘一生
 楼主| 发表于 2024-7-1 09:56:47 | 显示全部楼层
为支持象限扑捉的改写，可以用了
  2. ;;grread图元捕捉子函数-----(一级)------
  3. ;;name为移动的图元、选择集,pt为光标点
  4. ;;有捕捉点则返回捕捉点,无返回光标点
  5. (defun sl-osnappt (pt / p mode osmod osmode size cl)
  6.   (defun sldectobin (n m / c f) ;;十进制转二进制
  7.     (setq f (if (< n 0) 1 0) n (abs n))
  8.     (while (> (setq c (cons (rem n 2) c) n (* n 0.5)) 0))
  9.     (while (< (length c) (1- m)) (setq c (cons 0 c)))
  10.     (cons f c)
  11.   )
  12.   ;;------------------
  13.   (defun sldrawvecs (pt vecs size cl / xdir)
  14.     (setq xdir (getvar 'ucsxdir)
  15.       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)
  16.     )
  17.     (grvecs (apply 'append (mapcar 'cons (mapcar (function (lambda (x) cl)) vecs) vecs)))
  18.   )
  19.   ;;------------------
  20.   (if (setq
  21.         size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX"))
  22.         cl (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences *Acad*)))
  23.         osmod '("_NEA," "_QUA," "_END," "_MID," "_CEN," "_NOD," "_INT," "_INS," "_PER," "_TAN," "_APP," "_EXT," "_PAR")
  24.         osmode (reverse (sldectobin (getvar 'osmode) 1))
  25.         p (osnap pt (apply 'strcat (mapcar '(lambda (x y) (if (zerop x) "" y)) osmode osmod)))
  26.         mode (cdr (assoc (if p
  27.                            (vl-some '(lambda (x) (if (equal p (cdr x) 1e-8) (car x)))
  28.                              (vl-remove 'nil (mapcar '(lambda (x y / p) (if (zerop x) nil (if (setq p (osnap pt y)) (cons y p)))) osmode osmod)))
  29.                          )
  30.                     '(("_END," ((-1 1)(-1 -1))((-1 -1)(1 -1))((1 -1) (1 1))((1 1) (-1 1)))
  31.                        ("_MID," ((0 1.414) (-1.225 -0.707)) ((-1.225 -0.707)(1.225 -0.707))((1.225 -0.707) (0 1.414)))
  32.                        ("_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))
  33.                          ((0 -1)(0.707 -0.707))((0.707 -0.707)(1 0)) ((1 0) (0.707 0.707))((0.707 0.707) (0 1)))
  34.                        ("_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))
  35.                          ((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)))
  36.                        ("_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)))
  37.                        ("_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
  38.                        ("_INS," ((-1 1)(-1 -0.1))((-1 -0.1)(0 -0.1))((0 -0.1)(0 -1.0))((0 -1.0)(1 -1))
  39.                          ((1 -1)(1 0.1))((1 0.1)(0 0.1))((0 0.1) (0 1.0))((0 1.0)(-1 1))) ;双方形
  40.                        ("_PER," ((-1 1)(-1 -1))((-1 -1)(1 -1))((0 -1)(0 0))((0 0)(-1 0)))
  41.                        ("_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))
  42.                          ((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)))
  43.                        ("_NEA," ((-1 1)(1 -1))((1 -1)(-1 -1))((-1 -1)(1 1))((1 1)(-1 1)))
  44.                        ("_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)))
  45.                        ("_EXT," ((0.1 0)(0.13 0))((0.2 0)(0.23 0))((0.3 0)(0.33 0)))
  46.                        ("_PAR" ((0 1)(-1 -1))((1 1)(0 -1)))
  47.                      )
  48.                   )
  49.              )
  50.       )
  51.     (sldrawvecs (setq p (if p p pt)) mode size cl)
  52.   )
  53.   ;(if (and p0 p (not (equal p pt size)))
  54.   ;  (progn
  55.   ;    (setq p p0)
  56.   ;    (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)
  57.   ;  )
  58.   ;)
  59.   (if p p pt)
  60. )
  61. ;;grread图元捕捉函数-----(一级)------
  62. ;;name为移动的图元、选择集,pt为光标点
  63. ;;有捕捉点则返回捕捉点,无返回光标点
  64. ;;支持象限点 三领设计 V3.0 Modify by 尘缘一生  QQ:15290049 2024.7.1  (精简后代码)
  65. (defun slosnappt (name pt / p0 p1 p2 newe size k)
  66.   (if (< (getvar "OSMODE") 16384) ;;打开捕捉
  67.     (progn
  68.       (if name (progn (sl-sel-redrawsel name 2) (setq k t))) ;隐藏
  69.       (if (setq newe (car (nentselp pt)))
  70.         (progn
  71.           (setq p0 (e9pt newe 5))
  72.           (if (= (nentselp p0) nil)
  73.             (progn
  74.               (setq size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX")))
  75.               (setq p1 (polar p0 pi size) p2 (polar p0 0 size))
  76.               (entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "f-i-n-d"))) ;产生的象限临时线，需在函数体外删除，目前没解决函数体内删除问题
  77.               (setq p1 (polar p0 pi2 size) p2 (polar p0 3pi2 size))
  78.               (entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "f-i-n-d"))) ;产生的象限临时线，需在函数体外删除，目前没解决函数体内删除问题
  79.             )
  80.           )
  81.         )
  82.       )
  83.       (setq pt (sl-osnappt pt))
  84.       (if k (sl-sel-redrawsel name 1)) ;恢复显示
  85.     )
  86.   )
  87.   pt
  88. )


回复 支持 反对

使用道具 举报

尘缘一生
 楼主| 发表于 2024-7-4 01:16:29 | 显示全部楼层
  2. ;;;返回捕捉模式字串
  3. ;"_END,_MID,_CEN,_NOD,_QUA,_INT,_INS,_PER,_TAN,_NEA,_QUI,_APP,_EXT,_PAR"
  4. (defun get_osmode (/ cur_mode mode) ;(get_osmode)
  5.   (setq mode "")
  6.   (if (< 0 (setq cur_mode (getvar "osmode")) 16384)
  7.     (mapcar
  8.       (function
  9.         (lambda (x)
  10.           (if (not (zerop (logand cur_mode (car x))))
  11.             (if (zerop (strlen mode))
  12.               (setq mode (cadr x))
  13.               (setq mode (strcat mode "," (cadr x)))
  14.             )
  15.           )
  16.         )
  17.       )
  18.       '((1 "_END")
  19.          (2 "_MID")
  20.          (4 "_CEN")
  21.          (8 "_NOD")
  22.          (16 "_QUA")
  23.          (32 "_INT")
  24.          (64 "_INS")
  25.          (128 "_PER")
  26.          (256 "_TAN")
  27.          (512 "_NEA")
  28.          (1024 "_QUI")
  29.          (2048 "_APP")
  30.          (4096 "_EXT")
  31.          (8192 "_PAR")
  32.        )
  33.     )
  34.   )
  35.   mode
  36. )
  37. ;;grread图元捕捉子函数-----(一级)------有缺憾，会闪烁
  38. ;;name为移动的图元、选择集，pt为光标点
  39. ;;有捕捉点则返回捕捉点，无返回光标点
  40. (defun slosnappt (name pt / cl osmo d h k kk lst nearpt p0 p00 p1 p2 p3 p4 p5 ptx pty x newe)
  41.   (if (< (getvar "OSMODE") 16384) ;;打开捕捉
  42.     (progn
  43.       (if name (progn (sl-sel-redrawsel name 2) (setq kk t))) ;隐藏
  44.       (setq
  45.         p1 nil p2 nil
  46.         cl (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences *Acad*)))
  47.         h (p2uu 1.0) d (getvar "PICKBOX")
  48.         lst (list (* d h) (* (- d 0.5) h) (* (+ d 0.5) h)) k (* 30.0 d h)
  49.         p1 (cadr (grread 5))
  50.       )
  51.       (if (setq newe (car (nentselp pt)))
  52.         (setq p2 (e9pt newe 5))
  53.       )
  54.       (if (setq p0 (osnap pt (get_osmode)))
  55.         (setq osmo 1 nearpt p0)
  56.       )
  57.       (if (and (setq p0 (osnap pt "_NEA")) (equal nearpt p0 k))
  58.         (setq osmo 2 nearpt p0)
  59.       )
  60.       (if (and (setq p0 (osnap pt "_MID")) (equal nearpt p0 k))
  61.         (setq osmo 3 nearpt p0)
  62.       )
  63.       (if (and (setq p0 (osnap pt "_INT")) (equal nearpt p0 k))
  64.         (setq osmo 4 nearpt p0)
  65.       )
  66.       (if (and p2 nearpt (not (equal nearpt p2 k)))
  67.         (setq osmo 4 nearpt p2)
  68.       )
  69.       (if kk (sl-sel-redrawsel name 1)) ;恢复显示
  70.     )
  71.     (if nearpt
  72.       (progn
  73.         (setq ptx (car nearpt) pty (cadr nearpt))
  74.         (while lst
  75.           (setq x (car lst) p1 (list (- ptx x) (- pty x)) p2 (list (+ ptx x) (- pty x))
  76.             p3 (list (+ ptx x) (+ pty x)) p4 (list (- ptx x) (+ pty x))
  77.             p5 (list ptx (+ pty x))
  78.           )
  79.           (cond
  80.             ((= osmo 1) (grvecs (list cl p1 p2 p2 p3 p3 p4 p4 p1))) ;正方形
  81.             ((= osmo 2) (grvecs (list cl p1 p2 p2 p4 p3 p4 p3 p1))) ;俩三角
  82.             ((= osmo 3) (grvecs (list cl p1 p2 p2 p5 p5 p1))) ;三角
  83.             ((= osmo 4) (grvecs (list cl p1 p3 cl p2 p4)));交叉
  84.           )
  85.           (setq lst (cdr lst))
  86.         )
  87.         (setq pt nearpt)
  88.       )
  89.     )
  90.   )
  91.   pt
  92. )


回复 支持 反对

使用道具 举报

bai2000
发表于 2024-7-1 07:41:12 | 显示全部楼层
楼主是老当益壮啊，我们都老了，都要注意身体
回复 支持 反对

使用道具 举报

sniper1111
发表于 2024-7-1 08:35:51 | 显示全部楼层
睡得太晚了
回复 支持 反对

使用道具 举报

jun470
发表于 2024-7-1 10:02:07 | 显示全部楼层
新手前来学习下，grread我现在就只用过一次
回复 支持 反对

使用道具 举报

尘缘一生
 楼主| 发表于 2024-7-3 00:24:08 | 显示全部楼层
外壳部分再作一下

  2. ;;grread图元捕捉子函数-----(一级)------
  3. ;;name为移动的图元、选择集,pt为光标点
  4. ;;有捕捉点则返回捕捉点,无返回光标点
  5. ;;三领设计 尘缘一生 QQ:15290049
  6. (defun slosnappt (name pt / p0 p1 p2 newe ss size k)
  7.   (if (< (getvar "OSMODE") 16384) ;;打开捕捉
  8.     (progn
  9.       (if name (progn (sl-sel-redrawsel name 2) (setq k t))) ;隐藏
  10.       (if (setq newe (car (nentselp pt)))
  11.         (progn
  12.           (setq size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX"))
  13.             p0 (e9pt newe 5)
  14.             ss (ssget "C" (polar p0 5pi4 size) (polar p0 pi4 size))
  15.           )
  16.           (if (or (null ss) (and ss (< (sslength ss) 2)))
  17.             (progn
  18.               (setq p1 (polar p0 pi size) p2 (polar p0 0 size))
  19.               (entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "f-i-n-d")))
  20.               (setq p1 (polar p0 pi2 size) p2 (polar p0 3pi2 size))
  21.               (entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "f-i-n-d")))
  22.             )
  23.           )
  24.         )
  25.       )
  26.       (vl-catch-all-apply '(lambda () (setq pt (sl-osnappt pt))))
  27.       (if k (sl-sel-redrawsel name 1)) ;恢复显示
  28.     )
  29.   )
  30.   pt
  31. )


回复 支持 反对

使用道具 举报

228378553
发表于 2024-7-22 15:31:25 | 显示全部楼层
老师，请问最终完全体版本是哪个呢？想学习一下

点评

尘缘一生
最终的已发，  发表于 2024-7-23 11:03
回复 支持 反对

使用道具 举报

gzcsun
发表于 2024-7-23 10:41:42 | 显示全部楼层
本帖最后由 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 10:49:10 | 显示全部楼层
本帖最后由 尘缘一生 于 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完全一样，没有做到，代码看着行，实际办不到。
我再次说明，我帖子，别回复，只管看好了，有人看得明白咋回事！！！！


正中心的那个小正交线，定位在这里的要求。



本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x
回复 支持 反对

使用道具 举报

12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-11-25 12:34 , Processed in 0.206633 second(s), 29 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表