设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 应用篇 › AutoCAD工具插件 › 没钱发几个小插件赚点明经币
12下一页
返回列表 发新帖
查看: 2570|回复: 19

没钱发几个小插件赚点明经币

[复制链接]
yy6831817
发表于 2025-8-30 15:35:17 | 显示全部楼层 |阅读模式
购买主题 已有 15 人购买  本主题需向作者支付 1 个明经币 才能浏览
回复

使用道具 举报

yy6831817
 楼主| 发表于 2025-8-30 15:43:35 | 显示全部楼层
本帖最后由 yy6831817 于 2025-9-4 09:02 编辑

;; ===============================================================
;;  功能：计算带孤岛图形面积
;;  命令：ZZ标注带孤岛面积
;;  格式：
;; ===============================================================
(defun c:ZZ标注带孤岛面积 ( / pt area ent ins ms doc )
  (setvar "cmdecho" 0)

  (if (setq pt (getpoint "\n选择图案填充内部点: "))
    (progn
      ;; 1. 命令行 BHATCH
      (command "_.-bhatch" "_P" "SOLID" pt "")
      (setq ent (entlast))

      (if (and ent (= (cdr (assoc 0 (entget ent))) "HATCH"))
        (progn
          ;; 2. 计算面积（m²）
          (setq area (/ (vla-get-area (vlax-ename->vla-object ent)) 1e6))

          ;; 3. 文字插入点
          (setq ins (vlax-3d-point (list (car pt) (+ (cadr pt) 0.5) 0.0)))

          ;; 4. 取得 ModelSpace
          (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
                ms  (vla-get-ModelSpace doc))

          ;; 5. 用 ActiveX 一次性创建文字 —— 任何字符都不会被拆分
          (vla-AddText ms
                       (strcat "面积=" (rtos area 2 3) " m²")
                       ins
                       50)

          ;; 6. 删除临时填充
          (entdel ent)

          (princ (strcat "\n填充面积: " (rtos area 2 2) " m²"))
        )
        (princ "\n未能成功创建图案填充。")
      )
    )
    (princ "\n未选择点，已取消操作。")
  )

  (setvar "cmdecho" 1)
  (princ)
)

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x

评分

参与人数 4明经币 +4 金钱 +5 收起 理由
USER2128 + 1 赞一个!
cghdy + 1 很给力!
开心68602 + 1 赞一个!
tigcat + 1 + 5 谢谢分享

查看全部评分

回复 支持 2 反对 0

使用道具 举报

yy6831817
 楼主| 发表于 2025-8-30 15:49:10 | 显示全部楼层
