长度与面积测量并标注

nyistjz · 发表于 2021-5-28 10:10:06

本帖最后由 nyistjz 于 2021-6-4 08:17 编辑

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

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

修改版本，在十楼！

nyistjz · 发表于 2021-6-4 08:16:49

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

;;============================
;;长度面积统计: 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 · 发表于 2021-5-28 15:42:15

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 · 发表于 2021-5-28 15:15:46

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

lxl217114 · 发表于 2021-5-29 10:23:12

挺好使的，感谢分享

lxl217114 · 发表于 2021-5-29 10:25:14

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

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

paulpipi · 发表于 2021-5-29 13:15:39

挺好使的，感谢分享

nyistjz · 发表于 2021-5-30 21:54:20

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

你有没有试试操作一下？

lxl217114 · 发表于 2021-5-31 10:17:58

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

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

w379106181 · 发表于 2021-6-4 08:00:26

挺好使的，感谢分享

账号		自动登录	找回密码
密码			注册

[源码] 长度与面积测量并标注

本帖子中包含更多资源