[求助]急求一个加高程点的小程序

004

;;;201107311130wkq004@qq.com
(defun c:tt ()
  (setvar "osmode" 512)
  (command "layer" "s" "gcd" "")
  (setq p1 (getpoint "\n请输入点位置:"))
  (setq p2 (getpoint "\n请输入点位置:"))
  (setq a1 (caddr p1))
  (setq a2 (caddr p2))
;;;  (setq a3 (/ (- a1 a2) 2))
;;;  (setq a4 (- (caddr p1) a3))
  (setq s1 (distance p1 p2))
  (setvar "osmode" 0)
  (setvar "thickness" 1610000)
  (setq xh 1)
  (while (= 1 xh)
    (setq TMP  (grread T 15 1)
          MODE (car TMP)
          val  (cadr TMP)
    )
    (redraw)
    (cond
      ((= 5 MODE)
       (progn
         (grdraw p1 val -1)
         (grdraw p2 val -1)
         (grdraw p1 p2 -1)
       )
      )
      ((= 3 MODE)
       (progn
         (setq val (list (car val) (cadr val)))
         (setq ang1 (abs (- (atof (angtos (angle p1 val) 0 4))
                            (atof (angtos (angle p1 p2) 0 4))
                         )
                    )
         )
         (if (> ang1 180)
           (setq ang1 (- 360 ang1))
         )

         (setq ang2 (abs (- (atof (angtos (angle p2 val) 0 4))
                            (atof (angtos (angle p2 p1) 0 4))
                         )
                    )
         )
         (if (> ang2 180)
           (setq ang2 (- 360 ang2))
         )
         (if (< (+ ang1 ang2) 90)
           (progn
             (redraw)
             (setq
               dist1 (* (cos (* pi (/ ang1 180.0))) (distance p1 val))
             )
             (if (> a1 a2)
               (setq bili+- -1)
               (setq bili+- 1)
             )
             (setq gaocheng
                    (+ a1
                       (* bili+- (/ dist1 (distance p1 p2)) (abs (- a1 a2)))
                    )
             )
             (setq ptz (append val (list gaoCheng)))
;;;             (setq p4 (subst gaocheng a1 val))
             (setq text (rtos gaocheng 2 1))
;;;             (setq p5 (list (+ (car p4) 1) (nth 1 p4) gaocheng))
;;;             (command "point" p4)
;;;             (command "text" p5 "2.0" "" text)

             (entmake (list (cons 0 "POINT")
                            (cons 10 ptz)
                      )
             )
             (entmake
               (list (cons 0 "TEXT")
                     (cons 1 text)
                     (cons 10 ptz)
                     (cons 40 2.0)
;;;                     (cons 73 2)
               )
             )
             (setq xh 0)
           )
         )
       )
      )
      ((= 25 MODE)
       ;;右击
       (progn
         (redraw)
         (setq xh 0)
       )
      )
    )
  )
  (setvar "thickness" 0)
  (command "layer" "s" "0" "")
  (princ)
)

gzxl

到004发功力了

283528149

兄弟，也给小弟发一份吧，先谢谢了  283528149@qq.com

happy336

谢谢分享，支持