wanhongron 发表于 2012-7-10 22:54:16

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

wanhongron 发表于 2012-7-10 22:57:25

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

mmmmmm 发表于 2012-7-11 10:15:01

(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 发表于 2012-7-12 00:25:09

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

keleke85 发表于 2019-11-26 11:17:11

需要这个插件,实用

czb203 发表于 2020-2-28 09:13:39

这个非常好用,感谢nnnnnnnnnn兄

彳余 发表于 2020-2-29 13:31:26

这个非常好用
页: 1 2 [3]
查看完整版本: ★边坡台阶自动开挖程序求实现