求助关于动态标注（grread）键盘输入值
借助 langjs 大师的grread 捕捉子函数和网友惊惊帮助，还有论坛上大师们的代码，自己东拼西凑，弄了一个动态线性标注的小程序，谈不上什么实用性，只是在视觉上感觉比自带良好一下下而已。
现在的问题是：无法通过输入值来确定标注的距离，有劳大师们帮忙改进一下，
让程序可以像CAD自带的_dimlinear 一样可以通过输入值来确定标注距离
(defun c:13(/ oc ss jd ro) ;动态标注
(if (not o)(setq o (getpoint"\n请指标注起点:")))
(setq os (getvar "osmode")) ;记录捕捉
(setvar'osmode 0) ;关闭捕捉
(if (/= o nil)(command"dimlinear"o o o""))
(setq ss(ssadd) ss(ssadd(entlast)ss))
(command "delay" 100);延时(1000=1秒)
(if(member(car(grread 3))'(3 5))(setq oc(cadr(grread 3)))) ;光标位置
(setq jd (/(* (angle o oc) 180) pi)) ;两点与X轴的角度
(setq dx 14)
(if (setq ro (cond ((and(>= jd 45)(<= jd 135)) 90)
((and(>= jd 225)(<= jd 315))270)))
(if (not oo)(command"_rotate" ss "" o ro "")(command"_rotate" ss "" oo ro "") )
)
(setvar'osmode os) ;恢复捕捉模式
(ydd ss)(setq dx nil)
(if (= sc 1)(ydd ss)(command "_.erase" ss ""))
(setq o nil sc nil oo nil ss nil)
(princ))
;grread 捕捉子函数 langjs 2017-12-25 http://bbs.mjtd.com/thread-176190-1-1.html
;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:yd()(ydd (ssget ":e:s")))
(defun ydd(#s# / code ent gr loop name pt)
(cond((=(type #s#)'name) ;540762622（惊惊） 170919
(setq name #s#))((=(type #s#)'pickset)
(setq name (ssname #s# 0))))
(if name ;(setq name (car (entsel"\n请选择要移动的对象:")))
(progn
(if (not dx)(setq dx 10)) ;14标注终点
(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 sc 1)); 鼠标左键
((= code 5) ; 鼠标移动
(setq pt (osnappt name pt))
(entmod (setq ent (subst(cons dx pt)(assoc dx ent)ent))))
((= code 2) ; 键盘输入
(princ "\n键盘输入=")(princ pt))
((member code '(11 25)) ; 鼠标右击
(redraw)(setq loop nil) )))
(setq dx nil)
) )
(princ)
)
本帖最后由 namezg 于 2018-7-18 14:41 编辑
根据你最新的代码,全面改写了你的代码,修改了很多地方,重点是不仅支持输入数字和小数点还支持退格键,好像论坛上还没有,收点明经币
不知道如何更新附件,请下载前面的,前面的是最新的.
顶起来，大师们帮帮忙啦 是不是像這樣? bluefcc1 发表于 2018-7-14 19:08
是不是像這樣?
是的，不过是想在上面的程序里改，应该是在
((= code 2) ; 键盘输入
(princ "\n键盘输入=")(princ pt))
这个地方改吧？ 本帖最后由 bluefcc1 于 2018-7-14 19:33 编辑
669423907 发表于 2018-7-14 19:14
是的，不过是想在上面的程序里改，应该是在
((= code 2) ; 键盘输入
( ...
上面的test.gif 不是用上面的原碼修改的。
第2點應該是從相對於第1點的方向及距離求得。
bluefcc1 发表于 2018-7-14 19:29
上面的test.gif 不是用上面的原碼修改的。
第2點應該是從相對於第1點的方向及距離求得。
是的，我想让程序可以接受键盘输入的值 669423907 发表于 2018-7-14 19:42
是的，我想让程序可以接受键盘输入的值
(setq str "")
(while loop
(setq gr (grread t 15 0))
(setq code (car gr))
(setq pt (cadr gr))
(cond
((= code 3) ; 滑鼠左鍵
(redraw)
(setq loop nil)
(setq sc 1)
(setq pt (atof str))
)
((= code 5) ; 滑鼠移動
(setq pt (osnappt name pt))
(entmod (setq ent (subst(cons dx pt)(assoc dx ent)ent))))
((= code 2) ; 鍵盤輸入
(princ "\n鍵盤輸入=")
(setq str (strcat str (chr pt)))
(princ str)
) 精彩，学习。。。。 我怎么不能上传附件啊，提示Server (IO) Error