设为首页收藏本站

晓东CAD家园-论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 2633|回复: 10

[编程申请] 求一个自动计算面积和的程序

[复制链接]
发表于 2013-4-19 09:19:43 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

您需要 登录 才可以下载或查看,没有帐号?立即注册

x
想在cad里实现几个图像的面积和自动计算并统计的程序,求高手指点
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

点击这里给我发消息

已领礼包: 1739个

财富等级: 堆金积玉

发表于 2013-4-19 09:26:16 | 显示全部楼层
贴截图,以及测试图档,方便对症下药
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2013-4-19 09:39:19 | 显示全部楼层
入图请指教
23.jpg
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 40个

财富等级: 招财进宝

发表于 2013-4-19 09:46:24 | 显示全部楼层

这程序论坛搜一下会无数个。

装个晓东工具箱吧,有你所要的。



demo1.gif
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

点击这里给我发消息

已领礼包: 1739个

财富等级: 堆金积玉

发表于 2013-4-19 10:24:25 | 显示全部楼层
VLA-GET-AREA
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 836个

财富等级: 财运亨通

发表于 2013-4-19 11:43:47 | 显示全部楼层
又看到了熟悉的界面还有晓东的屏幕菜单
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

点击这里给我发消息

已领礼包: 589个

财富等级: 财运亨通