;; ===============================================================
;;  功能：批量选中多段线、直线、弧线、圆环长值写入当前表格
;;  命令：ZZ提取线长
;;  格式：0.12+0.19+0.5
;; ===============================================================
(defun c:ZZ提取线长 ( / ss i ent obj pt len lenStr newText excelapp selection oldVal minPt maxPt)
  (vl-load-com)
  ;; 1. 选择对象
  (princ "\n请选择要计算线长的图形: ")
  (setq ss (ssget))
  (if (not ss)
    (progn (princ "\n未选择任何对象！") (exit))
  )
  ;; 2. 逐个对象：写文字并拼字符串
  (setq lenStr "")
  (setq i 0)
  (repeat (sslength ss)
    (setq ent (ssname ss i))
    (setq obj (vlax-ename->vla-object ent))
    ;; 先根据对象类型算出长度
    (setq len nil)                ; 先置空
    (cond
      ;; Line / Polyline / LWPolyline / Spline 等
      ((vlax-property-available-p obj 'Length)
       (setq len (/ (vlax-get-property obj 'Length) 1000.0)))
      ;; Circle / Donut（本质是圆）
      ((= (vla-get-ObjectName obj) "AcDbCircle")
       (setq len (/ (* 2.0 pi (vla-get-Radius obj)) 1000.0)))
      ;; Arc
      ((= (vla-get-ObjectName obj) "AcDbArc")
       (setq len (/ (* (vla-get-ArcLength obj) 1.0) 1000.0)))
    )
    (if len
      (progn
        ;; 拼字符串
        (setq lenStr (strcat lenStr "+" (rtos len 2 3)))
        ;; 计算标注点
        (cond
          ;; 直线：中点
          ((= (vla-get-ObjectName obj) "AcDbLine")
           (setq pt (mapcar '(lambda (a b) (/ (+ a b) 2.0))
                            (vlax-get obj 'StartPoint)
                            (vlax-get obj 'EndPoint))))
          ;; 弧线：起点终点中点
          ((= (vla-get-ObjectName obj) "AcDbArc")
           (setq pt (mapcar '(lambda (a b) (/ (+ a b) 2.0))
                            (vlax-get obj 'StartPoint)
                            (vlax-get obj 'EndPoint))))
          ;; 圆 / 圆环：圆心
          ((= (vla-get-ObjectName obj) "AcDbCircle")
           (setq pt (vlax-get obj 'Center)))
          ;; 其它对象：包围盒中心
          ((vlax-property-available-p obj 'Centroid)
           (setq pt (vlax-get obj 'Centroid)))
          (T
           (vla-getboundingbox obj 'minPt 'maxPt)
           (setq pt (mapcar '(lambda (a b) (/ (+ a b) 2.0))
                            (vlax-safearray->list minPt)
                            (vlax-safearray->list maxPt)))))
        ;; 写文字
        (setq newText (strcat "线长=" (rtos len 2 3) "m"))
        (entmake
          (list '(0 . "TEXT")
                '(100 . "AcDbEntity")
                '(100 . "AcDbText")
                (cons 10 pt)
                (cons 1 newText)
                (cons 40 30)
                (cons 50 0.0)
                (cons 72 1)   ; 中心对齐
                (cons 11 pt)
                (cons 73 2)))
      )
    )
    (setq i (1+ i))
  )
  (if (= lenStr "")
    (progn (princ "\n所选对象中没有可计算线长的图形！") (exit)))
  ;; 3. 写入 Excel：追加
  (setq excelapp (vlax-get-or-create-object "excel.application"))
  (setq selection (vlax-get-property excelapp 'selection))
  (if (= (vlax-get-property selection 'Count) 1)
    (progn
      (setq oldVal (vlax-get selection 'Text))
      (if (null oldVal) (setq oldVal ""))
      (vlax-put-property selection 'Value2
        (if (= oldVal "")
          (substr lenStr 2)
          (strcat oldVal lenStr)))
      (princ (strcat "\n已写入 Excel: " (substr lenStr 2))))
    (princ "\n请在 Excel 中确保只选择一个单元格"))
  (princ)
)

评分

参与人数 2明经币 +2 收起 理由
USER2128 + 1 赞一个!
VBALISPER + 1

查看全部评分

回复 支持 0 反对 1

使用道具 举报

yy6831817
 楼主| 发表于 2025-8-30 15:50:18 | 显示全部楼层
;; ===============================================================
;;  功能：批量选中填充图案面积值写入当前表格
;;  命令：ZZ提取填充面积
;;  格式：0.12+0.19+0.5
;; ===============================================================
(defun c:ZZ提取填充面积 ( / ss i ent obj pt area areaStr newText excelapp selection oldVal)
  (vl-load-com)
  ;; 1. 仅选填充图案（Hatch）
  (princ "\n请选择要计算面积的填充图案: ")
  (setq ss (ssget '((0 . "HATCH"))))   ; 只过滤 Hatch
  (if (not ss)
    (progn (princ "\n未选择任何填充图案！") (exit))
  )
  ;; 2. 逐个对象：在中心写文字，同时拼字符串
  (setq areaStr "")
  (setq i 0)
  (repeat (sslength ss)
    (setq ent (ssname ss i))
    (setq obj (vlax-ename->vla-object ent))
    ;; Hatch 一定带 Area 属性，无需再判断
    ;; 面积（m²，3 位小数）
    (setq area (/ (vlax-get-property obj 'area) 1e6))
    ;; 拼字符串：+0.099+0.107 ...
    (setq areaStr (strcat areaStr "+" (rtos area 2 3)))
    ;; 取中心点
    (cond
      ((vlax-property-available-p obj 'centroid)
       (setq pt (vlax-get obj 'centroid)))
      (T
       (vla-getboundingbox obj 'minPt 'maxPt)
       (setq pt (mapcar '(lambda (a b) (/ (+ a b) 2.0))
                        (vlax-safearray->list minPt)
                        (vlax-safearray->list maxPt)))))
    ;; 用 entmake 创建文字，避免 command 截断
    (setq newText (strcat "面积=" (rtos area 2 3) "m²"))
    (entmake
      (list '(0 . "TEXT")
            '(100 . "AcDbEntity")
            '(100 . "AcDbText")
            (cons 10 pt)          ; 插入点
            (cons 1 newText)      ; 文字内容
            (cons 40 50)          ; 字高
            (cons 50 0.0)         ; 旋转角
            (cons 72 1)           ; 对正方式：中心
            (cons 11 pt)          ; 对齐点
            (cons 73 2)))
    (setq i (1+ i))
  )
  ;; 3. 写入 Excel：追加
  (setq excelapp (vlax-get-or-create-object "excel.application"))
  (setq selection (vlax-get-property excelapp 'selection))
  (if (= (vlax-get-property selection 'count) 1)
    (progn
      (setq oldVal (vlax-get selection 'Text))
      (if (null oldVal) (setq oldVal ""))
      (vlax-put-property selection 'value2
        (if (= oldVal "")
          (substr areaStr 2)        ; 去掉首“+”
          (strcat oldVal areaStr)))
      (princ (strcat "\n已写入 Excel: " (substr areaStr 2))))
    (princ "\n请在 Excel 中确保只选择一个单元格"))
  (princ)
)
回复 支持 1 反对 0

使用道具 举报

yy6831817
 楼主| 发表于 2025-8-30 15:56:03 | 显示全部楼层
本帖最后由 yy6831817 于 2025-9-4 09:10 编辑

;; ===============================================================
;;  功能：批量选中图形圈内面积值写入当前表格
;;  命令：ZZ提取圈内面积
;;  格式：0.12+0.19+0.5
;; ===============================================================
(defun C:ZZ提取圈内面积 (/ ent areaM2 P1 areaStr oldVal excelapp selection)
  (vl-load-com)
  (setvar "OSMODE" 0)
  ;; 创建或切到“面积标注”图层
  (command "_.-LAYER" "_M" "面积标注" "_C" "8" "" "")
  (setq areaStr "")                       ; 用于拼 Excel 字符串
  ;; 主循环：拾取内部点生成边界并求面积
  (while (setq P1 (getpoint "\n拾取内部点 <回车结束>："))
    (command "_.BOUNDARY" P1 "")         ; 生成边界
    (setq ent (entlast))                 ; 拿到边界对象
    ;; 计算面积 (mm&#178;→m&#178;)
    (command "_.AREA" "_O" ent)
    (setq areaM2 (/ (getvar "AREA") 1e6))
    ;; 即时在图上标注面积
    (command "_.TEXT" "_M" P1 "0" (strcat "面积=" (rtos areaM2 2 3) "m%%178"))
    ;; 把本次面积拼到字符串里，带“+”前缀
    (setq areaStr (strcat areaStr "+" (rtos areaM2 2 3)))
    ;; 删除生成的边界，保持图面干净（可选）
    (if ent (vla-delete (vlax-ename->vla-object ent)))
  )
  ;; 将累计面积写入 Excel 当前单元格
  (if (/= areaStr "")                   ; 有数据才写
    (progn
      (setq excelapp (vlax-get-or-create-object "excel.application"))
      (setq selection (vlax-get-property excelapp 'selection))
      (if (= (vlax-get-property selection 'count) 1)
        (progn
          (setq oldVal (vlax-get selection 'text))
          (if (null oldVal) (setq oldVal ""))
          (vlax-put-property
            selection
            'value2
            (if (= oldVal "")
              (substr areaStr 2)        ; 去掉首“+”
              (strcat oldVal areaStr)))
          (princ (strcat "\n已写入 Excel: " (substr areaStr 2))))
        (princ "\n请在 Excel 中确保只选择一个单元格")))
    (princ "\n未拾取任何区域，无数据写入！"))

  (setvar "OSMODE" 16383)
  (princ)
)

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x

评分

参与人数 2明经币 +2 收起 理由
不一样地设计 + 1 赞一个!
tigcat + 1 很给力!

查看全部评分

回复 支持 1 反对 0

使用道具 举报

qifeifei
发表于 2025-8-30 15:47:08 | 显示全部楼层
你售卖的是什么插件 开盲盒吗
回复 支持 反对

使用道具 举报

yy6831817
 楼主| 发表于 2025-8-30 15:47:50 | 显示全部楼层
本帖最后由 yy6831817 于 2025-9-4 09:10 编辑

;; ===============================================================
;;  功能：批量选中图形面积值写入当前表格
;;  命令：ZZ提取图形面积
;;  格式：0.12+0.19+0.5
;; ===============================================================
(defun c:ZZ提取图形面积 ( / ss i ent obj pt area areaStr newText excelapp selection oldVal)
  (vl-load-com)
  ;; 1. 选对象
  (princ "\n请选择要计算面积的图形: ")
  (setq ss (ssget))
  (if (not ss)
    (progn (princ "\n未选择任何对象！") (exit))
  )
  ;; 2. 逐个对象：在中心写文字，同时拼字符串
  (setq areaStr "")
  (setq i 0)
  (repeat (sslength ss)
    (setq ent (ssname ss i))
    (setq obj (vlax-ename->vla-object ent))
    (if (vlax-property-available-p obj 'area)
      (progn
        ;; 面积（m&#178;，3 位小数）
        (setq area (/ (vlax-get-property obj 'area) 1e6))
        ;; 拼字符串：+0.099+0.107 ...
        (setq areaStr (strcat areaStr "+" (rtos area 2 3)))
        ;; 取中心点
        (cond
          ((vlax-property-available-p obj 'centroid)
           (setq pt (vlax-get obj 'centroid)))
          (T
           (vla-getboundingbox obj 'minPt 'maxPt)
           (setq pt (mapcar '(lambda (a b) (/ (+ a b) 2.0))
                            (vlax-safearray->list minPt)
                            (vlax-safearray->list maxPt)))))
        ;; 用 entmake 创建文字，避免 command 截断
        (setq newText (strcat "面积=" (rtos area 2 3) "m&#178;"))
        (entmake
          (list '(0 . "TEXT")
                '(100 . "AcDbEntity")
                '(100 . "AcDbText")
                (cons 10 pt)          ; 插入点
                (cons 1 newText)      ; 文字内容
                (cons 40 50)         ; 字高
                (cons 50 0.0)         ; 旋转角
                (cons 72 1)           ; 对正方式：中心
                (cons 11 pt)          ; 对齐点
                (cons 73 2)))))
    (setq i (1+ i))
  )
  (if (= areaStr "")
    (progn (princ "\n所选对象中没有可计算面积的图形！") (exit)))
  ;; 3. 写入 Excel：追加
  (setq excelapp (vlax-get-or-create-object "excel.application"))
  (setq selection (vlax-get-property excelapp 'selection))
  (if (= (vlax-get-property selection 'count) 1)
    (progn
      (setq oldVal (vlax-get selection 'Text))
      (if (null oldVal) (setq oldVal ""))
      (vlax-put-property selection 'value2
        (if (= oldVal "")
          (substr areaStr 2)        ; 去掉首“+”
          (strcat oldVal areaStr)))
      (princ (strcat "\n已写入 Excel: " (substr areaStr 2))))
    (princ "\n请在 Excel 中确保只选择一个单元格"))
  (princ)
)

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x

评分

参与人数 1明经币 +1 收起 理由
tigcat + 1 很给力!

查看全部评分

回复 支持 反对

使用道具 举报

下文没句号。
发表于 2025-8-30 20:15:47 | 显示全部楼层
是什么，是什么，是什么？
回复 支持 反对

使用道具 举报

张向华
发表于 2025-8-30 22:47:09 | 显示全部楼层
看不懂太深奥了
回复 支持 反对

使用道具 举报

bskidtf
发表于 2025-8-30 23:41:32 | 显示全部楼层
有2人开盲盒了？
回复 支持 反对

使用道具 举报

12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2025-11-22 10:14 , Processed in 0.222139 second(s), 34 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表