★边坡台阶自动开挖程序求实现

wanhongron

如果台阶高能改成手动输入就好，如可根据提示输入500或600等其他数字

xyp1964

wanhongron

院长的程序小女一般用不了，太多自定义函数了，但还是感谢院长的指点。。

xyp1964

参考效果：

wanhongron

院长的程序功能确实强大，但没有通用函数没什么用

wanhongron

请问怎样把下面的固定500改成手动输入，怎样试都不行。。
(vla-move obj
               (vlax-3d-point '(0. 0. 0))
               (vlax-3d-point '(0. 500. 0.))
     )

mmmmmm

(vla-move obj
               (vlax-3d-point '(0. 0. 0))
               (vlax-3d-point (list 0. (if (null (setq disv (getdist"\n输入垂直间距 <500>:"))) 500.0 disv) 0.))
     )

等哪天闲下来重写个满足你全部要求的函数。

wanhongron

mmmmmm大哥真是有求必应，打心里崇拜你，谢谢你的关心。。

mmmmmm

飞机上写的，没太测试，主函数应该能工作，界面交互的那部分你自己弄个就好了。

;; pl=curveobject[ename]曲线实体
;; dy=vertical distance[real]垂直分段距离
;; dir=scanning direction [T/Nil] T=LL, NIL=UR起始点方向，t=下到上；NIL=上到下
(Defun c:zz () (_DrawSect (car (entsel)) 400. T))
(Defun c:zz1 () (_DrawSect (car (entsel)) 400. nil))
(Defun _DrawSect
       (pl dy dir / _FixVertex DX EPT INT LL OBJ P1 P2 PTX RTN SPT UR VLO)
  (Defun _FixVertex (ptx / BB BX DIR PT RTN VTX)
    (setq bx  (caar ptx)
          dir (- (car (last ptx)) (caar ptx))
    )
    (foreach pt        ptx
      (setq bb (car pt)
            bb (- bb bx)
            bb (* 100 (fix (+ 0.5 (* bb 0.01))))
            bb (+ bb bx)
      )
      (if (> dir 0)
        (while (> (car pt) bb) (setq bb (+ bb 100)))
        (while (< (car pt) bb) (setq bb (- bb 100)))
      )
      (setq rtn (cons (cons bb (cdr pt)) rtn))
    )
    (setq rtn (reverse rtn)
          rtn (append rtn (list (last rtn)))
    )
    (while (cdr rtn)
      (setq pt        (car rtn)
            ptx        (cadr rtn)
            rtn        (cdr rtn)
            vtx        (cons (cons 10 pt) vtx)
            vtx        (cons (list 10 (car ptx) (cadr pt)) vtx)
      )
    )
    vtx
  )
  (setq vlo (vlax-ename->vla-object pl))
  (vla-getboundingbox vlo 'll 'ur)
  (setq        ll (trans (vlax-safearray->list ll) 0 1)
        ur (trans (vlax-safearray->list ur) 0 1)
        dx (- (car ur) (car ll))
  )
  (if dir
    (setq p1  (polar ll pi (* 0.1 dx))
          p2  (polar ll 0 (* 1.2 dx))
          dir (* 0.5 pi)
    )
    (setq p1  (polar ur 0 (* 0.1 dx))
          p2  (polar ur pi (* 1.2 dx))
          dir (* 1.5 pi)
    )
  )
  (entmake (list (cons 0 "line") (cons 10 p1) (cons 11 p2)))
  (setq obj (vlax-ename->vla-object (entlast)))
  (while
    (and
      (setq int (vla-intersectwith vlo obj acExtendNone))
      (null
        (vl-catch-all-error-p
          (vl-catch-all-apply
            '(lambda ()
               (setq
                 int (vlax-safearray->list (vlax-variant-value int))
               )
             )
          )
        )
      )
      (= (length int) 3)
    )
     (setq rtn (cons int rtn))
     (vla-move obj
               (vlax-3d-point '(0. 0. 0))
               (vlax-3d-point (polar '(0. 0. 0.) dir dy))
     )
  )
  (vla-erase obj)
  (setq        ptx (car rtn)
        spt (trans (vlax-curve-getstartpoint vlo) 0 1)
        ept (trans (vlax-curve-getendpoint vlo) 0 1)
  )
  (if (> (abs (- (cadr spt) (cadr ptx)))
         (abs (- (cadr ept) (cadr ptx)))
      )
    (setq rtn (cons ept rtn))
    (setq rtn (cons spt rtn))
  )
  (setq        rtn (_FixVertex
              (vl-sort rtn '(lambda (p1 p2) (< (cadr p1) (cadr p2))))
            )
        rtn (append (list (cons 0 "lwpolyline")
                          (cons        100
                                "AcDbEntity"
                          )
                          (cons 100 "AcDbPolyline")
                          (cons 90 (length rtn))
                    )
                    rtn
            )
  )
  (entmake rtn)
  (princ)
)

wanhongron

这两天出差，回来一看到mmmm大哥的程序好开心哦，程序非常成功，大哥辛苦了，小女不胜感激。。。