求助关于动态标注（grread）键盘输入值

669423907

借助 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

根据你最新的代码,全面改写了你的代码,修改了很多地方,重点是不仅支持输入数字和小数点还支持退格键,好像论坛上还没有,收点明经币
不知道如何更新附件,请下载前面的,前面的是最新的.

669423907

顶起来，大师们帮帮忙啦

bluefcc1

是不是像這樣?

669423907

bluefcc1 发表于 2018-7-14 19:08
是不是像這樣?

是的，不过是想在上面的程序里改，应该是在
((= code 2)                  ; 键盘输入
            (princ "\n键盘输入=")(princ pt))
这个地方改吧？

bluefcc1

669423907 发表于 2018-7-14 19:14
是的，不过是想在上面的程序里改，应该是在
((= code 2)                  ; 键盘输入
            ( ...

上面的test.gif 不是用上面的原碼修改的。
第2點應該是從相對於第1點的方向及距離求得。

669423907

bluefcc1 发表于 2018-7-14 19:29
上面的test.gif 不是用上面的原碼修改的。
第2點應該是從相對於第1點的方向及距離求得。

是的，我想让程序可以接受键盘输入的值

bluefcc1

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

wangyonggao8

精彩，学习。。。。

namezg

我怎么不能上传附件啊，提示Server (IO) Error