发表于 2013-4-19 22:44:18 | 显示全部楼层
以前写的一个面积反应器DCL( 6年前的了
[pcode=lisp,false]area : dialog {
label = "Area Setting By Eachy";
: column {
  : row {
    : edit_box {
      label = "字高";
      width = 10;
      key = "h";
      }
    : popup_list {
      list = "2.0\n2.5\n3.0\n3.5\n4.0\n4.5\n5.0\n7.0";
      key = "kh";
      }
    }      
  : row {
    : edit_box {
      label = "系数";
      key = "s";
      width = 8;
      }
    : popup_list {
      list = "\n1e-6\n1.0\n1/666.667\n1000.0";
      key = "ks";
      }
    }
  : row {
    : edit_box {
      label = "后缀";
      key = "u";
      width = 8;
      }
    : popup_list {
      list = "\n㎡\n亩\nh㎡";
      key = "ku";
      }
    }
  : row {
    : edit_box {
      label = "精度";
      key = "d";
      width = 8;
      }
    : popup_list {
      list = "\n0\n1\n2\n3\n4\n5\n6\n7\n8\n9\n10";
      key = "kd";
      }
    }
}
ok_only;
}[/pcode]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

点击这里给我发消息

已领礼包: 589个

财富等级: 财运亨通

发表于 2013-4-19 22:45:23 | 显示全部楼层
Lisp文件
[pcode=c,true];; Author: Eachy 2006.10.21
;;对实体增加字串类扩展数据
(defun ybl-addxdata (obj str / xType Value)
  (setq        xType (vlax-safearray-fill
                (vlax-make-safearray vlax-vbInteger '(0 . 1))
                (list 1001 1000)
              )
        Value (vlax-safearray-fill
                (vlax-make-safearray vlax-vbVariant '(0 . 1))
                (list str str)
              )
  )
  (vla-setXdata obj xType Value)
)
;; 功能:增加面积标注字段,精度曲系统设置,后缀为 \U+33a1,
;;       面积系数可以指定,回车为 1

(defun area_reactor (txtobj objlst)
  (setq        area-reactor
         (vlr-object-reactor
           objlst
           (vla-get-handle txtobj)
           '((:vlr-modified . chg-area-txt-reaction))
         )
  )
  ;;(foreach x objlst (vlr-owner-add area-reactor))
)
(defun chg-area-txt-reaction (notifier reactor arg_list)
  (chg-area-txt (vlr-data reactor))
)
(defun chg-area-txt (handle / hl doc lst tx)
  (vl-catch-all-apply
    '(lambda ()
       (setq doc (vla-get-activedocument (vlax-get-acad-object)))
       (if (not        (vl-catch-all-error-p
                  (setq        tx (vl-catch-all-apply
                             'vla-handletoobject
                             (list doc handle)
                           )
                  )
                )
           )
         (progn
           (setq
             hl        (vlax-ldata-get
                  (setq tx (vla-handletoobject doc handle))
                  "Area_obj"
                )
           )
           (setq lst (vlax-ldata-get "Area_setting" "Setting"))
           (vla-put-textstring
             tx
             (strcat
               (rtos
                 (* (cadr lst)
                    (apply '+
                           (mapcar
                             '(lambda (x / aa)
                                (if (not (vl-catch-all-error-p
                                           (setq aa (vl-catch-all-apply
                                                      'vla-handletoobject
                                                      (list doc x)
                                                    )
                                           )
                                         )
                                    )
                                  (vla-get-area aa)
                                  0.
                                )
                              )
                             hl
                           )
                    )
                 )
                 2
                 (last lst)
               )
               (caddr lst)
             )
           )
         )
       )
     )
  )
)
(vl-catch-all-apply
  'vla-eval
  (list        (vlax-get-acad-object)
        "Thisdrawing.ActiveSelectionset.delete"
  )
)
(vl-catch-all-apply
  '(lambda (/ doc lst objlst tf)
     (setq doc (vla-get-activedocument (vlax-get-acad-object)))
     (if (ssget "X" '((-3 ("Ea_Area_Object"))))
       (vlax-for x (vla-get-activeselectionset doc)
         (setq lst (vlax-ldata-get x "Area_obj"))
         (if (setq objlst
                    (vl-remove
                      nil
                      (mapcar '(lambda (a / tx)
                                 (if (not (vl-catch-all-error-p
                                            (setq tx (vl-catch-all-apply
                                                       'vla-handletoobject
                                                       (list doc a)
                                                     )
                                            )
                                          )
                                     )
                                   tx
                                   nil
                                 )
                               )
                              lst
                      )
                    )
             )
           (progn (setq tf t)
                  (area_reactor x objlst)
           )
         )
       )
     )
     (if tf
       (princ "\nFind Area Reactor Objects, It's associated!")
     )
   )
)
(defun getarea (/     *acad*          doc        ms    ss    pcen  area        bp
                up    grps  str          txt        grp   scl   pcen  txth        diff
                kd    kh    ks          ku        kw    or_lst          prc        scl
                scll  sub   th          txth        code  curlst          kd        kh
                ks    ku    ppt          prc        scl   scll  sub          tf        txth
                zarea
               )

  (defun area_setting (/      _area_id            kh           ks          ku         d
                       dimscale             th            dimflac          diff         lst
                       or_lst prc    scl    sub           txth          kd
                      )
    (setvar "dimzin" 0)
    (if        (not _area_id)
      (setq _area_id (load_dialog "area.dcl"))
    )
    (if        (not (new_dialog "area" _area_id))
      (exit)
    )
    (setq kh '("2.0" "2.5" "3.0" "3.5" "4.0" "4.5" "5.0" "7.0")
          ks '("1e-6" "1.0" "0.145" "1000.0")
          kd '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10")
          ku '("㎡" "亩" "h㎡")
    )
    ;; Setting (texthigh scalefactor sub diff)
    (if        (vlax-ldata-list "Area_setting")
      (setq or_lst (vlax-ldata-get "Area_setting" "Setting")
            th           (vl-princ-to-string (car or_lst))
            scl           (vl-princ-to-string (cadr or_lst))
            sub           (caddr or_lst)
            diff   (itoa (last or_lst))
      )
      (setq dimscale (getvar "dimscale")
            dimflac  (getvar "dimflac") ;_线形因子
            th             (vl-princ-to-string (getvar "dimtxt"))
            scl             (if (or (and (> dimscale 1.)
                                  (>= dimflac 1.)
                             )
                             (and (> dimscale 1.)
                                  (<= dimflac 1.)
                             )
                         )
                       "1e-6"
                       "1.0"
                     )
            scll     scl
            diff     (vl-princ-to-string (getvar "luprec"))
            sub             "㎡"
      )
    )
    ;;
    (mode_tile "d" 1)
    ;;
    (set_tile "s" scl)
    (set_tile "h" th)
    (set_tile "d" diff)
    (set_tile "u" sub)
    ;;
    (action_tile
      "accept"
      "(setq txth (get_tile \"h\"))(setq scl (get_tile \"s\"))(setq sub (get_tile \"u\"))(setq prc (get_tile \"d\"))(done_dialog 0)"
    )
    ;;
    (action_tile "h" "(setq txth $value)")
    (action_tile "s" "(setq scl $value)")
    (action_tile "u" "(setq sub $value)")
    (action_tile "d" "(setq prc $value)")
    ;;
    (action_tile "kh" "(set_tile \"h\" (nth (atoi $value) kh))")
    (action_tile "ks" "(set_tile \"s\" (nth (atoi $value) ks))")
    (action_tile "ku" "(set_tile \"u\" (nth (atoi $value) ku))")
    (action_tile "kd" "(set_tile \"d\" (nth (atoi $value) kd))")
    (start_dialog)
    (unload_dialog _area_id)
    ;;
    (if        (or (not (distof txth)) (zerop (distof txth)))
      (setq txth th)
      (setq txth (distof txth))
    )
    (if        (or (not (distof scl)) (zerop (distof scl)))
      (setq scl (read scll))
      (setq scl (distof scl))
    )
    (if        (or (not (distof prc)) (zerop (distof prc)))
      (setq prc (getvar "luprec"))
      (setq prc (atoi prc))
    )
    (vlax-ldata-put
      "Area_setting"
      "Setting"
      (list txth scl sub prc)
    )
    (princ)
  )
  (setq *acad* (vlax-get-acad-object))
  (vla-eval *acad* "Thisdrawing.ActiveSelectionset.delete")
  (setq        doc  (vla-get-activedocument *acad*)
        ms   (vla-get-modelspace doc)
        grps (vla-get-groups doc)
  )
  (if (vlax-ldata-list "Area_setting")
    (setq or_lst (vlax-ldata-get "Area_setting" "Setting")
          th         (vl-princ-to-string (car or_lst))
          scl         (vl-princ-to-string (cadr or_lst))
          sub         (caddr or_lst)
          diff         (itoa (last or_lst))
    )
    (vlax-ldata-put
      "Area_setting"
      "Setting"
      (list (* (getvar "dimscale") (getvar "dimtxt"))
            1.0
            "㎡"
            (getvar "luprec")
      )
    )
  )
  (area_setting)
  (princ "\nSelect Pline,Circle,Ellipse,Spline,Hatch....")
  (if (setq ss (ssget '((0 . "lwpolyline,circle,ellipse,spline,hatch"))))
    (progn
      (vla-put-color (vla-add (vla-get-layers doc) "_$Area") 5)
      (setq or_lst (vlax-ldata-get "Area_setting" "Setting")
            th           (car or_lst)
            scl           (strcat "%ct8["
                           (vl-princ-to-string (cadr or_lst))
                           "]"
                   )
            sub           (caddr or_lst)
            diff   (last or_lst)
            $area  0.
      )
      (vlax-for        obj (vla-get-activeselectionset doc)
        (vla-getboundingbox obj 'bp 'up)
                                        ;(princ bp )
                                        ;(princ up)
        (setq pcen   (vlax-3d-point
                       (mapcar
                         '*
                         '(0.5 0.5 0.5)
                         (mapcar '+
                                 (safearray-value bp)
                                 (safearray-value up)
                         )
                       )
                     )
              $area  (+        $area
                        (vla-get-area obj)
                     )
              curlst (cons obj curlst)
        )
                                        ;(princ pcen)
        (setq txt
               (vla-addtext
                 ms
                 (setq
                   str (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                               (itoa (vla-get-objectid obj))
                               ">%).Area \\f \"%lu2%pr"
                               (itoa diff)
                               "%ps[,"
                               sub
                               "]"
                               scl
                               "\">%"
                       )
                 )
                 pcen
                 th
               )
        )
                                        ;(princ str)
        (vla-put-alignment txt acAlignmentMiddleCenter)
        (vla-put-textalignmentpoint txt pcen)
        (vla-put-layer txt "_$Area")
        (setq grp (vla-add grps "*"))
        (vla-appenditems
          grp
          (vlax-make-variant
            (vlax-safearray-fill
              (vlax-make-safearray vlax-vbobject '(0 . 1))
              (list txt obj)
            )
          )
        )
      )
      (setq zarea (vla-addtext
                    ms
                    (rtos (* (cadr or_lst) $area) 2 diff)
                    (vlax-3d-point (cadr (grread nil 13 2)))
                    th
                  )
            tf          t
      )
      (princ "\nPick Point: ")
      (while tf
        (setq ppt  (grread nil 13 2)
              code (car ppt)
        )
        (cond
          ((= code 3)
           (vla-put-insertionpoint zarea (vlax-3d-point (cadr ppt)))
           (vlax-ldata-put
             zarea
             "Area_obj"
             (mapcar 'vla-get-handle curlst)
           )
           (area_reactor zarea curlst)
           (ybl-addxdata zarea "Ea_Area_Object")
           (setq tf nil)
          )
          ((= code 5)
           (vla-put-insertionpoint zarea (vlax-3d-point (cadr ppt)))
          )
          (t (vla-delete zarea) (setq tf nil))
        )
      )
    )
  )
  (princ)
)
(defun c:getarea ()
  (vl-catch-all-apply 'getarea nil)
  (princ)
)
(defun c:gat ()   (vl-catch-all-apply 'getarea nil)
  (princ)
)
(princ
  "\nStart Command with Getarea & Gat, Author: eachy. 2006.11.22!"
)
(princ)[/pcode]

评分

参与人数 1D豆 +4 收起 理由
XDSoft + 4 技术引导讨论和指点奖!

查看全部评分

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

点击这里给我发消息

已领礼包: 144个

财富等级: 日进斗金

发表于 2013-4-19 22:54:13 | 显示全部楼层

看到这种对话框,好远古的感脚。:P
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 3108个

财富等级: 富可敌国

发表于 2013-5-3 20:49:57 | 显示全部楼层
XDSoft 发表于 2013-4-19 22:54
看到这种对话框,好远古的感脚。

不错,学习学习:lol
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-7-16 09:01:31 | 显示全部楼层
我也想要一个
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|小黑屋|手机版|Archiver|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )  

GMT+8, 2019-12-9 12:51 , Processed in 0.227621 second(s), 54 queries , Gzip On, WinCache On.

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

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