社区 › AutoLISP/Visual LISP 编程技术 › 修改了下grread捕捉子函数应该能用了

langjs 发表于 2017-12-25 15:13:42

修改了下grread捕捉子函数应该能用了

;;; grread捕捉子函数
;;; name为移动的图元名，pt为光标点
;;; 返回值：如果有捕捉点则返回捕捉点，无则返回光标点
(defun osnappt (name pt / color d h k lst nearpt nearpt2 osmo pt1 pt2 pt3 pt4 pt5 ptx pty x)
(if name (entdel name))
(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 name(entdel name))
(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 c:qq (/ code ent gr loop name pt)
(if (setq name (car (entsel "\n选择文本:")))
    (progn
      (setq ent (entget name) loop t)
      (princ "\n指定点:")
      (while loop
      (setq gr (grread t 15 0) code (car gr) pt (cadr gr))
      (cond
          ((= code 3)(redraw) (setq loop nil)); 鼠标左键
          ((= code 5)                  ; 鼠标移动
            (setq pt (osnappt name pt))
            (entmod (setq ent (subst(cons 10 pt)(assoc 10 ent)ent))))
          ((= code 2)                  ; 键盘输入
            (princ "\n键盘输入=")(princ pt))
          ((member code '(11 25))      ; 鼠标右击
            (redraw)(setq loop nil))))))
(princ)
)

gzcsun 发表于 2024-7-24 11:32:36

本帖最后由 gzcsun 于 2024-8-10 00:08 编辑

228378553 发表于 2024-7-24 11:03
好像还是不能捕捉圆心和几何中心
自己加上。圆心 ,几何中心,图元中心 都可以有。
我是不用几何中心的,图元中心用得多。

cad原捕捉限显示6个；而且面域不能显示几何中心。

所以圆心限显示4个，
图元中心限显示2个，面域，块，多段线的都能显示，其它的要按一下按键才显示。

llsheng_73 发表于 2020-8-11 10:33:40

本帖最后由 llsheng_73 于 2020-8-11 16:00 编辑

建议 (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)))))))
      ))
)

yoyoho 发表于 2017-12-25 16:42:52

本帖最后由 yoyoho 于 2017-12-25 16:47 编辑

感谢 langjs 分享程序!!!
但是在立体的物件貌似捕捉显示位置不正确,不知可否改善呢?

yoyoho 发表于 2017-12-26 16:23:03

yoyoho 发表于 2017-12-25 16:42
感谢 langjs 分享程序!!!
但是在立体的物件貌似捕捉显示位置不正确,不知可否改善呢?

将2D点改3D点可以改善!
圆是不是捕捉不到啊!

clh521 发表于 2017-12-27 08:25:23

谢谢，在2012和2018试过可以正确运行，收藏。

fl202 发表于 2017-12-27 10:51:18

本帖最后由 fl202 于 2017-12-27 11:24 编辑


文字组码

组码
说明

100
子类标记 (AcDbText)

39
厚度（可选；默认值 = 0）

10
第一对齐点（在 OCS 中）
DXF：X 值；APP：三维点

20, 30
DXF：第一对齐点的 Y 值和 Z 值（在 OCS 中）

40
文字高度

1
默认值（字符串本身）

50
文字旋转角度（可选；默认值 = 0）

41
X 相对缩放比例宽度（可选；默认值 = 1）
使用拟合类型的文字时，该值也将进行调整。

51
倾斜角（可选；默认值 = 0）

7
文字样式名（可选；默认值 = 标准）

71
文字生成标志（可选；默认值 = 0）：
2 = 文字反向（在 X 轴方向镜像）
4 = 文字倒置（在 Y 轴方向镜像)

72
文字水平对正类型（可选；默认值 = 0）整数代码（非按位编码）
0 = 左对正；1 = 居中对正；2 = 右对正
3 = 对齐（如果垂直对齐 = 0）
4 = 中间（如果垂直对齐 = 0）
5 = 拟合（如果垂直对齐 = 0）
详细信息请参见组 72 和 73 整数代码表

11
第二对齐点（在 OCS 中）（可选）
DXF：X 值；APP：三维点
只有当 72 或 73 组的值非零时，该值才有意义（如果对正不是基线对正/左对正）

21, 31
DXF：第二对齐点的 Y 值和 Z 值（在 OCS 中）（可选）

210
拉伸方向（可选；默认值 = 0, 0, 1）
DXF：X 值；APP：三维矢量

220, 230
DXF：拉伸方向的 Y 值和 Z 值（可选）

100
子类标记 (AcDbText)

73
文字垂直对正类型（可选；默认值 = 0）：整数代码（非按位编码）：
0 = 基线对正；1 = 底端对正；2 = 居中对正；3 = 顶端对正
详细信息请参见组 72 和 73 整数代码表


下表详细说明了组码 72（水平对齐）和组码 73（垂直对齐）。
组 72 和 73 整数代码

组 73

组 72
0

1

2

3

4

5

3（顶端对正）
左上
中上
右上




2（居中对正）
左中
正中
右中




1（底端对正）
左下
中下
右下




0（基线对正）
左
中心
右
对齐
中间
拟合


如果组 72 和/或 73 值非零，则第一对齐点值被忽略，并且 AutoCAD 根据第二对齐点和文字字符串本身的长度和高度（在应用文字样式之后）计算新值。如果 72 和 73 值为零或缺失，则第二对齐点将没有意义。

不能捕捉圆心。如果文字非左对齐时，楼主的测试程序会出错，文字不移动。所以应该加入判断72/73组码是否非0语句，然后修改10或者11组码。(if (and (= (cdr (assoc 72 ent)) 0) (= (cdr (assoc 73 ent)) 0) )
            (entmod (setq ent (subst(cons 10 pt)(assoc 10 ent)ent)))
            (entmod (setq ent (subst(cons 11 pt)(assoc 11 ent)ent)))
            )谢谢楼主！

yoyoho 发表于 2017-12-27 14:28:42

fl202 发表于 2017-12-27 10:51
下表详细说明了组码 72（水平对齐）和组码 73（垂直对齐）。
如果组 72 和/或 73 值非零，则第一对齐点 ...

感谢回覆!!!!

尘缘一生 发表于 2018-2-3 17:02:19

郎大师：能提供个不要扑捉，只要正交功能的grread函数吗？

张积乐 发表于 2018-3-30 19:18:28

正在寻找grread的捕捉，学习了

nihaoya 发表于 2018-4-13 20:27:14

非常好，可以有动态引线吗，移动的橡皮筋效果

evayleung 发表于 2018-5-30 21:12:41

很好很强大的功能，谢谢分享

查看完整版本: 修改了下grread捕捉子函数应该能用了