多段线面积标高到TXT，自娱自乐
(defun vxs (e / i v lst)(setq i 0)
(while
(setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst (cons v lst))
)
(reverse lst))
;;;;;;;;;;;;;;;
(defun 38zu ( e / e)
(cdr(assoc 38(entget e)))
)
(defun c:tt11 ( / lst ent pts pt demj zmj ffn ff) ;标记三角网表面积
(setq lst (ssget '( (0 . "*polyline") (8 . "S-CAP")) ) )
(setq i 0)
(setq zmj 0.000)
(setq ffn (getfiled "选取/建立数据导出文件" "" "txt" 1))
(setq ff (open ffn "w"))
(while(< i (sslength lst))
(setq ent (ssname lst i))
(setq pts (vxs ent))
(setq len (length pts))
(setq pt (mapcar
'(lambda(x)
(/ x len)
)
(apply
'mapcar
(cons '+ pts)
)
)
)
(setq AcadObject (vlax-get-acad-object)
AcadDocument (vla-get-ActiveDocument Acadobject)
mSpace (vla-get-ModelSpace Acaddocument)) ;初始化系统
(setq demj (vlax-curve-getArea(vlax-ename->vla-object ent)))
(entmake (list (cons 0"TEXT") (cons 1 (rtos (+ i 1) 2 0)) (cons 10 (polar pt (* 0.5 pi) 0.5))
(cons 40 0.3)
(cons 8 "三角网表面积")
))
(entmake (list (cons 0"TEXT") (cons 1 (strcat "面积"(rtos demj 2 3))) (cons 10 pt)
(cons 40 0.3)
(cons 8 "三角网表面积")
))
(entmake (list (cons 0"TEXT") (cons 1 (strcat "深度"(rtos (38zu ent) 2 3) )) (cons 10 (polar pt (* 1.5 pi) 0.5))
(cons 40 0.3)
(cons 8 "三角网表面积")
))
(princ (strcat (rtos (+ i 1) 2 0)","(rtos demj 2 3) "," (rtos (38zu ent) 2 3) "\n"
) ff)
;(setq zmj(+ zmj demj))
(setq i (+ i 1))
)
(close ff)
(princ)
)
感谢分享程序!!!!! 感谢分享程序!!!!! (mapcar 'cdr (vl-remove-if-not'(LAMBDA (A1)(equal 10 (car a1)) )(entget (car(entsel)))) )
页:
[1]