根据坡比划线并标注

sandyvs

网上找的程序，划线并标注坡比。


(defun c:PD  ( / bd ang stp enp p1 gr p0)
   (vl-load-com)
   (setvar "DYNMODE" 0)
   (setvar "nomutt" 0)
   (setq SCALE (GETVAR "DIMSCALE"))
    (setq DIMHEIGHT 2.5)
   (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))
(setq aa (abs aa))
   (entmake (list '(0 . "TEXT")
                  (cons 40 (* SCALE DIMHEIGHT))
                  (cons 41 0.85)
                  (cons 1 (strcat "1:" (if (eq aa (fix aa))(rtos aa 2 0) (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))

sandyvs

sandyvs 发表于 2023-1-17 10:31
额，不会编程，我把strcat那加了绝对值，结果不输出了。。

加在文字之前就可以了

(defun c:PD  ( / bd ang stp enp p1 gr p0)
   (vl-load-com)
   (setvar "DYNMODE" 0)
   (setvar "nomutt" 0)
   (setq SCALE (GETVAR "DIMSCALE"))
    (setq DIMHEIGHT 2.5)
   (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))
   (setq aa (abs aa))
   (entmake (list '(0 . "TEXT")
                  (cons 40 (* SCALE DIMHEIGHT))
                  (cons 41 0.85)
                  (cons 1 (strcat "1:" (if (eq aa (fix aa))(rtos aa 2 0) (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))

sandyvs

自贡黄明儒 发表于 2023-1-17 10:10
(setq aa bd))后面加一句(setq aa (abs aa))试试。

不行呀黄老师，正的是往左坡，负的是往右坡，改成正的之后就不能往右画坡了，我是想怎么把标注那改成正的

sandyvs

自贡黄明儒 发表于 2023-1-17 10:28
根据角度判断一下，正的加abs

额，不会编程，我把strcat那加了绝对值，结果不输出了。。

自贡黄明儒

(setq aa bd))后面加一句(setq aa (abs aa))试试。

自贡黄明儒

sandyvs 发表于 2023-1-17 10:26
不行呀黄老师，正的是往左坡，负的是往右坡，

根据角度判断一下，正的加abs

tigcat

sandyvs

tigcat 发表于 2023-1-17 11:30

感谢回复，应该不用判断是否小于0，反正要标的都是正的

tigcat

sandyvs 发表于 2023-1-17 11:56
感谢回复，应该不用判断是否小于0，反正要标的都是正的

的确不用判断

中国梦

支持一下看看