画指定坡度线程序 优化

read2line

**老师，2015.01.28 写的画指定坡比线的程序很好用，对我自身而言，有部分功能不适合，想简化掉，详情论坛里的大大帮我改进下，十分感谢！
需求：
1、指定1：m 的坡比，不需要X%的坡比标注。
2、输入坡比后，若ESC取消的话，snapang 默认不为0了，是个小BUG。
3、如若可能的话，能否增加“已知斜线的坡比标注”？我需要的是“1：x”这种标注。


附 何老师的源代码

(defun c:xieLine()
  (initget "1 2")
  (setq a (getstring"\n输入坡度度量型式[(1:X)->1]or[(X%)->2]<1>"))
  (if (= a "") (setq a "1"))
    (if (= a "1")
      (xieline1)
      (if (= a "2")
          (xieline2)
      )
    )
)
(defun xieLine1(/ aa ps)
  (setvar "orthomode" 1)
  (setq aa (getstring "\n输入坡度<1:X>："))
  (setq aa1 (atof aa))
  (setq aa1 (/ 1 aa1))
  (setq aa1 (atan aa1))
  (setvar "snapang" aa1)
  (setq ps (getpoint"\n输入起点："))
  (command "line" ps pause)
  (setvar "snapang" 0)
  (setq ss (strcat "\n已按1:" aa "的坡度绘制了一条直线"))
  (princ ss)
  (prin1)
)
(defun xieLine2(/ aa ps)
  (setvar "orthomode" 1)
  (setq aa (getstring "\n输入坡度<X%>："))
  (setq aa1 (atof aa))
  (setq aa1 (/ aa1 100))
  (setq aa1 (atan aa1))
  (setvar "snapang" aa1)
  (setq ps (getpoint"\n输入起点："))
  (command "line" ps pause)
  (setvar "snapang" 0)
  (setq ss (strcat "\n已按" aa "%的坡度绘制了一条直线"))
  (princ ss)
  (prin1)
)
(prompt "按给定坡值绘制直线，在命令行输入PD按提示操作即可，编程：**，2015.01.28")

pxr201419

