Topic: [XDrX-PlugIn(89)] HATCH area to generate legend table for statistics

[xdcad]

Generate statistical tables in three ways:
1. Layers
2. Color
3. hatch pattern

Code: [Select]

(defun c:XDTB_TJHATCH (/ blk clr e ha hascl head height keyword ln lst lyr
mode name pt row scl ss str tarea tb x y
      )
  (defun _prompt ()
    (xdrx_prompt
      (xdrx-string-multilanguage
"\n统计方式：按*"
"\nStatistical method: press *"
      )
      (cond
((= #mode 0)
(setq head (xdrx-string-multilanguage
      (list "图  例"
    "图  层"
    "数 量"
    "总面积"
      )
      (list "legend"
    "layer"
    "quantity"
    "The total area"
      )
    )
)
(xdrx-string-multilanguage "图层" "Layer")
)
((= #mode 1)
(setq head (xdrx-string-multilanguage
      (list "图  例"
    "颜色号"
    "数 量"
    "总面积"
      )
      (list "Legend"
    "Color"
    "Quantity"
    "The total area"
      )
    )
)
(xdrx-string-multilanguage "颜色" "Color")
)
(t
(setq head (xdrx-string-multilanguage
      (list "图  例"
    "模  式"
    "数 量"
    "总面积"
      )
      (list "Legend"
    "Model"
    "Quantity"
    "The total area"
      )
    )
)
(xdrx-string-multilanguage "模式" "Mode")
)
      )
      "*"
    )
  )
  (defun _keyword (keyword)
    (cond
      ((= keyword "TC")
(setq #mode 0)
      )
      ((= keyword "YS")
(setq #mode 1)
      )
      (t
(setq #mode 2)
      )
    )
    (_prompt)
  )
  (defun _name (x mode)
    (cond
      ((= mode "layer")
(car (xdrx_getpropertyvalue x mode))
      )
      ((= mode "color")
(setq ln (xdrx_getpropertyvalue x mode))
(if (= (type ln) 'LIST)
  (setq ln (apply
     'xdrx_color_rgb2aci
     ln
   )
  )
  (progn
    (if (= ln 256)
      (progn
(setq lyr (cadr (xdrx_getpropertyvalue x "layer")))
(setq ln (xdrx_getpropertyvalue lyr "color"))
      )
      ln
    )
  )
)
        (fix ln)
      )
      (t
(setq ln (xdrx_getpropertyvalue x mode))
      )
    )
  )
  (defun _maketuli (clr mode)
    (setq clr (fix clr))
    (setq name (xdrx_prompt "XD-TJ-HA-" mode "-" clr t))
    (if (not (setq blk (xdrx_object_get "block" name)))
      (progn
(setq e (xdrx_polyline_make
  (xd::pnt:getrecpnts
    '(0 0 0)
    (* scl 10.)
    (* 5 scl)
  )
  t
)
)
(xdrx_setpropertyvalue
  e
  "constantwidth"
  (* scl 0.3)
  "color"
  7
)
(setq ha (xdrx_hatch_make e))
(if (= #mode 2)
  (progn
    (setq hascl (XD::Hatch:GetSclByGap
     mode
     (* 1.414 scl)
   )
    )
    (xdrx_setpropertyvalue
      ha
      "PatternScale"
      hascl
      "patternname"
      (list 1 mode)
    )
  )
)
(xdrx_setpropertyvalue ha "color" clr "patternname" mode)
(xdrx_block_make (strcase name) (list e ha) '(0 0 0.) t)
(xdrx_entity_delete (entlast))
(setq blk (xdrx_object_get "block" name))
(xdrx_entity_setproperty
  (xdrx_block_getentities
    blk
    '
     (
      (0 . "LWPOLYLINE")
     )
  )
  "COLOR"
  7
)
(xdrx_draworder->back
  (xdrx_block_getentities
    blk
    '
     (
      (0 . "HATCH")
     )
  )
)
      )
    )
    blk
  )
  (defun _makelst (ss mode)
    (setq lst (mapcar
'(lambda (x)
   (list (_name x mode) x)
)
(xdrx_pickset->ents ss)
      )
    )
  )
  (defun _getHa (str)
    (cond
      ((= #mode 0)
(setq e (ssget "x" (list (cons 8 str) '(0 . "HATCH")))
      e (ssname e 0)
      clr (xdrx_getpropertyvalue e "color" t)
)
(_makeTuLi clr "SOLID")
      )
      ((= #mode 1)
(_makeTuLi str "SOLID")
      )
      (t
(setq e (ssget "x" (list (cons 2 str)))
      e (ssname e 0)
      clr (xdrx_getpropertyvalue e "color" t)
)
(_makeTuLi clr str)
      )
    )
  )
  (defun _data ()
    (cond
      ((= #mode 0)
(setq lst (_makelst ss "layer"))
      )
      ((= #mode 1)
(setq lst (_makelst ss "color"))
      )
      (t
(setq lst (_makelst ss "patternname"))
      )
    )
    (setq lst (xd::list:groupbyindex lst 1e-3)
  lst (vl-sort lst '(lambda (x y)
      (if (= (type (car x)) 'LIST)
(< (caar x) (caar y))
(< (car x) (car y))
      )
    )
      )
  lst (if (= #mode 1)
(mapcar '(lambda(x)(cons (fix (car x))(cdr x))) lst)
lst)
  lst (mapcar
'(lambda (x)
   (list (_getHa (car x)) (car x) (length (cdr x))
(rtos (apply
'+
(mapcar
   '(lambda (y)
      (xdrx_getpropertyvalue y "area")
    )
   (cdr x)
)
       ) 2 1
)
   )
)
lst
      )
  total (itoa (apply
'+
(mapcar
  'caddr
  lst
)
      )
)
  lst (cons head lst)
  lst (cons (list (xdrx-string-multilanguage "填充面积统计表""Hatch Area Statistics") "" nil nil) lst)
  tarea (mapcar
  'last
  lst
)
  tarea (apply
  '+
  (mapcar
    'atof
    (cddr tarea)
  )
)
  lst (append
lst
(list (list (xdrx-string-multilanguage "合  计""Total") nil total (rtos tarea 2 1)))
      )
    )
  )
  (defun _table ()
    ;(xdrx_draworder->back xd_blks)
    (if (setq pt (getpoint (xdrx-string-multilanguage
     "\n表格插入点<退出>:"
     "\nTable insertion point<Exit>:"
   )
)
)
      (progn
(xd::text:init 1)
(setq tb (XD::Table:MakeFromList lst (trans pt 1 0) #height
(/ #height 2.0)
)
)        ; (setq row (1- (length lst)))
       ; (xdrx_table_MergeCells tb row row
       ; 0 1)
       ; (xdrx_table_SetTextString tb row 0
       ; "合    计")
       ; (xdrx_setpropertyvalue tb
       ; "mergecells" (list row row 0 1)
       ; "textstring" (list row 0 "合
       ; 计") "color" 7)
      )
    )
  )
  (xdrx_begin)
  (xdrx_sysvar_push '("dimzin" 0))
  (if (not #mode)
    (setq #mode 0)
  )
  (if (not #height)
    (setq #height 4.)
  )
  (setq scl (* (xd::var:getratio) (xd::var:getscaleratio)))
  (if (setq height (getreal (strcat (xdrx_prompt
      (xdrx-string-multilanguage
"\n表格字高<"
"\nTable Text Height<"
      )
      #height
      ">:"
      t
    )
    )
   )
      )
    (setq #height height)
  )
  (if (and
(_prompt)
(xdrx_initssget
  (xdrx-string-multilanguage
    "\n选取要统计的填充[图层(TC)/颜色(YS)/模式(MS)]<退出>:"
    "\nSelect the fill to be counted [Layer(TC)/Color(YS)/Mode(MS)]<Exit>:"
  )
  "TC YS MS"
  (xdrx-string-multilanguage
    "移除不统计的填充[添加(A)]<退出>:"
    "Remove uncounted padding [Add(A)]<Exit>:"
  )
  "_keyword"
  ""
)
(setq ss (xdrx_ssget '((0 . "HATCH"))))
      )
    (progn
      (setq #scl (/ #height 4.0))
      (setq lst (_data))
      (_table)
    )
  )
  (xdrx_sysvar_pop)
  (xdrx_end)
  (princ)
)