[LISP程序]：鼠标拖动程序例二--鼠标动态拖拽绘制阶梯轴

lsjjm

鼠标拖动程序例二--鼠标动态拖拽绘制阶梯轴
[PHP]
(defun c:test (/ pd ec)
  ;(load "lsplib")
  (setq p0 (getpoint "\nPick Start Point: "))
  (setq x0 (car p0) y0 (cadr p0))
  (setq loop T)
  (while loop
    (if pd
      (setq pd (getpoint "\nPick Second Point: "))
      (setq pd (polar p0 (- (/ pi 6)) 1))
    )
    (if (> (car pd) x0)
      (progn
        ;(mlayer "cline" 2 "center2")
        (if (null ec)
          (progn
            (command "line" (polar p0 pi 0.2)(list (+ (car pd) 0.2)(cadr p0)) "")
               (setq ec (entget (entlast)))
          )
        )
        ;(mlayer "ex" 1 "continuous")
        (command "line" (list x0 (cadr pd))(list x0 (- (* 2 y0)(cadr pd))) "")
        (setq e1 (entget (entlast)))
        (command "line" (list x0 (- (* 2 y0)(cadr pd)))(list (car pd)(- (* 2 y0)(cadr pd))) "")
        (setq e2 (entget (entlast)))
        (command "line" (list (car pd) (- (* 2 y0)(cadr pd))) pd "")
        (setq e3 (entget (entlast)))
        (command "line" pd (list x0 (cadr pd)) "")
        (setq e4 (entget (entlast)))
        (setq pn T)
      )
      (setq loop nil)
    )
    (while pn
      (setq p (grread T)
           x1 (car (cadr p))
           y1 (cadr (cadr p)))
      (if (and (= (car p) 3)(<= x1 x0))(setq pn nil q nil))
      (if (> x1 x0)
        (progn
          (setq y2 (- (* y0 2) y1))
          (grtext -1 (strcat "d=" (rtos (- y2 y1) 2 2) "l=" (rtos (- x1 x0) 2 2)))
          (setq p1 (list x0 y1))
          (setq p2 (list x0 y2))
          (setq p3 (list x1 y2))
                (entmod (subst (list 11 (+ x1 0.3) y0)(assoc 11 ec) ec))
          (entmod (setq e1 (subst (list 10 x0 y1)(assoc 10 e1) e1)))
          (entmod (setq e1 (subst (list 11 x0 y2)(assoc 11 e1) e1)))
            (setq e2 (subst (list 10 x0 y2)(assoc 10 e2) e2))
          (setq e2 (subst (list 11 x1 y2)(assoc 11 e2) e2))
            (entmod e2)
          (setq e3 (subst (list 10 x1 y2)(assoc 10 e3) e3))
          (setq e3 (subst (list 11 x1 y1)(assoc 11 e3) e3))
          (entmod e3)
          (setq e4 (subst (list 10 x1 y1)(assoc 10 e4) e4))
          (setq e4 (subst (list 11 x0 y1)(assoc 11 e4) e4))
          (entmod e4)
        )
      )
      (if (= (car p) 3)(setq pn nil))
    )
    ;(mlayer "dim" 4 "continuous")
    (if (> x1 x0)
      (progn
          (command "dim" "ver" p1 p2 (list (- (car p1) 1)(+ y0 (/ (- y2 y1) 4)))(strcat "%%c" (rtos (- y2 y1) 2 2))
                 "hor" p2 p3 (list (+ (car p2)(/ (- x1 x0) 2))(+ (cadr p3) 0.5))(rtos (- x1 x0) 2 2) "exit")
        (setq x0 x1)
      )
    )
  )
)
[/PHP]

陌生人

有待改进，效果不是很理想，要一个个点效率不高。或者我不会用？
最好做个步骤说明or演示

lsjjm

最初由 陌生人 发布
[B]...要一个个点效率不高...[/B]

绘制图形(阶梯轴)有很多方法. 要想不一个个地点可以呀!---参考参数设计.
本题讨论的是 "动态拖拽" !!!

lhj743

不好均匀的控制！
不是很方便！

aeo

用过revit没
那才牛.
不过那个"过程"我们可以模仿