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

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

;;; 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)))))))
))
)

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

逗亦斗霸 · 发表于 2025-5-24 21:56:37

本帖最后由逗亦斗霸于 2025-5-25 15:47 编辑

llsheng_73 发表于 2020-8-11 10:33
建议 (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 / xpt mode osmod osmode Draftobj Size);;;修改G版函数带捕捉grread
(redraw)
(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))
xpt(osnap pt(apply'strcat(mapcar'(lambda(x y)(if(zerop x)""y))osmode osmod)))
mode(CDR(ASSOC
(if xpt(vl-some'(lambda(x)(if(equal xpt(cdr x)1e-8)(car x)))
(vl-remove'nil(mapcar'(lambda(x y / xpt)(if(zerop x)nil(if(setq xpt(osnap pt y))(cons y xpt))))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 xpt(if xpt xpt pt))mode size(VLA-GET-AUTOSNAPMARKERCOLOR Draftobj)))
(if xpt xpt pt))
(defun c:tvvt(/ e xpt) ;;选择一个圆进行移动
(while(setq e(ssget":E:S"'((0 . "circle"))))
(setq e(entget(ssname e 0)))
(while(/=(car(setq xpt(grread t 15 0)))3)(redraw)
(if(=(car xpt)5)(entmod(append e(list(cons 10(myosnap(cadr xpt)))))))
))
)
(defun bz (/ *error* name1 name2 name3)
(defun *error* (msg) ;将描述错误的字符串存入变量msg
(entdel name1)
(entdel name2)
(if name3
(entdel name3)
)
(princ "错误: ")
(princ msg)
) ;打印错误信息
(setq ty (getvar "TEXTSTYLE"))
(setq ht (atof txtht))
(if (= ht 0)
(progn
(prompt "字高为0!")
(terpri)
);progn
);if
(setq Scale (/ ht 2.5));
(setq kd1 (caadr (textbox (list '(0 . "text")
(cons 1 txt1)
(cons 40 ht)
(cons 41 1)
(cons 7 ty)
(cons 62 7)
)
)
)
)
;字高ht，字宽高比1，可以自己设置，字体为当前字体
(setq kd2 (caadr (textbox (list '(0 . "text")
(cons 1 txt2)
(cons 40 ht)
(cons 41 1)
(cons 7 ty)
(cons 62 7)
)
)
)
)
;字高ht，字宽高比1，可以自己设置，字体为当前字体
(setq kd (max kd1 kd2)
kd (+ kd (* 0.50 Scale))
)
(setq p (getpoint "\n输入基点:"))
(setq pd t)
(while pd
(setq gr (grread t 4 1)
mode (car gr)
pt (myosnap (cadr gr))
)
(if (= kd3 0)
(setq kd kd1)
)
(if (and (listp pt) (>= (car pt) (car p)))
(progn
(setq p0 (polar pt 0 kd))
(setq p1 (polar pt 0 (/ (- kd kd1) 2))
p1 (polar p1 (angtof "90") (* 0.70 Scale))
)
(setq p2 (polar pt 0 (/ (- kd kd2) 2))
p2 (polar p2 (angtof "270") (* 3.20 Scale))
)
)
)
(if (and (listp pt) (< (car pt) (car p)))
(progn
(setq p0 (polar pt pi kd))
(setq p1 (polar p0 0 (/ (- kd kd1) 2))
p1 (polar p1 (angtof "90") (* 0.70 Scale))
)
(setq p2 (polar p0 0 (/ (- kd kd2) 2))
p2 (polar p2 (angtof "270") (* 3.20 Scale))
)
)
)
(if (= mode 5)
(progn
(if name1
(entdel name1)
)
(entmake (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 3)
(cons 10 p)
(cons 10 pt)
(cons 10 p0)
(cons 62 3)
)
)
(setq name1 (entlast))
(if name2
(entdel name2)
)
(entmake (list '(0 . "text")
(cons 1 txt1)
(cons 40 ht)
(cons 41 1)
(cons 10 p1)
(cons 7 ty)(cons 62 7)
)
)
;字高ht，字宽高比1，可以自己设置，字体为当前字体
(setq name2 (entlast))
(if name3
(entdel name3)
)
(if (= kd3 1)
(entmake (list '(0 . "text")
(cons 1 txt2)
(cons 40 ht)
(cons 41 1)
(cons 10 p2)
(cons 7 ty)(cons 62 7)
)
)
)
;字高ht，字宽高比1，可以自己设置，字体为当前字体
(if (= kd3 1)
(setq name3 (entlast))
)
)
(redraw)
)
(if (= mode 3)
(setq pd nil)
)
(if (or (= mode 2) (= mode 25))
(progn (setq pd nil)
(entdel name1)
(entdel name2)
(if name3
(entdel name3)
)
)
)
)
(princ)
)
(defun getdata ()
(setq txt1 (get_tile "a1"))
(setq txt2 (get_tile "a2"))
(if (= (get_tile "a3") "0")
(setq kd3 0)
(setq kd3 1)
)
(setq txtht(get_tile "a4"))
)
(defun c:bz ()
;(步骤1)建立临时对话框
(setq tempname (vl-filename-mktemp "temp.dcl")
filen (open tempname "w")
)
(foreach stream
'("bz:dialog{"
"\n label = "
动态引线标注
";"
"\n :edit_box {key = "a1"; label = "线上文字:"; width = 40 ;}"
"\n :toggle {key = "a3"; label = "增加线下文字"; value = "
0
";}"
"\n :edit_box {key = "a2"; label = "线下文字:"; width = 40; is_enabled = false;}"
"\n :edit_box {key = "a4"; label = "文字高度:"; width = 20; }"
"\n ok_cancel;}"
)
(princ stream filen)
)
(close filen)
(setq dclname tempname)
;(步骤2)加载并显示对话框
(setq dcl_re (load_dialog dclname))
(if (not (new_dialog "bz" dcl_re))
(exit)
)
;(步骤3)定义对话框控件（运用set_tile、action_tile、mode_tile、get_tile等函数）
(if txt1
(set_tile "a1" txt1)
(set_tile "a1" "动态标注")
)
(if txt2
(set_tile "a2" txt2)
(set_tile "a2" "动态标注")
)
(if kd3
(set_tile "a3" (rtos kd3))
) ;注意set_tile函数中赋值均为字符串（带双引号），就连关键词也要加上双引号。
(if (= kd3 0)
(mode_tile "a2" 1)
)
(if (= kd3 1)
(mode_tile "a2" 0)
)
(if txtht
(set_tile "a4" txtht)
(set_tile "a4" "150")
)
(action_tile
"a3"
"(if (= (get_tile "a3") "0") (mode_tile "a2" 1) (mode_tile "a2" 0))"
) ;点击时才起作用
(action_tile "accept" "(getdata)(done_dialog 1)")
(action_tile "cancel" "(done_dialog)")
;(步骤4)激活并卸载对话框，并进行对话框隐藏后的操作。
(setq std (start_dialog))
(unload_dialog dcl_re)
(vl-file-delete dclname)
(if (= std 1)
(bz)
)
(princ)
)

(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 / xpt mode osmod osmode Draftobj Size);;;修改G版函数带捕捉grread 
(redraw) 
  (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)) 
     xpt(osnap pt(apply'strcat(mapcar'(lambda(x y)(if(zerop x)""y))osmode osmod))) 
     mode(CDR(ASSOC 
      (if xpt(vl-some'(lambda(x)(if(equal xpt(cdr x)1e-8)(car x))) 
             (vl-remove'nil(mapcar'(lambda(x y / xpt)(if(zerop x)nil(if(setq xpt(osnap pt y))(cons y xpt))))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 xpt(if xpt xpt pt))mode size(VLA-GET-AUTOSNAPMARKERCOLOR Draftobj))) 
  (if xpt xpt pt)) 
(defun c:tvvt(/ e xpt) ;;选择一个圆进行移动 
  (while(setq e(ssget":E:S"'((0 . "circle")))) 
    (setq e(entget(ssname e 0))) 
    (while(/=(car(setq xpt(grread t 15 0)))3)(redraw) 
      (if(=(car xpt)5)(entmod(append e(list(cons 10(myosnap(cadr xpt))))))) 
      )) 
  ) 
 
(defun bz (/ *error* name1 name2 name3) 
    (defun *error* (msg)    ;将描述错误的字符串存入变量msg 
  (entdel name1) 
  (entdel name2) 
  (if name3 
      (entdel name3) 
  ) 
  (princ "错误: ") 
  (princ msg) 
    )          ;打印错误信息 
    
    (setq ty (getvar "TEXTSTYLE")) 
    (setq ht (atof txtht)) 
    (if (= ht 0) 
  (progn 
  (prompt "字高为0!") 
  (terpri) 
  );progn 
  );if 
    (setq Scale (/ ht 2.5)); 
    (setq kd1 (caadr (textbox (list '(0 . "text") 
            (cons 1 txt1) 
            (cons 40 ht) 
            (cons 41 1) 
            (cons 7 ty) 
            (cons 62 7) 
            ) 
         ) 
        ) 
    ) 
          ;字高ht，字宽高比1，可以自己设置，字体为当前字体 
    (setq kd2 (caadr (textbox (list '(0 . "text") 
            (cons 1 txt2) 
            (cons 40 ht) 
            (cons 41 1) 
            (cons 7 ty) 
            (cons 62 7) 
            ) 
         ) 
        ) 
    ) 
          ;字高ht，字宽高比1，可以自己设置，字体为当前字体 
    (setq kd (max kd1 kd2) 
    kd (+ kd (* 0.50 Scale)) 
    ) 
    (setq p (getpoint "\n输入基点:")) 
    (setq pd t) 
    (while pd 
  (setq gr   (grread t 4 1) 
        mode (car gr) 
        pt   (myosnap (cadr gr)) 
  ) 
  (if (= kd3 0) 
      (setq kd kd1) 
  ) 
  (if (and (listp pt) (>= (car pt) (car p))) 
      (progn 
    (setq p0 (polar pt 0 kd)) 
    (setq p1 (polar pt 0 (/ (- kd kd1) 2)) 
          p1 (polar p1 (angtof "90") (* 0.70 Scale)) 
    ) 
    (setq p2 (polar pt 0 (/ (- kd kd2) 2)) 
          p2 (polar p2 (angtof "270") (* 3.20 Scale)) 
    ) 
      ) 
  ) 
  (if (and (listp pt) (< (car pt) (car p))) 
      (progn 
    (setq p0 (polar pt pi kd)) 
    (setq p1 (polar p0 0 (/ (- kd kd1) 2)) 
          p1 (polar p1 (angtof "90") (* 0.70 Scale)) 
    ) 
    (setq p2 (polar p0 0 (/ (- kd kd2) 2)) 
          p2 (polar p2 (angtof "270") (* 3.20 Scale)) 
    ) 
      ) 
  ) 
  (if (= mode 5) 
      (progn 
    (if name1 
        (entdel name1) 
    ) 
    (entmake (list '(0 . "LWPOLYLINE") 
             '(100 . "AcDbEntity") 
             '(100 . "AcDbPolyline") 
             '(90 . 3) 
             (cons 10 p) 
             (cons 10 pt) 
             (cons 10 p0) 
             (cons 62 3) 
       ) 
    ) 
    (setq name1 (entlast)) 
    (if name2 
        (entdel name2) 
    ) 
    (entmake (list '(0 . "text") 
             (cons 1 txt1) 
             (cons 40 ht) 
             (cons 41 1) 
             (cons 10 p1) 
             (cons 7 ty)(cons 62 7) 
       ) 
    ) 
          ;字高ht，字宽高比1，可以自己设置，字体为当前字体 
    (setq name2 (entlast)) 
    (if name3 
        (entdel name3) 
    ) 
    (if (= kd3 1) 
        (entmake (list '(0 . "text") 
           (cons 1 txt2) 
           (cons 40 ht) 
           (cons 41 1) 
           (cons 10 p2) 
           (cons 7 ty)(cons 62 7) 
           ) 
        ) 
    ) 
          ;字高ht，字宽高比1，可以自己设置，字体为当前字体 
    (if (= kd3 1) 
        (setq name3 (entlast)) 
    ) 
      ) 
    (redraw) 
  ) 
  (if (= mode 3) 
      (setq pd nil) 
  ) 
  (if (or (= mode 2) (= mode 25)) 
      (progn (setq pd nil) 
       (entdel name1) 
       (entdel name2) 
       (if name3 
           (entdel name3) 
       ) 
      ) 
  ) 
    ) 
    (princ) 
) 
 
(defun getdata () 
    (setq txt1 (get_tile "a1")) 
    (setq txt2 (get_tile "a2")) 
    (if  (= (get_tile "a3") "0") 
  (setq kd3 0) 
  (setq kd3 1) 
    ) 
    (setq txtht(get_tile "a4")) 
) 
 
(defun c:bz () 
          ;(步骤1)建立临时对话框 
    (setq tempname (vl-filename-mktemp "temp.dcl") 
    filen     (open tempname "w") 
    ) 
    (foreach stream 
       '("bz:dialog{" 
         "\n  label = " 
         动态引线标注 
         ";" 
         "\n  :edit_box {key = "a1"; label = "线上文字:"; width = 40 ;}" 
         "\n  :toggle {key = "a3"; label = "增加线下文字"; value = " 
         0 
         ";}" 
         "\n  :edit_box {key = "a2"; label = "线下文字:"; width = 40; is_enabled = false;}" 
         "\n  :edit_box {key = "a4"; label = "文字高度:"; width = 20; }" 
         "\n  ok_cancel;}" 
        ) 
  (princ stream filen) 
    ) 
    (close filen) 
    (setq dclname tempname) 
          ;(步骤2)加载并显示对话框 
    (setq dcl_re (load_dialog dclname)) 
    (if  (not (new_dialog "bz" dcl_re)) 
  (exit) 
    ) 
          ;(步骤3)定义对话框控件（运用set_tile、action_tile、mode_tile、get_tile等函数） 
    (if  txt1 
  (set_tile "a1" txt1) 
  (set_tile "a1" "动态标注") 
    ) 
    (if  txt2 
  (set_tile "a2" txt2) 
  (set_tile "a2" "动态标注") 
    ) 
    (if  kd3 
  (set_tile "a3" (rtos kd3)) 
    )          ;注意set_tile函数中赋值均为字符串（带双引号），就连关键词也要加上双引号。 
    (if  (= kd3 0) 
  (mode_tile "a2" 1) 
    ) 
    (if  (= kd3 1) 
  (mode_tile "a2" 0) 
    ) 
    (if  txtht 
  (set_tile "a4" txtht) 
  (set_tile "a4" "150") 
    ) 
    (action_tile 
  "a3" 
  "(if (= (get_tile "a3") "0") (mode_tile "a2" 1) (mode_tile "a2" 0))" 
    )          ;点击时才起作用 
    (action_tile "accept" "(getdata)(done_dialog 1)") 
    (action_tile "cancel" "(done_dialog)") 
          ;(步骤4)激活并卸载对话框，并进行对话框隐藏后的操作。 
    (setq std (start_dialog)) 
    (unload_dialog dcl_re) 
    (vl-file-delete dclname) 
    (if  (= std 1) 
  (bz) 
    ) 
    (princ) 
)

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捕捉子函数应该能用了

点评

评分

本帖被以下淘专辑推荐:

本帖子中包含更多资源

点评

本帖子中包含更多资源