试试这个，中途任意时间按esc取消，拾取起点后按鼠标左键或右键或按键盘任意非功能键均可完成任务
(defun c:TT  ( / bd ang stp enp p1 gr p0)
   (vl-load-com)
   (setvar "nomutt" 1)
   (defun gxl-error  (fun)
      (setq *olderror* *error*
            *Function* fun)
      (defun *error*  (msg)
         (if *Function*
            (VL-CATCH-ALL-APPLY *Function*))
         (setq *error* *olderror*
               *olderror* nil
               *Function* nil))
      (princ))
   (defun re () (setvar "nomutt" 0) (redraw))
   (gxl-error 're)
   (if (= aa nil)(setq aa 1))
   (if (null (setq bd (getreal (strcat "输入坡度 1: <" (vl-princ-to-string aa) ">" ))))
      (setq aa aa)
      (setq aa bd))
   (setq ang (atan (/ 1 aa)))
   (setq stp (getpoint "\n输入或拾取起点："))
   (setq p1 (polar stp ang 1e2))
   (while (not (member (car (setq gr (grread t 13 0))) '(2 3 25)))
      (redraw)
      (setq p0 (polar (cadr gr) (+ ang (/ pi 2)) 1e2))
      (setq enp (inters stp p1 p0 (cadr gr) nil))
      (grvecs (list -3 stp enp)))
   (entmake (list '(0 . "LINE") (cons 10 stp) (cons 11 enp)))
   (setq mip (mapcar '(lambda (x y) (/ (+ x y) 2)) stp enp))
   (entmake (list '(0 . "TEXT")
                  (cons 40 (/ (distance stp enp) 20))
                  (cons 1 (strcat "1:" (if (eq aa (fix aa))(rtos aa) (vl-princ-to-string aa))))
                  (cons 10 mip)
                  (cons 50 ang)
                  '(72 . 1)
                  (cons 11 mip)))
   (vla-put-Alignment (vlax-ename->vla-object (entlast)) 13)
   (redraw)
   (setvar "nomutt" 0)
   (princ))

read2line

pxr201419 发表于 2020-2-28 09:38
试试这个，中途任意时间按esc取消，拾取起点后按鼠标左键或右键或按键盘任意非功能键均可完成任务
(defun  ...

这个跟我想要的差不多了，感谢大佬
不过这个有部分问题，输入TT后，不提示“输入坡度 1: <”   需要直接输入，无任何提示

这个部分能否给予改进？万分感谢

read2line

pxr201419 发表于 2020-2-28 09:38
试试这个，中途任意时间按esc取消，拾取起点后按鼠标左键或右键或按键盘任意非功能键均可完成任务
(defun  ...

我搞错了，您弄的是动态输入，我想弄到命令栏  

pxr201419

read2line 发表于 2020-2-28 14:24
我搞错了，您弄的是动态输入，我想弄到命令栏

看了下，你的界面DYN那里处于关闭状态，
在第2行和第3行间加入下面这句
(setvar "DYNMODE" 1)
运行命令时光标处会有提示的，就不必去看命令行了

read2line

pxr201419 发表于 2020-2-28 15:12
看了下，你的界面DYN那里处于关闭状态，
在第2行和第3行间加入下面这句
(setvar "DYNMODE" 1)

嗯嗯，因为我个人习惯了命令行，所以DYN开着感觉不方便，不知道您能否帮我调整下？感谢感谢

pxr201419

你的意思是命令行要提示“输入坡度....."?

read2line

pxr201419 发表于 2020-2-28 15:39
你的意思是命令行要提示“输入坡度....."?

嗯嗯，就是这个意思

read2line

pxr201419 发表于 2020-2-28 15:39
你的意思是命令行要提示“输入坡度....."?

我按下面这个，结合您的，我试着自己改，改不出来，没基础  ，后面空了自己得好好学习下

(defun c:PD()
   (setvar "orthomode" 1)
  (setq aa (getstring "\n输入坡度1:m<m>："))
  (setq aa1 (atof aa))
  (setq aa1 (/ 1 aa1))
  (setq aa1 (atan aa1))
  (setvar "snapang" aa1)
  (setq ps (getpoint"\n输入起点："))
  (command "line" ps pause)
  (setvar "snapang" 0)
  (setq ss (strcat "\n已按1:" aa "的坡度绘制了一条直线"))
  (princ ss)
  (prin1)
)

pxr201419

(defun c:TT  ( / bd ang stp enp p1 gr p0)
   (vl-load-com)
   (setvar "DYNMODE" 0)
   (setvar "nomutt" 0)
   (defun gxl-error  (fun)
      (setq *olderror* *error*
            *Function* fun)
      (defun *error*  (msg)
         (if *Function*
            (VL-CATCH-ALL-APPLY *Function*))
         (setq *error* *olderror*
               *olderror* nil
               *Function* nil))
      (princ))
   (defun re () (setvar "nomutt" 0) (redraw))
   (gxl-error 're)
   (if (= aa nil)(setq aa 1))
   (if (null (setq bd (getreal (strcat "\n输入坡度 1: <" (vl-princ-to-string aa) ">" ))))
      (setq aa aa)
      (setq aa bd))
   (setvar "DYNMODE" 1)
   (setq ang (atan (/ 1 aa)))
   (setq stp (getpoint "\n输入或拾取起点："))
   (setq p1 (polar stp ang 1e2))
   (while (not (member (car (setq gr (grread t 13 0))) '(2 3 25)))
      (redraw)
      (setq p0 (polar (cadr gr) (+ ang (/ pi 2)) 1e2))
      (setq enp (inters stp p1 p0 (cadr gr) nil))
      (grvecs (list -3 stp enp)))
   (entmake (list '(0 . "LINE") (cons 10 stp) (cons 11 enp)))
   (setq mip (mapcar '(lambda (x y) (/ (+ x y) 2)) stp enp))
   (entmake (list '(0 . "TEXT")
                  (cons 40 (/ (distance stp enp) 20))
                  (cons 1 (strcat "1:" (if (eq aa (fix aa))(rtos aa) (vl-princ-to-string aa))))
                  (cons 10 mip)
                  (cons 50 ang)
                  '(72 . 1)
                  (cons 11 mip)))
   (vla-put-Alignment (vlax-ename->vla-object (entlast)) 13)
   (redraw)
   (princ))

read2line

pxr201419 发表于 2020-2-28 15:48
(defun c:TT  ( / bd ang stp enp p1 gr p0)
   (vl-load-com)
   (setvar "DYNMODE" 0)

非常感谢，

杨张张

学习一下，看看大神之作

sandyvs

pxr201419 发表于 2020-2-28 15:48
(defun c:TT  ( / bd ang stp enp p1 gr p0)
   (vl-load-com)
   (setvar "DYNMODE" 0)

您好，输入负数，标注也是负数，标注想要正的怎么办？

pxr201419

sandyvs 发表于 2023-1-16 17:21
您好，输入负数，标注也是负数，标注想要正的怎么办？

(cons 1 (strcat "1:" (vl-princ-to-string (abs aa))))

sandyvs

pxr201419 发表于 2023-1-20 10:56
(cons 1 (strcat "1:" (vl-princ-to-string (abs aa))))

感谢回复！我在创建文字前面加了 (setq aa (abs aa))，也可以