area calculation autolisp

sachindkini · 发表于 2009-12-18 20:03

Dear Sir

im not chines user plz help me

thx

Pick inside the polyline & create no’s of triangles (Rectangle, rotated rectangle, arch, circle) and area of each triangle

xianaihua · 发表于 2009-12-18 21:22

;| TOTALAREA version 4.02 (Gile)
Set the controls AREABOX, TOTALAREA, AREAEDIT, AREASHOW and AREACONV
- Block "TotalArea":
A definition block named "TotalArea" must be present in the drawing collection or
as file "TotalArea.dwg" in an AutoCAD search path directory.
This block must contain at least three attributes with "LABEL", "UNIT and "AREA" tags.
"AREA" will be automatically populate with the sum of the areas of objects linked to it.
(arc, circle, ellipse, polylines, spline, hatch, region, mpolygon)
If it contains a fourth attribute with "NOBJ" tag, it will also be
automatically populate with the number of items linked to the block.
Format the display of the attribute "AREA":
It is possible to assign a conversion factor to the value of the attribute.
This value is managed with a variable (AREACONV) that can be changed with the
command of the same name.
The display the number of decimal is managed by a variable too (AREAPREC)
|;
;;;===============================================;;;
(vl-load-com)
(or *acdoc*
(setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
)
;;; AREABOX (gile)
;;; Dialog Box for commands calling
(defun c:Areabox (/ tmp file what_next dcl_id result)
(or (getenv "AreaConv") (setenv "AreaConv" "1"))
(or (getenv "AreaPrec")
(setenv "AreaPrec" (itoa (getvar "LUPREC")))
)
(setq tmp (vl-filename-mktemp "Tmp.dcl")
file (open tmp "w")
)
(write-line
"AreaBox:dialog{label="总面积";
:boxed_column{label="命令";:row{
:button{label="总面积";key="(c:totalarea)";width=16;}
spacer;:text{label="插入并连接";width= 20;}}
:row{
:button{label="面积编辑";key="(c:areaedit)";width=16;}
spacer;:text{label="增加或移除链接";width= 20;}}
:row{
:button{label="面积显示";key="(c:areashow)";width=16;}
spacer;:text{label="显示链接对象";width= 20;}}}
:boxed_column{label="系统变量";:row{
:text{key="ConvValue";width= 20;}
:button{label="AreaConv";key="areaconv";width=16;}}
:row{:text{key="PrecValue";width= 20;}
:button{label="AreaPrec";key="areaprec";width=16;}}}
spacer;cancel_button;}"
file
)
(close file)
(setq dcl_id (load_dialog tmp))
(setq what_next 2)
(while (>= what_next 2)
(if (not (new_dialog "AreaBox" dcl_id))
(exit)
)
(set_tile "ConvValue"
(strcat "AREACONV = " (getenv "AreaConv"))
)
(set_tile "PrecValue"
(strcat "AREAPREC = " (getenv "AreaPrec"))
)
(foreach k '("(c:totalarea)"
"(c:areaedit)"
"(c:areashow)"
)
(action_tile k "(setq result $key) (done_dialog)")
)
(action_tile "areaconv" "(done_dialog 3)")
(action_tile "areaprec" "(done_dialog 4)")
(action_tile "cancel" "(done_dialog 0)")
(setq what_next (start_dialog))
(cond
((= what_next 3) (c:areaconv))
((= what_next 4) (c:areaprec))
)
)
(unload_dialog dcl_id)
(vl-file-delete tmp)
(and result (eval (read result)))
(princ)
)
;;;===============================================;;;
;; TotalAreaBox
;; TotalArea command dialog box
(defun TotalAreaBox (/ lbl unt scl lay lst
tmp file what_next dcl_id data
result
)
(or (getenv "AreaConv") (setenv "AreaConv" "1"))
(or (getenv "AreaPrec")
(setenv "AreaPrec" (itoa (getvar "LUPREC")))
)
(or (setq lbl (vlax-ldata-get "TotalArea" "lbl"))
(setq lbl (vlax-ldata-put "TotalArea" "lbl" "Total area"))
)
(or (setq unt (vlax-ldata-get "TotalArea" "unt"))
(setq unt (vlax-ldata-put "TotalArea" "unt" "m"))
)
(or (setq scl (vlax-ldata-get "TotalArea" "scl"))
(setq scl (vlax-ldata-put "TotalArea" "scl" 1))
)
(while (setq lay (tblnext "LAYER" (not lay)))
(setq lst (cons (cdr (assoc 2 lay)) lst))
)
(setq lst (vl-sort lst '<))
(setq lay (getvar "CLAYER"))
(setq tmp (vl-filename-mktemp "Tmp.dcl")
file (open tmp "w")
)
(write-line
"AreaBox:dialog{label="总面积";
:boxed_column{label="属性";
:row{:text{label="Label";}
:edit_box{key="lbl";width=24;}}
:row{:text{label="单位";}
:edit_box{key="unt";fixed_width=true;}}}
:boxed_column{label="属性";
:row{:text{label="比例";}
:edit_box{key="scl";fixed_width=true;}}
:popup_list{label="图层";key="lay";}}
:boxed_column{label="变量";:row{
:text{key="ConvValue";width= 20;}
:button{label="AreaConv";key="areaconv";width=16;}}
:row{:text{key="PrecValue";width= 20;}
:button{label="AreaPrec";key="areaprec";width=16;}}}
spacer;ok_cancel_help;}"
file
)
(close file)
(setq dcl_id (load_dialog tmp))
(setq what_next 2)
(while (>= what_next 2)
(if (not (new_dialog "AreaBox" dcl_id))
(exit)
)
(start_list "lay")
(mapcar 'add_list lst)
(end_list)
(set_tile "lbl" lbl)
(set_tile "unt" unt)
(set_tile "scl" (rtos scl))
(set_tile "lay" (itoa (vl-position lay lst)))
(set_tile "ConvValue"
(strcat "AREACONV = " (getenv "AreaConv"))
)
(set_tile "PrecValue"
(strcat "AREAPREC = " (getenv "AreaPrec"))
)
(action_tile "lbl" "(setq lbl $value)")
(action_tile "unt" "(setq unt $value)")
(action_tile
"scl"
"(if (< 0 (distof $value))
(setq scl (distof $value))
(progn (alert "Needs a valid scale.")
(setq scl (vlax-ldata-get "TotalArea" "scl"))
(set_tile "scl" (rtos scl))
(mode_tile "scl" 2)))"
)
(action_tile "lay" "(setq lay (nth (atoi $value) lst))")
(action_tile "areaconv" "(done_dialog 3)")
(action_tile "areaprec" "(done_dialog 4)")
(action_tile "help" "(done_dialog 5)")
(action_tile "cancel" "(done_dialog 0)")
(action_tile
"accept"
"(setq result (list lbl unt scl lay))
(vlax-ldata-put "TotalArea" "lbl" lbl)
(vlax-ldata-put "TotalArea" "unt" unt)
(vlax-ldata-put "TotalArea" "scl" scl)
(done_dialog 1)"
)
(setq what_next (start_dialog))
(cond
((= what_next 3) (c:areaconv))
((= what_next 4) (c:areaprec))
((= what_next 5) (help "TotalArea"))
)
)
(unload_dialog dcl_id)
(vl-file-delete tmp)
result
)
;;;===============================================;;;
;;; TOTALAREA (gile)
;;; Insert "TotalArea" block which "AREA" attribute value equals to
;;; the sum of selected objects areas
(defun c:TotalArea (/ *error* space dz bloc tot ss lst ins scl blk)
(defun *error* (msg)
(or (= msg "Function cancelled")
(princ (strcat "\Error: " msg))
)
(setvar "DIMZIN" dz)
(vla-EndUndoMark *acdoc*)
(princ)
)
(setq Space (if (= (getvar "CVPORT") 1)
(vla-get-PaperSpace *acdoc*)
(vla-get-ModelSpace *acdoc*)
)
dz (getvar "DIMZIN")
)
(if (or
(gc:GetItem
(vla-get-Blocks *acdoc*)
(setq bloc "TotalArea")
)
(findfile (setq bloc "TotalArea.dwg"))
)
(if (setq data (TotalAreaBox))
(if
(ssget
'((-4 . "<OR")
(0 . "ARC,CIRCLE,ELLIPSE,LWPOLYLINE,HATCH,MPOLYGON,REGION")
(-4 . "<AND")
(0 . "POLYLINE")
(-4 . "<NOT")
(-4 . "&")
(70 . 120)
(-4 . "NOT>")
(-4 . "AND>")
(-4 . "<AND")
(0 . "SPLINE")
(-4 . "&")
(70 . 8)
(-4 . "AND>")
(-4 . "OR>")
)
)
(progn
(setq tot 0.0)
(vla-StartUndoMark *acdoc*)
(vlax-for obj (setq ss (vla-get-ActiveSelectionset *acdoc*))
(setq tot (+ tot (vla-get-Area obj))
lst (cons obj lst)
)
)
(vla-delete ss)
(initget 1)
(setq ins (getpoint "\nSpecify insertion point: ")
scl (caddr data)
blk
(vla-insertBlock
Space
(vlax-3d-point (trans ins 1 0))
bloc
scl
scl
scl
0.0
)
)
(vla-put-layer blk (cadddr data))
(setvar "DIMZIN" (Boole 2 (getvar "DIMZIN") 8))
(foreach att (vlax-invoke blk 'GetAttributes)
(cond
((= (vla-get-TagString att) "LABEL")
(vla-put-TextString att (car data))
)
((= (vla-get-TagString att) "UNIT")
(vla-put-TextString att (cadr data))
)
((= (vla-get-TagString att) "AREA")
(vla-put-Textstring
att
(rtos (/ tot (distof (getenv "areaConv")))
2
(atoi (getenv "AreaPrec"))
)
)
)
((= (vla-get-TagString att) "NOBJ")
(vla-put-TextString att (itoa (length lst)))
)
)
)
(vlax-ldata-put
blk
"TotalArea"
(mapcar 'vla-get-Handle lst)
)
(setvar "DIMZIN" dz)
;;------------------------------------------------------------------;;
;; Creating reactor
(foreach obj lst
(vlr-object-reactor
(list obj)
(vla-get-Handle blk)
'((:vlr-erased . GC:AREAOBJECTERASED)
(:vlr-unerased . GC:AREAOBJECTUNERASED)
(:vlr-objectClosed . GC:AREAOBJECTCLOSED)
)
)
)
;;------------------------------------------------------------------;;
(vla-EndUndoMark *acdoc*)
)
)
)
(princ "\n"TotalArea" block can't be found.")
)
(princ)
)
;;------------------------------------------------------------------;;
;;; AREAEDIT (gile)
;;; Add or remove links to "TotalArea" block
(defun c:AreaEdit (/ *error* lst blk obj elst rea)
(defun *error* (msg)
(or (= msg "Function cancelled")
(princ (strcat "\Error: " msg))
)
(mapcar (function (lambda (x) (vla-highlight x :vlax-false)))
lst
)
(vla-EndUndoMark *acdoc*)
(princ)
)
(sssetfirst nil nil)
(if (setq lst (gc:AreaGet "\nSelect the block to edit: "))
(progn
(setq blk (car lst)
lst (cadr lst)
)
(vla-StartUndoMark *acdoc*)
(while (setq obj
(car
(entsel
"\nSelect an object to add or remove: "
)
)
)
(setq elst (entget obj))
(if (or
(member (cdr (assoc 0 elst))
'("ARC" "CIRCLE" "ELLIPSE"
"LWPOLYLINE" "HATCH" "MPOLYGON"
"REGION"
)
)
(and (= (cdr (assoc 0 elst)) "POLYLINE")
(zerop (logand 120 (cdr (assoc 70 elst))))
)
(and (= (cdr (assoc 0 elst)) "SPLINE")
(= 8 (logand 8 (cdr (assoc 70 elst))))
)
)
(if (member (setq obj (vlax-ename->vla-object obj)) lst)
(progn
(setq lst (vl-remove obj lst))
(vla-highlight obj :vlax-false)
(if (setq rea (gc:GetAreaObjectReactor obj blk))
(vlr-remove rea)
)
)
(progn
(setq lst (cons obj lst))
(vla-highlight obj :vlax-true)
(vlr-object-reactor
(list obj)
(vla-get-Handle blk)
'((:vlr-erased . GC:AREAOBJECTERASED)
(:vlr-unerased . GC:AREAOBJECTUNERASED)
(:vlr-objectClosed . GC:AREAOBJECTCLOSED)
)
)
)
)
)
(gc:TotalAreaUpd blk lst)
)
(mapcar (function (lambda (x) (vla-highlight x :vlax-false)))
lst
)
(vla-EndUndoMark *acdoc*)
)
)
(princ)
)
;;;===============================================;;;
;;; AREASHOW (gile)
;;; Highlight the linked objects to the block the cursor is on
(defun c:AreaShow (/ blk lst)
(and (setq lst (gc:AreaGet ""))
(mapcar (function (lambda (x) (vla-highlight x :vlax-false)))
(cadr lst)
)
)
(princ)
)
;;;===============================================;;;
;;; AREACONV (gile)
;;; Edit AREACONV sysvar value
;;; This sysvar is registered and manages the area unit conversion factor
;;; example : 10000 for cm?-> m? 1000000 (or 1e6) for m?-> km?
(defun c:AreaConv ()
(or (getenv "AreaConv") (setenv "AreaConv" "1"))
(while
(not
((lambda (r)
(or (= r "")
(< 0 (distof r))
)
)
(setq
r (getstring
(strcat "\nEnter a new value for AREACONV <"
(getenv "AreaConv")
">: "
)
)
)
)
)
(princ "\nNeeds a strictly positive number")
)
(or (= r "") (setenv "AreaConv" r))
(princ)
)
;;;===============================================;;;
;;; AREAPREC (gile)
;;; Edit AREACONV sysvar value
;;; This registered sysvar manages the number of decimal displayed
(defun c:AreaPrec ()
(or (getenv "AreaPrec")
(setenv "AreaPrec" (itoa (getvar "LUPREC")))
)
(while
(not
((lambda (r)
(or (= r "")
(and
(= 'INT (type (read r)))
(<= 0 (atoi r))
)
)
)
(setq
r (getstring
(strcat "\nEnter a new value for AREAPREC <"
(getenv "AreaPrec")
">: "
)
)
)
)
)
(princ "\nNeeds a strictly positive number")
)
(or (= r "") (setenv "AreaPrec" r))
(princ)
)
;;;================== SUB ROUTINES ==================;;;
;;; gc:TotalAreaUpd (gile)
;;; Update of a "TotalArea" block attributes
(defun gc:TotalAreaUpd (blk lst / *error* dz hand tot pl new)
(vl-load-com)
(defun *error* (msg)
(or (= msg "Function cancelled")
(princ (strcat "\Error: " msg))
)
(setvar "DIMZIN" dz)
(princ)
)
(setq dz (getvar "DIMZIN"))
(setvar "DIMZIN" (Boole 2 (getvar "DIMZIN") 8))
(if lst
(progn
(setq tot 0.0)
(foreach obj lst
(if obj
(setq tot (+ tot (vla-get-Area obj))
new (cons (vla-get-Handle obj) new)
)
)
)
(foreach att (vlax-invoke blk 'GetAttributes)
(cond
((= (vla-get-TagString att) "AREA")
(vla-put-Textstring
att
(rtos (/ tot (distof (getenv "areaConv")))
2
(atoi (getenv "AreaPrec"))
)
)
)
((= (vla-get-TagString att) "NOBJ")
(vla-put-TextString att (itoa (length new)))
)
)
)
)
(foreach att (vlax-invoke blk 'GetAttributes)
(cond
((= (vla-get-TagString att) "AREA")
(vla-put-Textstring
att
(rtos 0.0 2 (atoi (getenv "AreaPrec")))
)
)
((= (vla-get-TagString att) "NOBJ")
(vla-put-TextString att "0")
)
)
)
)
(setvar "DIMZIN" dz)
)
;;;===============================================;;;
;;; gc:AreaGet (gile)
;;; Returns a list which countains a "TotalArea" block and all linked objects
;;; Linked objects are highlighted while the cursor is on the block
(defun gc:AreaGet (msg / ss l1 gr ent l2 l3)
(defun *error* (msg)
(or (= msg "Function cancelled")
(princ (strcat "\nError: " msg))
)
(mapcar (function (lambda (x) (vla-highlight x :vlax-false)))
l2
)
(princ)
)
(princ msg)
(while (and (setq gr (grread T 4 2)) (= (car gr) 5))
(if (and (setq ent (nentselp (cadr gr)))
(or
(and
(caddr ent)
(setq ent (last (last ent)))
)
(setq ent (cdr (assoc 330 (entget (car ent)))))
)
)
(if (= (cdr (assoc 2 (entget ent))) "TotalArea")
(progn
(setq blk T
l1 (vlax-ldata-get ent "TotalArea")
)
(foreach h l1
(if (setq obj (gc:HandleToObject h))
(progn
(vla-highlight obj :vlax-true)
(or (member obj l2) (setq l2 (cons obj l2)))
)
)
)
)
)
(progn
(mapcar (function (lambda (x) (vla-highlight x :vlax-false)))
l2
)
(setq l2 nil
blk nil
)
)
)
)
(if (and (= (car gr) 3) l2)
(list (vlax-ename->vla-object ent) l2)
(mapcar (function (lambda (x) (vla-highlight x :vlax-false)))
l2
)
)
)
;;;===============================================;;;
;;; gc:AreaUpdAll
;;; Updates all "ToTalArea" block references
(defun gc:AreaUpdAll (/ ss)
(if (ssget "_X" '((0 . "INSERT") (2 . "TotalArea")))
(progn
(vlax-for blk (setq ss (vla-get-activeSelectionSet *acdoc*))
(gc:TotalAreaUpd
blk
(mapcar 'gc:HandleToObject
(vlax-ldata-get blk "TotalArea")
)
)
)
(vla-delete ss)
)
)
)
;;;===============================================;;;
;;; gc:GetAreaObjectReactor
;;; Returns the reactor linked to the object
;;; Arguments
;;; obj : owner object (vla-object)
;;; blk : the block linked to object (vla-object)
;;;
;;; Retour : the reactor or nil
(defun gc:GetAreaObjectReactor (obj blk / lst rea loop)
(setq lst (cdr (assoc :VLR-Object-Reactor (vlr-reactors)))
loop T
)
(while (and lst loop)
(setq rea (car lst)
lst (cdr lst)
)
(if (and
(equal (vlr-owners rea) (list obj))
(= (vlr-data rea) (vla-get-Handle blk))
)
(setq loop nil)
(setq rea nil)
)
)
rea
)
;;;===============================================;;;
;;; gc:GetItem (gile)
;;; Returns a vla-object if item exists in the collection
;;;
;;; Arguments
;;; col : the collection (vla-object)
;;; name : the item name (string) or its index (integer)
;;;
;;; Return : the vla-object or nil
(defun gc:GetItem (col name / obj)
(vl-catch-all-apply
(function (lambda () (setq obj (vla-item col name))))
)
obj
)
;;;===============================================;;;
;; gc:HandleToObject (gile)
;; Returns the VLA-OBJECT about its handle
;;; Argument
;;; handle : the object handle
;;;
;;; Return : the vla-object or nil
(defun gc:HandleToObject (handle / obj)
(vl-catch-all-apply
(function
(lambda ()
(setq obj (vla-HandleToObject
(vla-get-ActiveDocument (vlax-get-acad-object))
handle
)
)
)
)
)
obj
)
;;;================== CALLBACKS ==================;;;
(defun GC:AREAOBJECTERASED (own rea lst)
(vlr-remove rea)
)
;;;===============================================;;;
(defun GC:AREAOBJECTUNERASED (own rea lst)
(if (setq blk (gc:HandleToObject (vlr-data rea)))
(vlr-add rea)
(vlr-remove rea)
)
)
;;;===============================================;;;
(defun GC:AREAOBJECTCLOSED (own rea lst / blk data)
(if (setq blk (gc:HandleToObject (vlr-data rea)))
(if (setq data (vlax-ldata-get blk "TotalArea"))
(gc:TotalAreaUpd blk (mapcar 'gc:HandleToObject data))
)
(vlr-remove rea)
)
)
;;;==================== CREATING REACTORS WHILE LOADING ====================;;;
((lambda (/ ss obj)
(foreach r (cdr (assoc :VLR-Object-Reactor (vlr-reactors)))
(if (member '(:VLR-erased . GC:AREAOBJECTERASED)
(vlr-reactions r)
)
(vlr-remove r)
)
)
(if (ssget "_X" '((0 . "INSERT") (2 . "TotalArea")))
(progn
(vlax-for blk (setq ss (vla-get-ActiveSelectionSet *acdoc*))
(foreach hand (vlax-ldata-get blk "TotalArea")
(if (setq obj (gc:HandleToObject hand))
(vlr-object-reactor
(list obj)
(vla-get-Handle blk)
'((:vlr-erased . GC:AREAOBJECTERASED)
(:vlr-unerased . GC:AREAOBJECTUNERASED)
(:vlr-objectClosed . GC:AREAOBJECTCLOSED)
)
)
)
)
)
(vla-delete ss)
)
)
)
)
(princ)

;| TOTALAREA version 4.02 (Gile)
Set the controls AREABOX, TOTALAREA, AREAEDIT, AREASHOW and AREACONV
- Block "TotalArea":
A definition block named "TotalArea" must be present in the drawing collection or
as file "TotalArea.dwg" in an AutoCAD search path directory.
This block must contain at least three attributes with "LABEL", "UNIT and "AREA" tags.
"AREA" will be automatically populate with the sum of the areas of objects linked to it.
(arc, circle, ellipse, polylines, spline, hatch, region, mpolygon)
If it contains a fourth attribute with "NOBJ" tag, it will also be
automatically populate with the number of items linked to the block.

Format the display of the attribute "AREA":
It is possible to assign a conversion factor to the value of the attribute.
This value is managed with a variable (AREACONV) that can be changed with the
command of the same name.
The display the number of decimal is managed by a variable too (AREAPREC)
|;
;;;===============================================;;;
(vl-load-com)
(or *acdoc*
    (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
)
;;; AREABOX (gile)
;;; Dialog Box for commands calling
(defun c:Areabox (/ tmp file what_next dcl_id result)
  (or (getenv "AreaConv") (setenv "AreaConv" "1"))
  (or (getenv "AreaPrec")
      (setenv "AreaPrec" (itoa (getvar "LUPREC")))
  )
  (setq tmp  (vl-filename-mktemp "Tmp.dcl")
 file (open tmp "w")
  )
  (write-line
    "AreaBox:dialog{label="总面积";
    :boxed_column{label="命令";:row{
    :button{label="总面积";key="(c:totalarea)";width=16;}
    spacer;:text{label="插入并连接";width= 20;}}
    :row{
    :button{label="面积编辑";key="(c:areaedit)";width=16;}
    spacer;:text{label="增加或移除链接";width= 20;}}
    :row{
    :button{label="面积显示";key="(c:areashow)";width=16;}
    spacer;:text{label="显示链接对象";width= 20;}}}
    :boxed_column{label="系统变量";:row{
    :text{key="ConvValue";width= 20;}
    :button{label="AreaConv";key="areaconv";width=16;}}
    :row{:text{key="PrecValue";width= 20;}
    :button{label="AreaPrec";key="areaprec";width=16;}}}
    spacer;cancel_button;}"
    file
  )
  (close file)
  (setq dcl_id (load_dialog tmp))
  (setq what_next 2)
  (while (>= what_next 2)
    (if (not (new_dialog "AreaBox" dcl_id))
      (exit)
    )
    (set_tile "ConvValue"
       (strcat "AREACONV = " (getenv "AreaConv"))
    )
    (set_tile "PrecValue"
       (strcat "AREAPREC = " (getenv "AreaPrec"))
    )
    (foreach k '("(c:totalarea)"
   "(c:areaedit)"
   "(c:areashow)"
  )
      (action_tile k "(setq result $key) (done_dialog)")
    )
    (action_tile "areaconv" "(done_dialog 3)")
    (action_tile "areaprec" "(done_dialog 4)")
    (action_tile "cancel" "(done_dialog 0)")
    (setq what_next (start_dialog))
    (cond
      ((= what_next 3) (c:areaconv))
      ((= what_next 4) (c:areaprec))
    )
  )
  (unload_dialog dcl_id)
  (vl-file-delete tmp)
  (and result (eval (read result)))
  (princ)
)
;;;===============================================;;;
;; TotalAreaBox
;; TotalArea command dialog box
(defun TotalAreaBox (/      lbl     unt     scl     lay     lst
       tmp     file    what_next      dcl_id  data
       result
      )
  (or (getenv "AreaConv") (setenv "AreaConv" "1"))
  (or (getenv "AreaPrec")
      (setenv "AreaPrec" (itoa (getvar "LUPREC")))
  )
  (or (setq lbl (vlax-ldata-get "TotalArea" "lbl"))
      (setq lbl (vlax-ldata-put "TotalArea" "lbl" "Total area"))
  )
  (or (setq unt (vlax-ldata-get "TotalArea" "unt"))
      (setq unt (vlax-ldata-put "TotalArea" "unt" "m"))
  )
  (or (setq scl (vlax-ldata-get "TotalArea" "scl"))
      (setq scl (vlax-ldata-put "TotalArea" "scl" 1))
  )
  (while (setq lay (tblnext "LAYER" (not lay)))
    (setq lst (cons (cdr (assoc 2 lay)) lst))
  )
  (setq lst (vl-sort lst '<))
  (setq lay (getvar "CLAYER"))
  (setq tmp  (vl-filename-mktemp "Tmp.dcl")
 file (open tmp "w")
  )
  (write-line
    "AreaBox:dialog{label="总面积";
    :boxed_column{label="属性";
    :row{:text{label="Label";}
    :edit_box{key="lbl";width=24;}}
    :row{:text{label="单位";}
    :edit_box{key="unt";fixed_width=true;}}}
    :boxed_column{label="属性";
    :row{:text{label="比例";}
    :edit_box{key="scl";fixed_width=true;}}
    :popup_list{label="图层";key="lay";}}
    :boxed_column{label="变量";:row{
    :text{key="ConvValue";width= 20;}
    :button{label="AreaConv";key="areaconv";width=16;}}
    :row{:text{key="PrecValue";width= 20;}
    :button{label="AreaPrec";key="areaprec";width=16;}}}
    spacer;ok_cancel_help;}"
    file
  )
  (close file)
  (setq dcl_id (load_dialog tmp))
  (setq what_next 2)
  (while (>= what_next 2)
    (if (not (new_dialog "AreaBox" dcl_id))
      (exit)
    )
    (start_list "lay")
    (mapcar 'add_list lst)
    (end_list)
    (set_tile "lbl" lbl)
    (set_tile "unt" unt)
    (set_tile "scl" (rtos scl))
    (set_tile "lay" (itoa (vl-position lay lst)))
    (set_tile "ConvValue"
       (strcat "AREACONV = " (getenv "AreaConv"))
    )
    (set_tile "PrecValue"
       (strcat "AREAPREC = " (getenv "AreaPrec"))
    )
    (action_tile "lbl" "(setq lbl $value)")
    (action_tile "unt" "(setq unt $value)")
    (action_tile
      "scl"
      "(if (< 0 (distof $value))
 (setq scl (distof $value))
 (progn (alert "Needs a valid scale.")
   (setq scl (vlax-ldata-get "TotalArea" "scl"))
   (set_tile "scl" (rtos scl))
   (mode_tile "scl" 2)))"
    )
    (action_tile "lay" "(setq lay (nth (atoi $value) lst))")
    (action_tile "areaconv" "(done_dialog 3)")
    (action_tile "areaprec" "(done_dialog 4)")
    (action_tile "help" "(done_dialog 5)")
    (action_tile "cancel" "(done_dialog 0)")
    (action_tile
      "accept"
      "(setq result (list lbl unt scl lay))
      (vlax-ldata-put "TotalArea" "lbl" lbl)
      (vlax-ldata-put "TotalArea" "unt" unt)
      (vlax-ldata-put "TotalArea" "scl" scl)
      (done_dialog 1)"
    )
    (setq what_next (start_dialog))
    (cond
      ((= what_next 3) (c:areaconv))
      ((= what_next 4) (c:areaprec))
      ((= what_next 5) (help "TotalArea"))
    )
  )
  (unload_dialog dcl_id)
  (vl-file-delete tmp)
  result
)
;;;===============================================;;;
;;; TOTALAREA (gile)
;;; Insert "TotalArea" block which "AREA" attribute value equals to
;;; the sum of selected objects areas
(defun c:TotalArea (/ *error* space dz bloc tot ss lst ins scl blk)
  (defun *error* (msg)
    (or (= msg "Function cancelled")
 (princ (strcat "\Error: " msg))
    )
    (setvar "DIMZIN" dz)
    (vla-EndUndoMark *acdoc*)
    (princ)
  )
  (setq Space (if (= (getvar "CVPORT") 1)
  (vla-get-PaperSpace *acdoc*)
  (vla-get-ModelSpace *acdoc*)
       )
 dz    (getvar "DIMZIN")
  )
  (if (or
 (gc:GetItem
   (vla-get-Blocks *acdoc*)
   (setq bloc "TotalArea")
 )
 (findfile (setq bloc "TotalArea.dwg"))
      )
    (if (setq data (TotalAreaBox))
      (if
 (ssget
   '((-4 . "<OR")
     (0 . "ARC,CIRCLE,ELLIPSE,LWPOLYLINE,HATCH,MPOLYGON,REGION")
     (-4 . "<AND")
     (0 . "POLYLINE")
     (-4 . "<NOT")
     (-4 . "&")
     (70 . 120)
     (-4 . "NOT>")
     (-4 . "AND>")
     (-4 . "<AND")
     (0 . "SPLINE")
     (-4 . "&")
     (70 . 8)
     (-4 . "AND>")
     (-4 . "OR>")
    )
 )
  (progn
    (setq tot 0.0)
    (vla-StartUndoMark *acdoc*)
    (vlax-for obj (setq ss (vla-get-ActiveSelectionset *acdoc*))
      (setq tot (+ tot (vla-get-Area obj))
     lst (cons obj lst)
      )
    )
    (vla-delete ss)
    (initget 1)
    (setq ins (getpoint "\nSpecify insertion point: ")
   scl (caddr data)
   blk
       (vla-insertBlock
         Space
         (vlax-3d-point (trans ins 1 0))
         bloc
         scl
         scl
         scl
         0.0
       )
    )
    (vla-put-layer blk (cadddr data))
    (setvar "DIMZIN" (Boole 2 (getvar "DIMZIN") 8))
    (foreach att (vlax-invoke blk 'GetAttributes)
      (cond
        ((= (vla-get-TagString att) "LABEL")
  (vla-put-TextString att (car data))
        )
        ((= (vla-get-TagString att) "UNIT")
  (vla-put-TextString att (cadr data))
        )
        ((= (vla-get-TagString att) "AREA")
  (vla-put-Textstring
    att
    (rtos (/ tot (distof (getenv "areaConv")))
   2
   (atoi (getenv "AreaPrec"))
    )
  )
        )
        ((= (vla-get-TagString att) "NOBJ")
  (vla-put-TextString att (itoa (length lst)))
        )
      )
    )
    (vlax-ldata-put
      blk
      "TotalArea"
      (mapcar 'vla-get-Handle lst)
    )
    (setvar "DIMZIN" dz)
    ;;------------------------------------------------------------------;;
    ;; Creating reactor
    (foreach obj lst
      (vlr-object-reactor
        (list obj)
        (vla-get-Handle blk)
        '((:vlr-erased . GC:AREAOBJECTERASED)
   (:vlr-unerased . GC:AREAOBJECTUNERASED)
   (:vlr-objectClosed . GC:AREAOBJECTCLOSED)
  )
      )
    )
    ;;------------------------------------------------------------------;;
    (vla-EndUndoMark *acdoc*)
  )
      )
    )
    (princ "\n"TotalArea" block can't be found.")
  )
  (princ)
)
;;------------------------------------------------------------------;;
;;; AREAEDIT (gile)
;;; Add or remove links to "TotalArea" block
(defun c:AreaEdit (/ *error* lst blk obj elst rea)
  (defun *error* (msg)
    (or (= msg "Function cancelled")
 (princ (strcat "\Error: " msg))
    )
    (mapcar (function (lambda (x) (vla-highlight x :vlax-false)))
     lst
    )
    (vla-EndUndoMark *acdoc*)
    (princ)
  )
  (sssetfirst nil nil)
  (if (setq lst (gc:AreaGet "\nSelect the block to edit: "))
    (progn
      (setq blk (car lst)
     lst (cadr lst)
      )
      (vla-StartUndoMark *acdoc*)
      (while (setq obj
      (car
        (entsel
   "\nSelect an object to add or remove: "
        )
      )
      )
 (setq elst (entget obj))
 (if (or
       (member (cdr (assoc 0 elst))
        '("ARC"       "CIRCLE"     "ELLIPSE"
   "LWPOLYLINE"  "HATCH"     "MPOLYGON"
   "REGION"
         )
       )
       (and (= (cdr (assoc 0 elst)) "POLYLINE")
     (zerop (logand 120 (cdr (assoc 70 elst))))
       )
       (and (= (cdr (assoc 0 elst)) "SPLINE")
     (= 8 (logand 8 (cdr (assoc 70 elst))))
       )
     )
   (if (member (setq obj (vlax-ename->vla-object obj)) lst)
     (progn
       (setq lst (vl-remove obj lst))
       (vla-highlight obj :vlax-false)
       (if (setq rea (gc:GetAreaObjectReactor obj blk))
  (vlr-remove rea)
       )
     )
     (progn
       (setq lst (cons obj lst))
       (vla-highlight obj :vlax-true)
       (vlr-object-reactor
  (list obj)
  (vla-get-Handle blk)
  '((:vlr-erased . GC:AREAOBJECTERASED)
    (:vlr-unerased . GC:AREAOBJECTUNERASED)
    (:vlr-objectClosed . GC:AREAOBJECTCLOSED)
   )
       )
     )
   )
 )
 (gc:TotalAreaUpd blk lst)
      )
      (mapcar (function (lambda (x) (vla-highlight x :vlax-false)))
       lst
      )
      (vla-EndUndoMark *acdoc*)
    )
  )
  (princ)
)
;;;===============================================;;;
;;; AREASHOW (gile)
;;; Highlight the linked objects to the block the cursor is on
(defun c:AreaShow (/ blk lst)
  (and (setq lst (gc:AreaGet ""))
       (mapcar (function (lambda (x) (vla-highlight x :vlax-false)))
        (cadr lst)
       )
  )
  (princ)
)
;;;===============================================;;;
;;; AREACONV (gile)
;;; Edit AREACONV sysvar value
;;; This sysvar is registered and manages the area unit conversion factor
;;; example : 10000 for cm?-> m? 1000000 (or 1e6) for m?-> km?
(defun c:AreaConv ()
  (or (getenv "AreaConv") (setenv "AreaConv" "1"))
  (while
    (not
      ((lambda (r)
  (or (= r "")
      (< 0 (distof r))
  )
       )
 (setq
   r (getstring
       (strcat "\nEnter a new value for AREACONV <"
        (getenv "AreaConv")
        ">: "
       )
     )
 )
      )
    )
     (princ "\nNeeds a strictly positive number")
  )
  (or (= r "") (setenv "AreaConv" r))
  (princ)
)
;;;===============================================;;;
;;; AREAPREC (gile)
;;; Edit AREACONV sysvar value
;;; This registered sysvar manages the number of decimal displayed
(defun c:AreaPrec ()
  (or (getenv "AreaPrec")
      (setenv "AreaPrec" (itoa (getvar "LUPREC")))
  )
  (while
    (not
      ((lambda (r)
  (or (= r "")
      (and
        (= 'INT (type (read r)))
        (<= 0 (atoi r))
      )
  )
       )
 (setq
   r (getstring
       (strcat "\nEnter a new value for AREAPREC <"
        (getenv "AreaPrec")
        ">: "
       )
     )
 )
      )
    )
     (princ "\nNeeds a strictly positive number")
  )
  (or (= r "") (setenv "AreaPrec" r))
  (princ)
)
;;;================== SUB ROUTINES ==================;;;
;;; gc:TotalAreaUpd (gile)
;;; Update of a "TotalArea" block attributes
(defun gc:TotalAreaUpd (blk lst / *error* dz hand tot pl new)
  (vl-load-com)
  (defun *error* (msg)
    (or (= msg "Function cancelled")
 (princ (strcat "\Error: " msg))
    )
    (setvar "DIMZIN" dz)
    (princ)
  )
 (setq dz (getvar "DIMZIN"))
  (setvar "DIMZIN" (Boole 2 (getvar "DIMZIN") 8))
  (if lst
    (progn
      (setq tot 0.0)
      (foreach obj lst
 (if obj
   (setq tot (+ tot (vla-get-Area obj))
  new (cons (vla-get-Handle obj) new)
   )
 )
      )
      (foreach att (vlax-invoke blk 'GetAttributes)
 (cond
   ((= (vla-get-TagString att) "AREA")
    (vla-put-Textstring
      att
      (rtos (/ tot (distof (getenv "areaConv")))
     2
     (atoi (getenv "AreaPrec"))
      )
    )
   )
   ((= (vla-get-TagString att) "NOBJ")
    (vla-put-TextString att (itoa (length new)))
   )
 )
      )
    )
    (foreach att (vlax-invoke blk 'GetAttributes)
      (cond
 ((= (vla-get-TagString att) "AREA")
  (vla-put-Textstring
    att
    (rtos 0.0 2 (atoi (getenv "AreaPrec")))
  )
 )
 ((= (vla-get-TagString att) "NOBJ")
  (vla-put-TextString att "0")
 )
      )
    )
  )
  (setvar "DIMZIN" dz)
)
;;;===============================================;;;
;;; gc:AreaGet (gile)
;;; Returns a list which countains a "TotalArea" block and all linked objects
;;; Linked objects are highlighted while the cursor is on the block
(defun gc:AreaGet (msg / ss l1 gr ent l2 l3)
  
  (defun *error* (msg)
    (or (= msg "Function cancelled")
 (princ (strcat "\nError: " msg))
    )
    (mapcar (function (lambda (x) (vla-highlight x :vlax-false)))
     l2
    )
    (princ)
  )
  
  (princ msg)
  (while (and (setq gr (grread T 4 2)) (= (car gr) 5))
    (if (and (setq ent (nentselp (cadr gr)))
      (or
        (and
   (caddr ent)
   (setq ent (last (last ent)))
        )
        (setq ent (cdr (assoc 330 (entget (car ent)))))
      )
 )
      (if (= (cdr (assoc 2 (entget ent))) "TotalArea")
 (progn
   (setq blk T
  l1  (vlax-ldata-get ent "TotalArea")
   )
   (foreach h l1
     (if (setq obj (gc:HandleToObject h))
       (progn
  (vla-highlight obj :vlax-true)
  (or (member obj l2) (setq l2 (cons obj l2)))
       )
     )
   )
 )
      )
      (progn
 (mapcar (function (lambda (x) (vla-highlight x :vlax-false)))
  l2
 )
 (setq l2  nil
       blk nil
 )
      )
    )
  )
  (if (and (= (car gr) 3) l2)
    (list (vlax-ename->vla-object ent) l2)
    (mapcar (function (lambda (x) (vla-highlight x :vlax-false)))
     l2
    )
  )
)
;;;===============================================;;;
;;; gc:AreaUpdAll
;;; Updates all "ToTalArea" block references
(defun gc:AreaUpdAll (/ ss)
  (if (ssget "_X" '((0 . "INSERT") (2 . "TotalArea")))
    (progn
      (vlax-for blk (setq ss (vla-get-activeSelectionSet *acdoc*))
 (gc:TotalAreaUpd
   blk
   (mapcar 'gc:HandleToObject
    (vlax-ldata-get blk "TotalArea")
   )
 )
      )
      (vla-delete ss)
    )
  )
)
;;;===============================================;;;
;;; gc:GetAreaObjectReactor
;;; Returns the reactor linked to the object
;;; Arguments
;;; obj : owner object (vla-object)
;;; blk : the block linked to object (vla-object)
;;;
;;; Retour : the reactor or nil
(defun gc:GetAreaObjectReactor (obj blk / lst rea loop)
  (setq lst  (cdr (assoc :VLR-Object-Reactor (vlr-reactors)))
 loop T
  )
  (while (and lst loop)
    (setq rea (car lst)
   lst (cdr lst)
    )
    (if (and
   (equal (vlr-owners rea) (list obj))
   (= (vlr-data rea) (vla-get-Handle blk))
 )
      (setq loop nil)
      (setq rea nil)
    )
  )
  rea
)
;;;===============================================;;;
;;; gc:GetItem (gile)
;;; Returns a vla-object if item exists in the collection
;;;
;;; Arguments
;;; col : the collection (vla-object)
;;; name : the item name (string) or its index (integer)
;;;
;;; Return : the vla-object or nil
(defun gc:GetItem (col name / obj)
  (vl-catch-all-apply
    (function (lambda () (setq obj (vla-item col name))))
  )
  obj
)
;;;===============================================;;;
;; gc:HandleToObject (gile)
;; Returns the VLA-OBJECT about its handle
;;; Argument
;;; handle : the object handle
;;;
;;; Return : the vla-object or nil
(defun gc:HandleToObject (handle / obj)
  (vl-catch-all-apply
    (function
      (lambda ()
 (setq obj (vla-HandleToObject
      (vla-get-ActiveDocument (vlax-get-acad-object))
      handle
    )
 )
      )
    )
  )
  obj
)
;;;================== CALLBACKS ==================;;;
(defun GC:AREAOBJECTERASED (own rea lst)
  (vlr-remove rea)
)
;;;===============================================;;;
(defun GC:AREAOBJECTUNERASED (own rea lst)
  (if (setq blk (gc:HandleToObject (vlr-data rea)))
    (vlr-add rea)
    (vlr-remove rea)
  )
)
;;;===============================================;;;
(defun GC:AREAOBJECTCLOSED (own rea lst / blk data)
  (if (setq blk (gc:HandleToObject (vlr-data rea)))
    (if (setq data (vlax-ldata-get blk "TotalArea"))
      (gc:TotalAreaUpd blk (mapcar 'gc:HandleToObject data))
    )
    (vlr-remove rea)
  )
)
;;;==================== CREATING REACTORS WHILE LOADING ====================;;;
((lambda (/ ss obj)
   (foreach r (cdr (assoc :VLR-Object-Reactor (vlr-reactors)))
     (if (member '(:VLR-erased . GC:AREAOBJECTERASED)
   (vlr-reactions r)
  )
       (vlr-remove r)
     )
   )
   (if (ssget "_X" '((0 . "INSERT") (2 . "TotalArea")))
     (progn
       (vlax-for blk (setq ss (vla-get-ActiveSelectionSet *acdoc*))
  (foreach hand (vlax-ldata-get blk "TotalArea")
    (if (setq obj (gc:HandleToObject hand))
      (vlr-object-reactor
        (list obj)
        (vla-get-Handle blk)
        '((:vlr-erased . GC:AREAOBJECTERASED)
   (:vlr-unerased . GC:AREAOBJECTUNERASED)
   (:vlr-objectClosed . GC:AREAOBJECTCLOSED)
  )
      )
    )
  )
       )
       (vla-delete ss)
     )
   )
 )
)
(princ)

xianaihua · 发表于 2009-12-18 21:26

glowz · 发表于 2009-12-19 14:05

好像很高级的样子，如何用呢？？代码下载下来后用不了

xianaihua · 发表于 2009-12-19 14:50

使用方法：

1：打开一个图形制作一个块，该块含有"LABEL", "UNIT "AREA" 以及"NOBJ"提示的属性。然后将该图形保存到cad支持路径下；

2：另打开一个图形，加载该程序，在命令行输入命令TotalArea；

3：在弹出对话框后，输入所选对象的标签（LABEL），确定；

4：选择要计算的对象，在点取数据要放置的位置；

5：同4，计算其他对象的面积；

6：如果选择所有的对象，将计算总面积；

7：完成后，修改任何一个对象，面积数据也会发生变化。

liminnet · 发表于 2009-12-19 15:10

提示: 作者被禁止或删除内容自动屏蔽

xianaihua · 发表于 2009-12-19 15:29

liminnet · 发表于 2009-12-19 15:32

提示: 作者被禁止或删除内容自动屏蔽

xianaihua · 发表于 2009-12-19 15:39

反应器的目的在当前计算时是不起作用的，只有在计算完成后，某个对象要进行修改或变动时才起作用。不知你能明白吗？

liminnet · 发表于 2009-12-19 15:43

提示: 作者被禁止或删除内容自动屏蔽

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

[基础] area calculation autolisp

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源

浏览过的版块

liminnet liminnet 当前离线积分 9737 明经币个注册时间 2007-8-22 在线时间小时威望金钱个贡献激情	发表于 2009-12-19 15:10 \| 显示全部楼层提示: 作者被禁止或删除内容自动屏蔽

	回复支持反对使用道具举报显身卡

liminnet liminnet 当前离线积分 9737 明经币个注册时间 2007-8-22 在线时间小时威望金钱个贡献激情	发表于 2009-12-19 15:32 \| 显示全部楼层提示: 作者被禁止或删除内容自动屏蔽

	回复支持反对使用道具举报显身卡

liminnet liminnet 当前离线积分 9737 明经币个注册时间 2007-8-22 在线时间小时威望金钱个贡献激情	发表于 2009-12-19 15:43 \| 显示全部楼层提示: 作者被禁止或删除内容自动屏蔽

	回复支持反对使用道具举报显身卡