长度与面积测量并标注

nyistjz

自己根据论坛里朋友提供的学习资料，修改的长度与面积测量，如附件，喜欢对大家有所帮忙。

;;长度面积统计: T
;;计量结算标注: TT
;;长度统计:  TG
;;面积统计:  GT



修改版本，在十楼！

nyistjz

;修改了一下，增加了标注的相应图层及文字样式



;;============================
;;长度面积统计: T
;;计量结算标注: TT
;;长度统计:  TG
;;面积统计:  GT

;;=============================
;长度面积统计，选择测算数据不能局部函数，无法擦除
(defun caleachone();测量当前元素长度与面积
        (setq dis (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj)))
        (setq area (vl-catch-all-apply 'vlax-curve-getArea (list obj)))
)
(defun Total-count(/ ename i n obj);长度面积统计
  (vl-load-com)
        (setvar "cmdecho" 0)
  (setq
                n (sslength ss)
                i 0
                totalarea 0
                totlength 0
        )
  (repeat n
    (setq ename (ssname ss i))
    (setq obj (vlax-ename->vla-object ename))
    (caleachone)
                (setq totlength (+ dis totlength))
                (setq totalarea (+ area totalarea))
    (setq i (1+ i))
                (if (or (= L 1)(= S 1))
                        (princ (strcat "\n第" (itoa i) "个图元"))
                )
                (if (= L 1)
                        (princ (strcat ", 长度=" (rtos dis 2 3)  "mm"))
                )
                (if (= S 1)
                        (if (/= area 0.0)
                                (princ (strcat ", 面积=" (rtos area 2 3) "mm2"))
                                (princ (strcat ", 无面积属性!"))
                        )
                )
  )
  (princ "\n****默认绘图比例1:1，以mm为单位****")
        (princ (strcat "\n>>>>>共统计了" (itoa n) "个"))
        (setq totlength (strcat "，累计长度=" (rtos (/ totlength 1e3) 2 3) "m"))
        (setq totalarea (strcat "，累计面积=" (rtos (/ totalarea 1e6) 2 3) "m2"))
        (setvar "cmdecho" 1)
  (princ)
)
(defun c:T(/ l s ss);长度面积统计
        (princ "-->长度与面积统计")
        (setq ss (ssget '((0 . "CIRCLE,ELLIPSE,*POLYLINE,SPLINE,ARC,LINE"))))
        (setq L 0 S 0)
        (Total-count)
        (princ(strcat totlength totalarea))
        (princ)
)
(defun c:tg(/ l s ss);长度统计
        (princ "-->长度统计")
        (setq ss (ssget '((0 . "CIRCLE,ELLIPSE,*POLYLINE,SPLINE,ARC,LINE"))))
        (setq L 1 S 0)
        (Total-count)
        (princ totlength)
        (princ)
)
(defun c:gt(/ l s ss);面积统计
        (princ "-->面积统计")
        (setq ss (ssget '((0 . "CIRCLE,ELLIPSE,*POLYLINE"))))
        (setq L 0 S 1)
        (Total-count)
        (princ totalarea)
        (princ)
)

;周长与面积图形标注
(defun c:tt (/ calname caltextlabel ename htext_max htext_mini i n obj olay oldstyle pt pt2 ss thestring)
        (defun caltextlabel(thestring Htext Value / *doc* textobj)
                (setq *doc* (vla-get-ActiveDocument (vlax-get-acad-object)))
                (setq textobj (vla-addtext
                                                                                (vla-get-Modelspace *doc*)
                                                                                thestring
                                                                                (vlax-3d-point pt)
                                                                                Htext
                                                                        )
                )
                (vla-put-Alignment textobj Value)
                (vla-put-TextAlignmentPoint textobj pt2)
        )
        (vl-load-com)
        (setvar "cmdecho" 0)
        (setq ss (ssget '((0 . "CIRCLE,ELLIPSE,*POLYLINE,SPLINE,ARC,LINE"))))
        (setq
                n (sslength ss)
                i 0
        )
        ;算量辅助标注名
        (setq calname "LB_算量辅助标注")
        ;创建沿线文字专用样式
        (setq olay (getvar "clayer"))
        (if (= (tblobjname "layer" calname) nil)
    (vl-cmdf "Layer" "new" calname "color" "63" calname "" )
  )
        (setvar "clayer" calname)
        ;创建沿线文字专用样式
        (setq oldstyle (getvar "TEXTSTYLE"));当前文字样式
  (if (= (tblobjname "STYLE" calname) nil)
    (vl-cmdf "style" calname "tssdeng.shx,hztxt.shx" "0.0" "0.7" "" "" "" "")
                (setvar "TEXTSTYLE" calname)
  )
        ;设置标注字体高度
        (setq
                Htext_max 120
                Htext_mini 75
        )
        ;开始计算并标注
        (if ss
                (progn
                        (repeat n
                                (setq ename (ssname ss i))
                                (setq obj (vlax-ename->vla-object ename))
                                (vla-GetBoundingBox obj 'minpt 'maxpt)
                                (setq pt (mapcar '(lambda (x) (/ x 2.0))
                                                                         (mapcar '+
                                                                                 (vlax-safearray->list minpt)
                                                                                 (vlax-safearray->list maxpt)
                                                                         )
                                                                 )
                                )
                                (setq pt2 (vlax-make-safearray vlax-vbDouble '(0 . 2)))
                                (vlax-safearray-fill pt2 pt)
                                (caleachone)
                                (cond
                                        ((> (/ area 1000000) 0.3)
                                                (setq thestring (strcat "S=" (rtos (/ area 1000000) 2 2) "m2"))
                                                (caltextlabel thestring Htext_max acAlignmentBottomCenter)
                                                (setq thestring (strcat "L=" (rtos (/ dis 1e3) 2 2) "m"))
                                                (caltextlabel thestring Htext_max acAlignmentTopCenter)
                                        )
                                        ((> (/ area 1000000) 0)
                                                (setq thestring (strcat "S=" (rtos (/ area 1000000) 2 2) "m2"))
                                                (caltextlabel thestring Htext_mini acAlignmentBottomCenter)
                                                (setq thestring (strcat "L=" (rtos (/ dis 1e3) 2 2) "m"))
                                                (caltextlabel thestring Htext_mini acAlignmentTopCenter)
                                        )
                                        ((= (/ area 1000000) 0)
                                                (setq thestring (strcat "L=" (rtos (/ dis 1e3) 2 2) "m"))
                                                (caltextlabel thestring Htext_max acAlignmentMiddleCenter)
                                        )
                                        (t nil)
                                )
                                (setq i (1+ i))
                        )
                )
        )
        (setvar "clayer" olay)
        (setvar "TEXTSTYLE" oldstyle)
        (setvar "cmdecho" 1)
        (princ "\n****默认绘图比例1:1，以mm为单位，实际如果不同，则标注结果错误！！！****")
        (princ)
)


(princ)

nyistjz

664571221 发表于 2021-5-28 15:15
兄弟 线的长度可不可以标注一下呀

;;============================
;;长度面积统计: T
;;计量结算标注: TT
;;长度统计:  TG
;;面积统计:  GT
;;连续测距:  DT
;;文字求和:  TS
;;=============================
;长度面积统计，选择测算数据不能局部函数，无法擦除
(defun caleachone();测量当前元素长度与面积
        (setq dis (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj)))
        (setq area (vl-catch-all-apply 'vlax-curve-getArea (list obj)))
)
(defun Total-count(/ ename i n obj);长度面积统计
  (vl-load-com)
  (setq
                n (sslength ss)
                i 0
                totalarea 0
                totlength 0
        )
  (repeat n
    (setq ename (ssname ss i))
    (setq obj (vlax-ename->vla-object ename))
    (caleachone)
                (setq totlength (+ dis totlength))
                (setq totalarea (+ area totalarea))
    (setq i (1+ i))
  )
  (princ "\n****默认绘图比例1:1，以mm为单位****")
        (princ (strcat "\n>>>>>共统计了" (itoa n) "个"))
        (setq totlength (strcat "，累计长度=" (rtos (/ totlength 1e3) 2 3) "m"))
        (setq totalarea (strcat "，累计面积=" (rtos (/ totalarea 1e6) 2 3) "m2"))
  (princ)
)
(defun c:T(/ ss);长度面积统计
        (princ "-->长度与面积统计")
        (setq ss (ssget '((0 . "CIRCLE,ELLIPSE,*POLYLINE,SPLINE,ARC,LINE"))))
        (Total-count)
        (princ(strcat totlength totalarea))
        (princ)
)
(defun c:tg(/ ss);长度统计
        (princ "-->长度统计")
        (setq ss (ssget '((0 . "CIRCLE,ELLIPSE,*POLYLINE,SPLINE,ARC,LINE"))))
        (Total-count)
        (princ totlength)
        (princ)
)
(defun c:gt(/ ss);面积统计
        (princ "-->面积统计")
        (setq ss (ssget '((0 . "CIRCLE,ELLIPSE,*POLYLINE"))))
        (Total-count)
        (princ totalarea)
        (princ)
)

;周长与面积图形标注
(defun c:tt (/ caltextlabel ename i n obj pt pt2 ss thestring)
        (defun caltextlabel(thestring Htext Value / textobj)
                (setq textobj (vla-addtext
                                                                                (vla-get-Modelspace (vla-get-activeDocument (vlax-get-acad-object)))
                                                                                thestring
                                                                                (vlax-3d-point pt)
                                                                                Htext
                                                                        )
                )
                (vla-put-Alignment textobj Value)
                (vla-put-TextAlignmentPoint textobj pt2)
        )
        (vl-load-com)
        (setq ss (ssget '((0 . "CIRCLE,ELLIPSE,*POLYLINE,SPLINE,ARC,LINE"))))
        (setq
                n (sslength ss)
                i 0
        )
        (if ss
                (progn
                        (repeat n
                                (setq ename (ssname ss i))
                                (setq obj (vlax-ename->vla-object ename))
                                (vla-GetBoundingBox obj 'minpt 'maxpt)
                                (setq pt (mapcar '(lambda (x) (/ x 2.0))
                                                                         (mapcar '+
                                                                                 (vlax-safearray->list minpt)
                                                                                 (vlax-safearray->list maxpt)
                                                                         )
                                                                 )
                                )
                                (setq pt2 (vlax-make-safearray vlax-vbDouble '(0 . 2)))
                                (vlax-safearray-fill pt2 pt)
                                (caleachone)
                                (cond
                                        ((> (/ area 1000000) 0.3)
                                                (setq thestring (strcat "S=" (rtos (/ area 1000000) 2 2) "m2"))
                                                (caltextlabel thestring 200 acAlignmentBottomCenter)
                                                (setq thestring (strcat "L=" (rtos (/ dis 1e3) 2 2) "m"))
                                                (caltextlabel thestring 200 acAlignmentTopCenter)
                                        )
                                        ((> (/ area 1000000) 0)
                                                (setq thestring (strcat "S=" (rtos (/ area 1000000) 2 2) "m2"))
                                                (caltextlabel thestring 75 acAlignmentBottomCenter)
                                                (setq thestring (strcat "L=" (rtos (/ dis 1e3) 2 2) "m"))
                                                (caltextlabel thestring 75 acAlignmentTopCenter)
                                        )
                                        ((= (/ area 1000000) 0)
                                                (setq thestring (strcat "L=" (rtos (/ dis 1e3) 2 2) "m"))
                                                (caltextlabel thestring 120 acAlignmentBottomCenter)
                                        )
                                        (t nil)
                                )
                                (setq i (1+ i))
                        )
                )
        )
        (princ "\n****默认绘图比例1:1，以mm为单位，实际如果不同，则标注结果错误！！！****")
        (princ)
)

664571221

兄弟 线的长度可不可以标注一下呀

lxl217114

挺好使的，感谢分享

lxl217114

nyistjz 发表于 2021-5-28 15:42
;;============================
;;长度面积统计: T
;;计量结算标注: TT

;;连续测距:  DT
;;文字求和:  TS
请教下楼主DT和TS怎么修改启动命令和天正的（电梯）和（表格样式）冲突了

paulpipi

挺好使的，感谢分享

nyistjz

lxl217114 发表于 2021-5-29 10:25
;;连续测距:  DT
;;文字求和:  TS
请教下楼主DT和TS怎么修改启动命令和天正的（电梯）和（表格样式）冲 ...

你有没有试试操作一下？

lxl217114

nyistjz 发表于 2021-5-30 21:54
你有没有试试操作一下？

其他的4个命令都找的到修改命令的行，这两个没有找到

w379106181

挺好使的，感谢分享