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

wanhongron

只是还有个小问题，台阶从上面开始，开始点不在线上，即是没有闭合，希望从最上面开始的时候最上面闭合，最下面可不闭合，再次麻烦哥哥了。。

wanhongron

zz命令非常好，就是zz1命令麻烦再完善一下。

mmmmmm

(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 flag / BB BX DIR PT RTN VTX)
    (if        (equal flag (* 0.5 pi) 0.001)
      (setq bx (caar ptx))
      (setq bx (car (last ptx)))
    )
    (setq 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))))
              dir
            )
        rtn (append (list (cons 0 "lwpolyline")
                          (cons        100
                                "AcDbEntity"
                          )
                          (cons 100 "AcDbPolyline")
                          (cons 90 (length rtn))
                    )
                    rtn
            )
  )
  (entmake rtn)
  (princ)
)

wanhongron

MMMMM哥哥，你太有才了，也很细心，非常谢谢。

keleke85

需要这个插件，实用

czb203

这个非常好用，感谢nnnnnnnnnn兄

彳余

这个非常好用