004 发表于 2013-1-8 17:26:17

;;;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 发表于 2013-1-8 18:54:33

到004发功力了

283528149 发表于 2019-6-15 21:47:04

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

happy336 发表于 2019-10-14 23:54:41

谢谢分享，支持
页: 1 [2]
查看完整版本: [求助]急求一个加高程点的小程序