等高线计算土方，必须封闭
本帖最后由 树櫴希德 于 2023-6-4 22:50 编辑等高线计算土方，必须封闭
( defun c:dgxtf (/ lst lst1 dgj pt pzx pzx1 mj mj1 tj )
(vl-load-com)
(alert "本图按照毫米为单位计算等高线土方")
(setq dgj (getreal "\n请输入等高距毫米："))
(prompt "\n请选择低的一组等高线")
(setq lst (ssget '((0 . "LWPOLYLINE,SPLINE") ) ))
(prompt "\n请选择高的一组等高线")
(setq lst1 (ssget '((0 . "LWPOLYLINE,SPLINE") ) ))
(setq pt(getpoint "\n请点击体积标注位置："))
;选择集与对象名表互转
(defun cx-ss2en
(ss / enlst)
(cond
((= (type ss) 'PICKSET)
(vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
)
((= (type ss) 'LIST)
(setq enlst (ssadd))
(last (mapcar '(lambda (x) (ssadd x enlst)) ss))
)
((='ename(type ss))
(ssadd ss)
)
)
)
;(entget(car(entsel))'("*"))
(setq pzx 0)
(foreach x (cx-ss2en lst)
(setq mj (vlax-curve-getArea (vlax-ename->vla-object x)) ) ;;;;
(setq pzx (+ mj pzx))
(vla-put-color (vlax-ename->vla-object x) 20)
)
(setq pzx1 0)
(foreach y (cx-ss2en lst1)
(setq mj1 (vlax-curve-getArea (vlax-ename->vla-object y)) ) ;;;;
(setq pzx1 (+ mj1 pzx1))
(vla-put-color (vlax-ename->vla-object y) 223)
)
(setq tj (/(*(/ (+(expt (* pzx pzx1) 0.5) pzx pzx1 ) 3.0000) dgj) 1000000000.0000) )
; 6、单行文本
(entmake (list '(0 . "TEXT") (cons 1 (rtos tj 2 3)) (cons 10 pt)(cons 62 3) (cons 40 1000)))
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;
( defun c:dgxtf1 (/ lst lst1 dgj pt pzx pzx1 mj mj1 tji )
(vl-load-com)
(alert "本图按照毫米为单位计算等高线土方")
(setq dgj (getreal "\n请输入等高距毫米："))
(prompt "\n请选择一组等高线")
(setq lst (ssget '((0 . "LWPOLYLINE,SPLINE") ) ))
(setq pt(getpoint "\n请点击体积标注位置："))
(setq pzx '())
(foreach x (cx-ss2en lst)
(setq mj (vlax-curve-getArea (vlax-ename->vla-object x)) ) ;;;;
(setq pzx (append (list mj) pzx))
(vla-put-color (vlax-ename->vla-object x) 20)
) (setq pzx (vl-sort pzx '>) )
(setq i 0)
(setq pzx1 0)
(repeat (-(length pzx) 1)
(setq tj (/(*(/ (+(expt (* (nth i pzx)(nth (+ i 1) pzx) ) 0.5) (nth i pzx) (nth (+ i 1) pzx)) 3.0000) dgj) 1000000000.0000) )
(setq pzx1 (+ tj pzx1))
(setq i (1+ i))
)
(entmake (list '(0 . "TEXT") '(8 . "zxtj")(cons 1 (rtos pzx1 2 3)) (cons 10 pt)(cons 62 3) (cons 40 1000)))
(princ )
)
页:
[1]