批量为闭合图形标注面积
本帖最后由 zyx1029 于 2025-9-13 17:40 编辑之前用的面积标注插件太过于零散了，来回切换插件来查看或标注面积。
整合了一个为闭合图形批量标注面积㎡、亩、公顷、㎡合亩的插件。
非闭合图形不会被标注。
也相当于间接的检查了那些图形为非闭合图形。(defun C:BZMJ (/ *error* ss i ent obj area centroid text-height unit-choice text-layer area-mu area-hectare)
;; 错误处理函数
(defun *error* (msg)
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*,*LAYER*"))
(princ (strcat "\n错误: " msg))
)
(princ)
)
;;关闭回显
(SETVAR "CMDECHO" 0)
;; 确保"面积"图层存在(如果不存在则新建)
(if (not (tblsearch "LAYER" "面积"))
(progn
(command "._-LAYER" "M" "面积" "C" "1" "面积" "")
(princ "\n已创建'面积'图层，颜色设置为红色。")
)
(princ "\n找到'面积'图层。")
)
;; 确保宋体文字样式存在(如果不存在则新建)
(if (not (tblsearch "STYLE" "宋体"))
(progn
(command "._-STYLE" "宋体" "宋体" "0" "1" "0" "N" "N" "N")
(princ "\n已创建'宋体'文字样式。")
)
(princ "\n找到'宋体'文字样式。")
)
;; 设置变量
(setq text-height (getreal"\n请输入标注文字高度<1.0>: "))
(if (not text-height) (setq text-height 1.0)) ; 默认文字高度
;; 选择单位类型
(initget"1 2 3 4")
(setq unit-choice (getkword "\n选择标注单位 [平方米<1>/亩<2>/公顷<3>/平方米合亩<4>] <1>: "))
(if (not unit-choice) (setq unit-choice "1"))
;; 选择多段线
(princ "\n请选择闭合多段线: ")
(setq ss (ssget '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1)))) ; 只选择闭合多段线
(if ss
(progn
(setq i 0)
(repeat (sslength ss)
(setq ent (ssname ss i)
obj (vlax-ename->vla-object ent)
i (1+ i))
;; 检查是否为闭合多段线
(if (= (vla-get-closed obj) :vlax-true)
(progn
;; 计算面积
(setq area (vla-get-area obj))
(setq area-mu (/ area 666.6667)) ; 转换为亩
(setq area-hectare (/ area 10000.0)) ; 转换为公顷
;; 获取多段线的质心(近似中心点)
(setq centroid (get-centroid ent))
;; 创建面积标注
(create-area-text area area-mu area-hectare centroid text-height unit-choice)
)
(princ (strcat "\n跳过非闭合多段线: " (vl-princ-to-string ent)))
)
)
(princ (strcat "\n已完成 " (itoa i) " 个闭合多段线的面积标注。"))
)
(princ "\n未选择任何闭合多段线。")
)
(princ)
)
;; 函数：获取多段线的质心(近似中心点)
(defun get-centroid (ent / obj minpt maxpt)
(vla-getboundingbox (vlax-ename->vla-object ent) 'minpt 'maxpt)
(setq minpt (vlax-safearray->list minpt)
maxpt (vlax-safearray->list maxpt))
(mapcar '(lambda (a b) (/ (+ a b) 2.0)) minpt maxpt)
)
;; 函数：创建面积标注文字
(defun create-area-text (area area-mu area-hectare point height unit-choice / text-content text-obj)
;; 根据单位选择格式化面积文本
(cond
((= unit-choice "1") ; 平方米
(setq text-content (strcat (rtos area 2 2) " ㎡")))
((= unit-choice "2") ; 亩
(setq text-content (strcat (rtos area-mu 2 4) " 亩")))
((= unit-choice "3") ; 公顷
(setq text-content (strcat (rtos area-hectare 2 4) " 公顷")))
((= unit-choice "4") ; 平方米合亩
(setq text-content (strcat (rtos area 2 2) "㎡,合" (rtos area-mu 2 4) "亩")))
)
;; 创建文字对象
(setq text-obj (vla-addtext
(vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
text-content
(vlax-3d-point point)
height
))
;; 设置文字对齐方式为居中
(vla-put-alignment text-obj acAlignmentMiddleCenter)
(vla-put-textalignmentpoint text-obj (vlax-3d-point point))
;; 设置文字图层为"面积"
(vla-put-layer text-obj "面积")
;; 设置文字样式为宋体
(vla-put-stylename text-obj "宋体")
;;还原0图层
(set-layer-0-silently)
;;打开回显
(SETVAR "CMDECHO" 1)
)
;; 静默还原到0图层函数
(defun set-layer-0-silently ()
(vl-load-com)
(setq *acad* (vlax-get-acad-object)
*doc* (vla-get-activedocument *acad*)
*layers* (vla-get-layers *doc*))
;; 检查0图层是否存在
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list *layers* "0")))
(progn
;; 创建0图层
(setq layer-0 (vla-add *layers* "0"))
(vla-put-color layer-0 7) ; 设置颜色为白色
)
(progn
;; 0图层已存在，确保它是打开状态
(setq layer-0 (vla-item *layers* "0"))
(vla-put-layeron layer-0 :vlax-true) ; 打开图层
)
)
;; 设置0图层为当前图层
(vla-put-activelayer *doc* layer-0)
)
;; 加载提示
(princ "\n批量面积标注插件已加载，请输入 BZMJ 启动命令。")
(princ)
非常厉害 感谢分享 能不能按类输出成表格形式？ BUBUBA918 发表于 2025-9-12 14:46
能不能按类输出成表格形式？
具体指什么类？
页:
[1]