[编程交流] 区域标签更改

(defun C:AREATT ( / en obj tblobj row col lst pt rows cols what fld)
;;;; Command: AREATT (AREA to table)
;;;; Posted http://dwg.ru/f/showthread.php?t=14528
;;;; This command allows you to insert into the specified table cell and the subsequent
;;;; Text field (FIELD), containing the value of the square of the selected object.
;;;; Depending on the choice of navigation options by rows or columns.
;;;; If rows or columns coming to an end, they are automatically added.
;;;; Formatting cell is taken as specified in the first cell.
;;;; Precision of rounding and scaling factor are given the option "Setting"
;;;; Since this field is associated with a particular object, if you change 
;;;; Object field is recalculated (need updating field) 
;;;; Code can be stored in a file areatt.lsp 
;;;; Possible macro to a button or menu item: 
;;;; ^ C ^ C (if (not C: AREATT) (load "AREATT")); AREATT;  
 (vl-load-com)
 (or *SCALE* (setq *SCALE* 1))
 (or *PREC* (setq *PREC* 2))
 (or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
 (or *SUFF* (setq *SUFF* ""))(or *PREF* (setq *PREF* ""))
 (setq *SUFF* (vl-princ-to-string *SUFF*))
 (setq *PREF* (vl-princ-to-string *PREF*))
 (princ "\nCurrent scale = ")(princ *SCALE*)
 (princ " Current precision = ")(princ *PREC*)
 (princ " Text size = ")(princ *TEXTSIZE*)
 (princ " Prefix= ")(princ *PREF*)(princ " Suffix= ")(princ *SUFF*)
 (setq  tblobj nil tblobj (ssget "_X" '((0 . "ACAD_TABLE"))))
 (setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblobj)))))
 (setq  tblobj nil)
 (cond
  ((and lst
        (or (initget "Row Col Setting _Row Col Setting") t)
        (or (while (=(setq what (getkword "\nNavigate [on tne Row/on the Columns/Setting] <on the Columns>: "))
                     "Setting")
                    (princ "\nNew scale <")(princ *SCALE*)(princ "> : ")
     (initget 6)
     (if (setq en (getdist))(setq *SCALE* en))
     (princ "\nNew  precision <")(princ *PREC*)(princ "> : ")
     (initget 4)
     (if (setq en (getint))(setq *PREC* en))
     (princ "\nNew text size <")(princ *TEXTSIZE*)(princ "> : ")
     (initget 6)
     (if (setq en (getdist))(setq *TEXTSIZE* en))
     (princ "\nPrefix (space - clear) <")(princ *PREF*)(princ "> : ")
     (if (= (setq en (getstring t)) " ")(setq en ""))
     (if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
     (setq en (strcat "\" (vl-string-left-trim "\/" en))))(setq *PREF* en)
     (princ "\nSuffix? (space - clear) <")(princ *SUFF*)(princ "> : ")
     (if (= (setq en (getstring t)) " ")(setq en ""))
     (if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
     (setq en (strcat "\" (vl-string-left-trim "\/" en))))(setq *SUFF* en)
              (initget "Row Col Setting _Row Col Setting")
              )
            t
            )
        (or what (setq what "Col"))
        (or
       (while (null  tblobj)
         (initget 1)
         (setq pt (getpoint "\nSpecify a first table cell:"))
         (mapcar '(lambda (x)
          (or tblobj
              (and
                (= :vlax-true (vla-HitTest x
                              (vlax-3d-point (trans pt 1 0))
                              (vlax-3d-point (trans (getvar "VIEWDIR") 1 0))
                              'row 'col))
                (setq tblobj x)
                )
              )
          )
       lst)
         (if (null  tblobj)(princ " ** missing **"))
         )
       t)
        (or
          (vlax-write-enabled-p tblobj)
          (and
            (princ "\nTable on a locked layer!")
            nil
            )
          )
        (setq pt (vla-GetCellAlignment tblobj row col))
        )
   (setq rows (vla-get-rows tblobj))
   (setq cols (vla-get-columns tblobj))
   (while (setq en (car (entsel "\nSelect the entity to insert it square into the table (ENTER - exit): " )))
     (cond
      ((vlax-property-available-p (setq en (vlax-ename->vla-object en)) 'Area)
         (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId "
            (vl-princ-to-string(Get-ObjectID-x86-x64 en))
               ">%).Area \\f "%lu2%ps["*PREF* "," *SUFF*
               "]%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALE*)"]">%"
               ) ;_ strcat
         )
       (cond
         ((= col cols)
           (vla-insertColumns tblobj col (vla-GetColumnWidth tblobj (1- col)) 1)
           (vla-SetCellAlignment tblobj row col pt)
           (setq rows (vla-get-rows tblobj))
           (setq cols (vla-get-columns tblobj))
           
         )
         ((= row rows)
           (vla-insertRows tblobj row (vla-GetRowHeight tblobj (1- row)) 1)
          (vla-SetCellAlignment tblobj row col pt)
           (setq rows (vla-get-rows tblobj))
           (setq cols (vla-get-columns tblobj))
        )
         (t nil))
       (vla-SetText tblobj row col fld)
       (if (= what "Col")(setq col (1+ col))(setq row (1+ row)))
       
      )
      (t(princ "\nThis primitive can not get property Area!"))
     )
     
   )
  )
  (t
    (princ "\nTables not found!")
  )
 )
 (princ)
)
;;------------------------------------------------ --------
;; Function gets a string representation ObjectID
;; Whether AutoCAD x86 or x64
;; Source: https: / / discussion.autodesk.com / forums / message.jspa? MessageID = 6172961
;; Http://forum.dwg.ru/showthread.php?t=51822
(defun Get-ObjectID-x86-x64 (obj / util)
 (setq util (vla-get-Utility (vla-get-activedocument (vlax-get-acad-object))))
 (if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
 (if (= (type obj) 'VLA-OBJECT)
    (if (> (vl-string-search "x64" (getvar "platform")) 0)
      (vlax-invoke-method util "GetObjectIdString" obj :vlax-False)
      (rtos (vla-get-objectid obj) 2 0)
    )
 )
)