求一个自动计算面积和的程序

zjdeng

想在cad里实现几个图像的面积和自动计算并统计的程序，求高手指点

炫翔

贴截图，以及测试图档，方便对症下药

zjdeng

入图请指教

newer

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

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

炫翔

VLA-GET-AREA

hao3ren

又看到了熟悉的界面还有晓东的屏幕菜单

eachy

以前写的一个面积反应器DCL( 6年前的了{:soso_e100:}）
[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]

eachy

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]

XDSoft

eachy 发表于 2013-4-19 22:44

                               
登录/注册后可看大图

以前写的一个面积反应器DCL( 6年前的了）
area : dialog {
label = "Area Setting By Eachy ...

看到这种对话框，好远古的感脚。:P

liuyun242

XDSoft 发表于 2013-4-19 22:54

                               
登录/注册后可看大图

看到这种对话框，好远古的感脚。

不错，学习学习:lol

linmw

我也想要一个