Narzędzia do zestawień długości i powierzchni.


Recommended Posts

Witam.

Jakiś czas temu Klient podsunął nam możliwość tworzenia zestawień długości elementów z rysunku korzystając a narzędzia LenCal autorstwa Lee McDonnell. Narzędzie jest bardzo przydatne w pracy kosztorysantów , tworzy zestawienie w postaci tabelki z elementów pogrupowanych według koloru czy warstwy.

http://www.cadtutor.net/forum/showthread.php?42734-Line-Length-Calculator

 

Na prośbę Klienta przerobiliśmy program na zliczający powierzchnie z kreskowań.

Poniżej oba programy:

LenCal:

;;;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;;;
;;;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;;;
;;                                                                               ;;
;;                                                                               ;;
;;                       --=={  Length Calculator  }==--                         ;;
;;                                                                               ;;
;;  This program will calculate the total length of user specified objects       ;;
;;  with an optional filter. The Filter may be used to select only those objects ;;
;;  that are on a certain layer, or perhaps have a certain linetype or colour.   ;;
;;                                                                               ;;
;;  The objects included in the calculation can be changed in the 'Options'      ;;
;;  dialog, along with the calculation precision and output type.                ;;
;;                                                                               ;;
;;  The user can choose between three output options: ACAD Table, Txt file, or   ;;
;;  CSV file. If the output is set to ACAD Table, the user may select the        ;;
;;  Table-Style from the Drop-down in the main Dialog.                           ;;
;;                                                                               ;;
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
;;                                                                               ;;
;;  FUNCTION SYNTAX:  LenCal                                                     ;;
;;                                                                               ;;
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
;;                                                                               ;;
;;  AUTHOR:                                                                      ;;
;;                                                                               ;;
;;  Copyright © Lee McDonnell, June 2009. All Rights Reserved.                   ;;
;;                                                                               ;;
;;      { Contact: Lee Mac @ TheSwamp.org, CADTutor.net }                        ;;
;;                                                                               ;;
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
;;                                                                               ;;
;;  VERSION:                                                                     ;;
;;                                                                               ;;
;;    ř 1.0   ~¤~   22nd June 2009       ~¤~   ş First Release                   ;;
;;...............................................................................;;
;;    ř 1.1   ~¤~   22nd June 2009       ~¤~                                     ;;
;;...............................................................................;;
;;    ř 1.2   ~¤~   23rd June 2009       ~¤~                                     ;;
;;...............................................................................;;
;;    ř 1.3   ~¤~   23rd June 2009       ~¤~   ş Fixed bugs.                     ;;
;;...............................................................................;;
;;    ř 1.4   ~¤~   10th December 2009   ~¤~   ş Fixed bugs.                     ;;
;;...............................................................................;;
;;    ř 1.5   ~¤~   21st December 2009   ~¤~   ş Updated Version Checking code.  ;;
;;...............................................................................;;
;;    ř 1.6   ~¤~   22nd December 2009   ~¤~   ş Added option to choose objects  ;;
;;...............................................................................;;
;;    ř 1.7   ~¤~   24th December 2009   ~¤~   ş Improved Options Dialog (with   ;;
;;                                               thanks to CAB for dialog bar).  ;;
;;                                             ş Added Precision Options         ;;
;;                                             ş Added alternative Output        ;;
;;                                               Options                         ;;
;;...............................................................................;;
;;                                                                               ;;
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
;;                                                                               ;;
;;;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;;;
;;;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;;;


(defun c:LenCal (/  ;;  --=={ Local Functions }==--

                    *error*
                    AcCm-Color
                    DCL_Write
                    ErrChk
                    Get_Tbl_Styl
                    GetObjString
                    List_Upd
                    Obj_Settings
                    Pad
                    StrBrk       

                    ;;  --=={ Local Variables }==--

                    BPT
                    COL
                    DCTAG DCTITLE DOC
                    ELST ENT
                    FILE FLST FNAME
                    I
                    LAYLST LAYSTR LENLST LEN_SUB LST LT
                    OFILE OILST OLST OPTITLE OULST
                    SLST SPC SS
                    TBLOBJ TDEF TMP
                    UFLAG
                    WC
                    Z

                    ;;  --=={ Global Variables }==--
                 
                    ; *pop:def*  ~  Popup_List Default
                    ; *lst:def*  ~  List_Box Default
                    ; *tbl:stl*  ~  Table Style Default
                    ; *obj:set*  ~  Object Settings Default [bit-coded]
                    ; *len:pre*  ~  Length Precision Setting
                    ; *len:out*  ~  Output Mode Setting
                 )

  (vl-load-com)

  (setq fname   "LMAC_LenCal_V1.7.dcl"
        dcTitle "Length Calculator V1.7"
        opTitle "Options")

  (or *pop:def* (setq *pop:def* "0"))
  (or *lst:def* (setq *lst:def* "0"))
  (or *tbl:stl* (setq *tbl:stl* "0"))
  (or *obj:set* (setq *obj:set*  7 ))
  (or *len:pre* (setq *len:pre* (getvar "LUPREC")))
  (or *len:out* (setq *len:out* "0"))

  ; 1  = Line
  ; 2  = Lw Polyline
  ; 4  = Polyline
  ; 8  = Arc
  ; 16 = Circle
  ; 32 = Spline
  ; 64 = Ellipse

  (defun *error* (msg)
    (and uFlag (vla-EndUndoMark doc))
    (and dcTag (unload_dialog dcTag))
    (and ofile (close ofile))
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
        (princ (strcat "\n** Error: " msg " **")))
    (princ))
  

  (defun Pad (str chc len)
    (while (< (strlen Str) len)
      (setq str (strcat str (chr chc))))
    str)
  

  (defun StrBrk (str chrc / pos lst)
    (while (setq pos (vl-string-position chrc str))
      (setq lst (cons (substr str 1 pos) lst)
            str (substr str (+ pos 2))))
    (reverse (cons str lst)))
  

  (defun Get_Tbl_Styl (/ tbl lst)
    (if (not (vl-catch-all-error-p
               (setq tbl
                 (vl-catch-all-apply 'vla-item
                   (list (vla-get-Dictionaries
                           (cond (doc) ((vla-get-ActiveDocument
                                          (vlax-get-acad-object))))) "acad_tablestyle")))))
      
      (vlax-for styl tbl
        (setq lst (cons (vla-get-name styl) lst))))
    (reverse lst))
  

  (defun errchk (lst / olst)
    (setq *pop:def* (get_tile "sel_fil") *tbl:stl* (get_tile "tbl_styl"))
    
    (if (not (eq "" (setq *lst:def* (get_tile "sel_sel"))))
      (progn
        (setq olst (mapcar
                     (function
                       (lambda (x)
                         (nth x lst)))
                     (mapcar 'atoi (strbrk *lst:def* 32)))) (done_dialog))      
      (progn
        
        (set_tile "error" "** Nothing Selected **")
        (setq olst nil)))
    
   olst)
  

  (defun list_upd (code / lst wc col ss)
    
    (setq doc (cond (doc) ((vla-get-ActiveDocument
                             (vlax-get-acad-object)))))
    
    (cond (  (eq code 0)
           
             (vlax-for l (vla-get-layers doc)
               (setq lst (cons (vla-get-Name l) lst))))
          
          (  (eq code 1)
           
             (vlax-for l (vla-get-linetypes doc)
               (setq lst (cons (vla-get-Name l) lst)))
           
             (setq lst (vl-remove-if
                         (function
                           (lambda (x)
                             (vl-position
                               (strcase x) '("BYLAYER" "BYBLOCK")))) lst)))
          
          (  (eq code 2)
           
             (vlax-for l (vla-get-layers doc)
               (if (not (vl-position (setq col (vla-get-color l)) lst))
                 (setq lst (cons col lst))))
           
             (if (setq ss (ssget "_X" '((-4 . "<NOT")
                                          (-4 . "<OR")
                                            (62 . 256)
                                            (62 . 0)
                                          (-4 . "OR>")
                                        (-4 . "NOT>"))))
               (foreach x (mapcar
                            (function
                              (lambda (x)
                                (cdr (assoc 62 (entget x)))))
                            (mapcar 'cadr (ssnamex ss)))
                 
                 (if (not (or (null x) (vl-position x lst)))
                   (setq lst (cons x lst)))))
           
             (setq lst (vl-remove-if
                         (function
                           (lambda (x)
                             (vl-position (strcase x) '("BYLAYER" "BYBLOCK"))))
                         (mapcar 'itoa lst)))))

    (if (not (eq "" (setq wc (get_tile "wc_str"))))
      (progn
        (setq lst
          (vl-remove-if-not
            (function
              (lambda (x)
                (wcmatch x wc))) lst))

        (and (not lst) (setq lst '("-- No Matches --")))))
    
    (start_list "sel_sel")
    (mapcar 'add_list (setq lst (acad_strlsort lst)))
    (end_list)
    
  lst)


  (defun AcCm-Color (/ acVer ac)
    (setq acVer (substr (getvar "ACADVER") 1 2))
    
    (if (not (vl-catch-all-error-p
               (setq ac
                 (vl-catch-all-apply 'vla-GetInterfaceObject
                   (list *acad (strcat "AutoCAD.AcCmColor." acVer))))))
      ac nil))
  

  (defun dcl_write (fname / pat path ofile)
    
    (if (not (findfile fname))
      (if (setq pat (findfile "ACAD.PAT"))
        (progn
          (setq path (vl-filename-directory pat))
          
          (or (eq "\\" (substr path (strlen path)))
              (setq path (strcat path "\\")))
          
          (setq ofile (open (strcat path fname) "w"))
          (foreach str
                   
            '("//;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;//"
              "//;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;//"
              "//                                                                               //"
              "//                      --=={  Length Calculator  }==--                          //"
              "//                                                                               //"
              "//             LenCal.dcl for use in conjunction with LenCal.lsp                 //"
              "//             Copyright © June 2009, by Lee McDonnell (Lee Mac)                 //"
              "//                                                                               //"
              "//;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;//"
              "//;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;//"
              ""
              "//  Sub-Assembly Definitions"
              ""
              "butt12 : button { width = 12; fixed_width = true; alignment = centered; }"
              "pop15  : popup_list { width = 15; fixed_width = true; alignment = centered; }"
              "tog    : toggle { alignment = centered; fixed_width = false; }"
              "bar    : image  {  width = 33.26; height = 0.74; color = -15; alignment = centered; }"
              ""
              "//  Main Dialog"
              ""
              "lencal : dialog { key = \"dctitle\";"
              "  : text { value = \"Copyright (c) 2009 Lee McDonnell\"; alignment = right; }"
              "  "
              "  : boxed_column { label = \"Filter\"; fixed_width = true; width = 45;"
              "    : popup_list { key = \"sel_fil\";alignment = centered; }"
              "    spacer_1; "
              "  }"
              "  "
              "  : boxed_column { label = \"Selection\";"
              "    : list_box { key = \"sel_sel\"; multiple_select = true; alignment = centered; }"
              "    : edit_box { key = \"wc_str\" ; label = \"Filter String:\"; edit_limit = 50;"
              "                 value = \"*\"; alignment = centered; }"
              "    spacer_1; "
              "  }"
              "  "
              "  : boxed_column { label = \"Table Style\";"
              "    : popup_list { key = \"tbl_styl\"; alignment = centered; }"
              "    spacer_1; "
              "  }"
              "  "
              "  : errtile { width = 34; }"
              "  : row {"
              "    : butt12 { key = \"opt\"; label = \"Options\"; }"
              "    : butt12 { key = \"accept\"; label = \"OK\"; is_default = true; }"
              "    : butt12 { key = \"cancel\"; label = \"Cancel\"; is_cancel = true; }"
              "  }"
              "}"
              ""
              ""  
              "lencal_opt : dialog { key = \"stitle\";"
              "  spacer;"
              "  : row { alignment = centered; "
              "    spacer;"
              "    : column { alignment = centered;"
              "      : tog { key = \"li\"; label = \"Line\"; }"              
              "      : tog { key = \"pl\"; label = \"Polyline\"; }"
              "    }"
              ""
              "    : column { alignment = centered;"
              "      : tog { key = \"el\"; label = \"Ellipse\";}"
              "      : tog { key = \"ar\"; label = \"Arc\"; }"
              "    }"
              ""
              "    : column { alignment = centered;"
              "      : tog { key = \"lw\"; label = \"LW Polyline\"; }"              
              "      : tog { key = \"ci\"; label = \"Circle\"; }"
              "    }"
              ""
              "    : column { alignment = centered;"
              "      : tog { key = \"sp\"; label = \"Spline\"; }"
              "      : tog { key = \"al\"; label = \"Select All\"; }"
              "    }"
              "  }"
              "  : row {"
              "    : spacer { width = 0.1; fixed_width = true; }"
              "    : bar { key = \"sep1\"; }"
              "    : spacer { width = 0.1; fixed_width = true; }"
              "  }"
              ""
              "  : row { alignment = centered; children_alignment = centered;"
              ""
              "    spacer;"
              "    : column { "
              "      : spacer { height = 0.1; fixed_height = true; }"
              "      : text { label = \"Precision:\"; }"
              "    }"
              "    : pop15 { key = \"prec\"; }"
              ""
              "    spacer;"
              ""
              "    : column {"
              "      : spacer { height = 0.1; fixed_height = true; }"
              "      : text { label = \"Output:\"; }"
              "    }"
              "    : pop15 { key = \"outp\"; }"
              "    spacer;"
              ""
              "  }"
              ""
              "  spacer;"
              "  : row {"
              "    : spacer { width = 0.1; fixed_width = true; }"
              "    : bar { key = \"sep2\"; }"
              "    : spacer { width = 0.1; fixed_width = true; }"
              "  }"
              ""
              "  ok_cancel;"
              "}"
              ""              
              "/*"
              "//;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;"
              ""
              "                          End of Program Code"
              ""
              "//;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;"
              "*/")
            
            (write-line str ofile))
          
          (setq ofile (close ofile))
          
        t)
    nil)
  t))

  
  (defun GetObjString (code / n x str)
    (setq n -1 str "")

    (foreach x '("LINE" "LWPOLYLINE" "POLYLINE" "ARC" "CIRCLE" "SPLINE" "ELLIPSE")
      (if (not (zerop (logand code (expt 2 (setq n (1+ n))))))
        (setq str (strcat str x (chr 44)))))

    (vl-string-right-trim "," str))
  

  (defun Obj_Settings (dcTag / Set_tiles Tile_Bit tmp)

    (defun Set_tiles (code / n x)
      (setq n -1)

      (foreach x '("li" "lw" "pl" "ar" "ci" "sp" "el")
        (if (not (zerop (logand code (expt 2 (setq n (1+ n))))))
          (set_tile x "1")
          (set_tile x "0"))))
    

    (defun Tile_Bit (key value)

      (*

        (if (eq value "0")
          (progn
            (set_tile "al" "0") -1) 1)

        (expt 2 (vl-position key '("li" "lw" "pl" "ar" "ci" "sp" "el")))))
    
      
    (cond (  (not (new_dialog "lencal_opt" dcTag))

             (princ "\n** Options Dialog Could not be Loaded **"))

          (t
             (set_tile "stitle" opTitle)

             (foreach x '("sep1" "sep2")
               (start_image x)
               (mapcar (function vector_image) '(0 0) '(6 5) '(300 300) '(6 5) '(8 7))
               (end_image))

             (Set_tiles *obj:set*)
             (setq tmp *obj:set*) ;; For Cancel

             (start_list "prec")
             (mapcar 'add_list '("0" "0.0" "0.00" "0.000" "0.0000"
                                 "0.00000" "0.000000" "0.0000000" "0.00000000"))
             (end_list)
             (set_tile "prec" (itoa *len:pre*))

             (start_list "outp")
             (mapcar 'add_list '("ACAD Table" "TXT File" "CSV File"))
             (end_list)
             (set_tile "outp" *len:out*)

             (action_tile "prec" "(setq *len:pre* (atoi $value))")
             (action_tile "outp" "(setq *len:out* $value)")
           
             (action_tile "li"   "(setq tmp (+ tmp (Tile_Bit \"li\" $value)))")
             (action_tile "lw"   "(setq tmp (+ tmp (Tile_Bit \"lw\" $value)))")
             (action_tile "pl"   "(setq tmp (+ tmp (Tile_Bit \"pl\" $value)))")
             (action_tile "ar"   "(setq tmp (+ tmp (Tile_Bit \"ar\" $value)))")
             (action_tile "ci"   "(setq tmp (+ tmp (Tile_Bit \"ci\" $value)))")
             (action_tile "sp"   "(setq tmp (+ tmp (Tile_Bit \"sp\" $value)))")
             (action_tile "el"   "(setq tmp (+ tmp (Tile_Bit \"el\" $value)))")
           
             (action_tile "al" "(if (eq \"1\" $value) (progn (setq tmp 127) (Set_Tiles tmp)))")

             (action_tile "accept"
               (vl-prin1-to-string
                 (quote
                   (progn
                     (cond (  (zerop tmp)
                              (alert "Please Select at Least One Object"))

                           (t (setq *obj:set* tmp)
                              (done_dialog)))))))
                           
             (action_tile "cancel" "(done_dialog)")

             (start_dialog))))


  ;;  --=={ Main Function }==--
  
  (setq laystr "")

  (setq doc (vla-get-ActiveDocument
              (setq *acad (vlax-get-Acad-Object)))
        
        spc (if (zerop (vla-get-activespace doc))
              (if (= (vla-get-mspace doc) :vlax-true)
                (vla-get-modelspace doc)
                (vla-get-paperspace doc))
              (vla-get-modelspace doc)))
  

  (cond (  (not (>= (distof (substr (getvar "ACADVER") 1 4)) 16.1))  ;; ACAD 2005
         
           (princ "\n** Table Object Not Available in this Version **"))
        
        (  (eq 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar "CLAYER"))))))
         
           (princ "\n** Current Layer Locked **"))
        
        (  (not (dcl_write fname))
         
           (princ "\n** DCL File Could not be Written **"))
        
        (  (<= (setq dcTag (load_dialog fname)) 0)
         
           (princ "\n** Error Loading DCL **"))
        
        (  (not (new_dialog "lencal" dcTag))
         
           (princ "** Error Loading Length Calculator Dialog **"))
        
        (  (not (setq sLst (get_tbl_styl)))
         
           (princ "\n** Error Loading TableStyles **"))
        
        (t

          (start_list "tbl_styl")
          (mapcar 'add_list (setq sLst (acad_strlsort sLst)))
          (end_list)
         
          (setq fLst '("Layer" "Linetype" "Colour"))
          (start_list "sel_fil")
          (mapcar 'add_list fLst)
          (end_list)

          (set_tile "dctitle" dcTitle)
         
          (set_tile "sel_fil"  *pop:def*)
          (set_tile "sel_sel"  *lst:def*)
          (set_tile "tbl_styl" *tbl:stl*)
          (setq lst (list_upd (atoi *pop:def*)))

          (if (eq "0" *len:out*)
            (mode_tile "tbl_styl" 0)
            (mode_tile "tbl_styl" 1))

          (action_tile "sel_fil"
            (vl-prin1-to-string
              (quote
                (progn
                  (setq lst (list_upd (atoi $value))) (set_tile "error" "")
                  (setq *lst:def* (set_tile "sel_sel" "0"))))))
                
          (action_tile "wc_str"
            (vl-prin1-to-string
              (quote
                (progn
                  (setq lst (list_upd (atoi (get_tile "sel_fil"))))))))

          (action_tile "opt"
            (vl-prin1-to-string
              (quote
                (progn
                  (Obj_Settings dcTag)
                  (if (eq "0" *len:out*)
                    (mode_tile "tbl_styl" 0)
                    (mode_tile "tbl_styl" 1))))))
                  
          (action_tile "accept"  "(setq olst (errchk lst))")
          (action_tile "cancel"  "(done_dialog)")
         
          (start_dialog)
          (setq dcTag (unload_dialog dcTag))

         ;; --=={ Alternative Pre-DCL Selection Method  }==--

          ;|
          (while
            (progn
              (initget 128 "Select List All Done")
              (setq lt (getkword "\nSpecify Linetype to List [Select/List/All] <Done>: "))
              (cond ((not lt) nil) ; Enter
                    ((eq "Done" lt) nil)
                    ((eq "Select" lt)
                     (if (setq ent (car (nentsel "\nSelect Object: ")))
                       (progn
                         (setq lt (strcase
                                    (vla-get-linetype
                                      (setq Obj (vlax-ename->vla-object ent)))))
                         (cond ((eq lt "BYLAYER")
                                (if (vl-catch-all-error-p
                                      (vl-catch-all-apply
                                        (function
                                          (lambda ( )
                                            (setq lt
                                              (strcase
                                                (vla-get-linetype
                                                  (vla-item
                                                    (vla-get-Layers doc) (vla-get-layer Obj)))))))))
                                  (princ "\n<< Error Retrieving Linetype >>")
                                  (if ltlst
                                    (if (vl-position lt ltlst)
                                      (princ (strcat "\n<< " lt " Linetype Already Listed >>"))
                                      (progn
                                        (setq ltlst (cons lt ltlst))
                                        (princ (strcat "\n<< " lt " Linetype Added to List >>"))))
                                    (progn
                                      (setq ltlst (cons lt ltlst))
                                      (princ (strcat "\n<< " lt " Linetype Added to List >>"))))))
                               (t (if ltlst
                                    (if (vl-position lt ltlst)
                                      (princ (strcat "\n<< " lt " Linetype Already Listed >>"))
                                      (progn
                                        (setq ltlst (cons lt ltlst))
                                        (princ (strcat "\n<< " lt " Linetype Added to List >>"))))
                                    (progn
                                      (setq ltlst (cons lt ltlst))
                                      (princ (strcat "\n<< " lt " Linetype Added to List >>")))))))
                       t)) ; Stay in Loop
                    ((eq "List" lt)
                     (if ltlst
                       (progn
                         (foreach lt ltlst
                           (princ (strcat "\n" (Pad lt 46 30)))) (textscr) t) ; Stay in Loop
                       (princ "\n<< No List Created >>")))
                    ((eq "All" lt)
                     (setq ltlst nil)
                     (while (setq l (tblnext "LTYPE" (not l)))
                       (setq ltlst (cons (cdr (assoc 2 l)) ltlst))) nil) ; Exit Loop
                    ((and (snvalid lt)
                          (tblsearch "LTYPE" lt))
                     (setq ltlst (cons (strcase lt) ltlst)))
                    (t (princ "\n<< Linetype not Found in Drawing >>")))))
                    |;

         ;; --===============================================================--
         

          (if (and olst (not (vl-position "-- No Matches --" olst)))
            (progn
                
              (cond (  (eq "0" *pop:def*)  ;; Layer Filtering
                     
                       (foreach lay olst
                         (if (setq z -1 len_sub 0. ss (ssget "_X" (list (cons 0 (GetObjString *obj:set*))
                                                                        (cons 8 lay))))
                           (progn

                             (while (setq ent (ssname ss (setq z (1+ z))))
                               (setq len_sub
                                 (+ len_sub (vlax-curve-getDistatParam ent
                                              (vlax-curve-getEndParam ent)))))

                             (setq lenlst (cons (list lay len_sub) lenlst)))
                           
                           (princ (strcat "\n** No Objects Found on Layer: " lay " **")))))
                    
                    
                    (  (eq "1" *pop:def*)  ;; Linetype Filtering
                       
                       (foreach lt (setq oulst (mapcar (function strcase) olst))
                         
                         (while (setq tdef (tblnext "LAYER" (not tdef)))
                           
                           (if (eq lt (strcase (cdr (assoc 6 tdef))))
                             (setq laystr (strcat (cdr (assoc 2 tdef)) (chr 44) laystr)
                                   laylst (cons   (cdr (assoc 2 tdef)) laylst))))
                         
                         (setq laystr (vl-string-right-trim (chr 44) laystr))
                         
                         (if (setq ss (ssget "_X" (list (cons 0 (GetObjString *obj:set*))
                                                        (cons -4 "<OR")
                                                          (cons 6 lt)
                                                          (cons 8 laystr)
                                                        (cons -4 "OR>"))))
                           (progn
                             
                             (setq Elst
                               (vl-remove-if
                                 (function
                                   (lambda (x / l)
                                     (and
                                       (vl-position
                                         (cdr (assoc 8 (entget x))) laylst)
                                           (setq l (cdr (assoc 6 (entget x))))
                                             (not (eq (strcase l) lt)))))
                                   
                                   (mapcar 'cadr (ssnamex ss))))
                             
                             (setq lenlst
                               (cons
                                 (list lt
                                   (apply (function +)
                                     (mapcar
                                       (function
                                         (lambda (x)
                                           (vlax-curve-getDistatParam x
                                             (vlax-curve-getEndParam x)))) Elst))) lenlst)))
                           
                           (princ (strcat "\n** No Objects Found With Linetype " lt " **")))
                         
                         (setq tdef nil laystr "" laylst nil ss nil)))
                    
                    (  (eq "2" *pop:def*)  ;; Colour Filtering
                     
                       (foreach col (setq oilst (mapcar 'atoi olst))
                         
                         (while (setq tdef (tblnext "LAYER" (not tdef)))
                           
                           (if (eq col (cdr (assoc 62 tdef)))
                             (setq laystr (strcat (cdr (assoc 2 tdef)) (chr 44) laystr)
                                   laylst (cons   (cdr (assoc 2 tdef)) laylst))))
                         
                         (setq laystr (vl-string-right-trim (chr 44) laystr))
                         
                         (if (setq ss (ssget "_X" (list (cons 0 (GetObjString *obj:set*))
                                                        (cons -4 "<OR")
                                                          (cons 62 col)
                                                          (cons 8 laystr)
                                                        (cons -4 "OR>"))))
                           (progn
                             
                             (setq Elst
                               (vl-remove-if
                                 (function
                                   (lambda (x / c)
                                     (and
                                       (vl-position
                                         (cdr (assoc 8 (entget x))) laylst)
                                           (setq c (cdr (assoc 62 (entget x))))
                                             (not (eq c col)))))
                                   
                                   (mapcar 'cadr (ssnamex ss))))
                             
                             (setq lenlst
                               (cons
                                 (list (itoa col)
                                   (apply (function +)
                                     (mapcar
                                       (function
                                         (lambda (x)
                                           (vlax-curve-getDistatParam x
                                             (vlax-curve-getEndParam x)))) Elst))) lenlst)))
                           
                           (princ (strcat "\n** No Objects Found With Colour " (itoa col) " **")))
                         
                         (setq tdef nil laystr "" laylst nil))))

              (if lenlst 

                (cond (  (and (eq "0" *len:out*) (setq bPt (getpoint "\nSelect Point for Table: ")))
                
                         (setq uflag (not (vla-StartUndoMark doc)) i 2)
                  
                         (setq tblObj
                           (vla-addTable spc
                             (vlax-3D-point bPt)
                               (+ 2 (length lenlst)) 2 (* 1.5 (getvar "DIMTXT"))
                                 (* (apply 'max
                                      (mapcar 'strlen
                                        (append (list (strcat (nth (atoi *pop:def*) fLst) " Name"))
                                          (apply 'append
                                            (mapcar
                                              (function
                                                (lambda (x)
                                                  (list (car x) (rtos (cadr x) 2 *len:pre*)))) lenlst))))) 1.5 (getvar "DIMTXT"))))
                  
                       ;;;            (if (setq ac (AcCm-Color))
                       ;;;              (progn
                       ;;;                (vla-setRGB ac 76 153 76)
                       ;;;                  (vla-put-TrueColor tblObj ac)))
                  
                         (vla-put-StyleName tblObj (nth (atoi *tbl:stl*) sLst))
                         (vla-setText tblObj 0 0 "Length Calculation")
                         (vla-setText tblObj 1 0 (strcat (nth (atoi *pop:def*) fLst) " Name"))
                         (vla-setText tblObj 1 1 "Length")
                  
                         (foreach x (reverse lenlst)
                           (vla-setText tblObj i 0 (car x))
                           (vla-setText tblObj i 1 (rtos (cadr x) 2 *len:pre*))
                    
                           (setq i (1+ i)))

                         (setq uflag (vla-EndUndoMark doc)))

                      (  (and (eq "1" *len:out*) (setq file (getfiled "Select Output File" "" "txt" 9)))

                         (setq ofile (open file "a"))
                         (write-line "\nLength Calculation" ofile)
                         (write-line (strcat (Pad (strcat "\n" (nth (atoi *pop:def*) fLst) " Name") 32 31) "Length\n") ofile)

                         (mapcar
                           (function
                             (lambda (x)
                               (write-line (strcat (Pad (car x) 32 30) (rtos (cadr x) 2 *len:pre*)) ofile)))
                           (reverse lenlst))

                         (setq ofile (close ofile)))

                      (  (and (eq "2" *len:out*) (setq file (getfiled "Select Output File" "" "csv" 9)))

                         (setq ofile (open file "a"))
                         (write-line "Length Calculation" ofile)
                         (write-line (strcat (nth (atoi *pop:def*) fLst) " Name,Length") ofile)

                         (mapcar
                           (function
                             (lambda (x)
                               (write-line (strcat (car x) (chr 44) (rtos (cadr x) 2 *len:pre*)) ofile)))
                           (reverse lenlst))

                         (setq ofile (close ofile))))))            
            
            (princ "\n*Cancel*"))))

  (princ))

(princ "\nř¤ş°`°ş¤ř  LenCal.lsp ~ Copyright © by Lee McDonnell  ř¤ş°`°ş¤ř")
(princ "\n   ~¤~          ...Type \"LenCal\" to Invoke...            ~¤~   ")
(princ)


;;;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;;;
;;                                                                               ;;
;;                             End of Program Code                               ;;
;;                                                                               ;;
;;;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;;;

AreaCal:

;;;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;;;
;;;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;;;
;;                                                                               ;;
;;                                                                               ;;
;;                       --=={  Area Calculator  }==--                         ;;
;;                                                                               ;;
;;  This program will calculate the total area of user specified objects       ;;
;;  with an optional filter. The Filter may be used to select only those objects ;;
;;  that are on a certain layer, or perhaps have a certain linetype or colour.   ;;
;;                                                                               ;;
;;  The objects included in the calculation can be changed in the 'Options'      ;;
;;  dialog, along with the calculation precision and output type.                ;;
;;                                                                               ;;
;;  The user can choose between three output options: ACAD Table, Txt file, or   ;;
;;  CSV file. If the output is set to ACAD Table, the user may select the        ;;
;;  Table-Style from the Drop-down in the main Dialog.                           ;;
;;                                                                               ;;
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
;;                                                                               ;;
;;  FUNCTION SYNTAX:  AreaCal                                                     ;;
;;                                                                               ;;
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
;;                                                                               ;;
;;  AUTHOR:                                                                      ;;
;;                                                                               ;;
;;  Copyright © Lee McDonnell, June 2009. All Rights Reserved.                   ;;
;;                                                                               ;;
;;      { Contact: Lee Mac @ TheSwamp.org, CADTutor.net }                        ;;
;;                                                                               ;;
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
;;                                                                               ;;
;;  VERSION:                                                                     ;;
;;                                                                               ;;
;;    ř 1.0   ~¤~   22nd June 2009       ~¤~   ş First Release                   ;;
;;...............................................................................;;
;;    ř 1.1   ~¤~   22nd June 2009       ~¤~                                     ;;
;;...............................................................................;;
;;    ř 1.2   ~¤~   23rd June 2009       ~¤~                                     ;;
;;...............................................................................;;
;;    ř 1.3   ~¤~   23rd June 2009       ~¤~   ş Fixed bugs.                     ;;
;;...............................................................................;;
;;    ř 1.4   ~¤~   10th December 2009   ~¤~   ş Fixed bugs.                     ;;
;;...............................................................................;;
;;    ř 1.5   ~¤~   21st December 2009   ~¤~   ş Updated Version Checking code.  ;;
;;...............................................................................;;
;;    ř 1.6   ~¤~   22nd December 2009   ~¤~   ş Added option to choose objects  ;;
;;...............................................................................;;
;;    ř 1.7   ~¤~   24th December 2009   ~¤~   ş Improved Options Dialog (with   ;;
;;                                               thanks to CAB for dialog bar).  ;;
;;                                             ş Added Precision Options         ;;
;;                                             ş Added alternative Output        ;;
;;                                               Options                         ;;
;;...............................................................................;;
;;                                                                               ;;
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
;;                                                                               ;;
;;;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;;;
;;;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;;;


(defun c:AreaCal (/  ;;  --=={ Local Functions }==--

                    *error*
                    AcCm-Color
                    DCL_Write
                    ErrChk
                    Get_Tbl_Styl
                    GetObjString
                    List_Upd
                    Obj_Settings
                    Pad
                    StrBrk       

                    ;;  --=={ Local Variables }==--

                    BPT
                    COL
                    DCTAG DCTITLE DOC
                    ELST ENT
                    FILE FLST FNAME
                    I
                    LAYLST LENLST LEN_SUB LST LT
                    OFILE OILST OLST OPTITLE OULST
                    SLST SPC SS
                    TBLOBJ TDEF TMP
                    UFLAG
                    WC
                    Z

                    ;;  --=={ Global Variables }==--
                 
                    ; *pop:def*  ~  Popup_List Default
                    ; *lst:def*  ~  List_Box Default
                    ; *tbl:stl*  ~  Table Style Default
                    ; *obj:set*  ~  Object Settings Default [bit-coded]
                    ; *len:pre*  ~  Length Precision Setting
                    ; *len:out*  ~  Output Mode Setting
                 )

  (vl-load-com)

  (setq fname   "AreaCal_V1.0.dcl"
        dcTitle "Area Calculator V1.0"
        opTitle "Options")
	(defun GetFilterList ( / ) 
			(list "Layer" "Hatch Pattern" "Colour")
	)
	
  (or *pop:def* (setq *pop:def* "0"))
  (or *lst:def* (setq *lst:def* "0"))
  (or *tbl:stl* (setq *tbl:stl* "0"))
  (or *obj:set* (setq *obj:set*  7 ))
  (or *len:pre* (setq *len:pre* (getvar "LUPREC")))
  (or *len:out* (setq *len:out* "0"))

  ; 1  = Line
  ; 2  = Lw Polyline
  ; 4  = Polyline
  ; 8  = Arc
  ; 16 = Circle
  ; 32 = Spline
  ; 64 = Ellipse

  (defun *error* (msg)
    (and uFlag (vla-EndUndoMark doc))
    (and dcTag (unload_dialog dcTag))
    (and ofile (close ofile))
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
        (princ (strcat "\n** Error: " msg " **")))
    (princ))
  

  (defun Pad (str chc len)
    (while (< (strlen Str) len)
      (setq str (strcat str (chr chc))))
    str)
  

  (defun StrBrk (str chrc / pos lst)
    (while (setq pos (vl-string-position chrc str))
      (setq lst (cons (substr str 1 pos) lst)
            str (substr str (+ pos 2))))
    (reverse (cons str lst)))
  

  (defun Get_Tbl_Styl (/ tbl lst)
    (if (not (vl-catch-all-error-p
               (setq tbl
                 (vl-catch-all-apply 'vla-item
                   (list (vla-get-Dictionaries
                           (cond (doc) ((vla-get-ActiveDocument
                                          (vlax-get-acad-object))))) "acad_tablestyle")))))
      
      (vlax-for styl tbl
        (setq lst (cons (vla-get-name styl) lst))))
    (reverse lst))
  

  (defun errchk (lst / olst)
    (setq *pop:def* (get_tile "sel_fil") *tbl:stl* (get_tile "tbl_styl"))
    
    (if (not (eq "" (setq *lst:def* (get_tile "sel_sel"))))
      (progn
        (setq olst (mapcar
                     (function
                       (lambda (x)
                         (nth x lst)))
                     (mapcar 'atoi (strbrk *lst:def* 32)))) (done_dialog))      
      (progn
        
        (set_tile "error" "** Nothing Selected **")
        (setq olst nil)))
    
   olst)

(defun Hatch:GetUsedPatterns ( / hatches i hatch hatchObj pattern patterns) 
	(setq hatches (ssget "_X" (list (cons 0 "HATCH") ) ) )
	(setq i 0 )
	(repeat (sslength hatches)
		(setq hatch (ssname hatches i))
		(setq hatchObj (vlax-ename->vla-object hatch ))		
		(setq pattern (vlax-get-property hatchObj 'PatternName ) )
		(if (not (member pattern patterns) ) 
			(setq patterns (append patterns (list pattern ) ) )
		)
		(setq i (1+ i ) )
	)
	patterns
)   

  (defun list_upd (code / lst wc col ss)
    
    (setq doc (cond (doc) ((vla-get-ActiveDocument
                             (vlax-get-acad-object)))))
    
    (cond (  (eq code 0)	; ByLayer Selected
           
             (vlax-for l (vla-get-layers doc)
               (setq lst (cons (vla-get-Name l) lst))))
          
          (  (eq code 1)	; ByHatchPattern Selected
           
             (setq lst (Hatch:GetUsedPatterns ))
          )
          (  (eq code 2)	; ByColor selected
           
             (vlax-for l (vla-get-layers doc)
               (if (not (vl-position (setq col (vla-get-color l)) lst))
                 (setq lst (cons col lst))))
           
             (if (setq ss (ssget "_X" '((-4 . "<NOT")
                                          (-4 . "<OR")
                                            (62 . 256)
                                            (62 . 0)
                                          (-4 . "OR>")
                                        (-4 . "NOT>"))))
               (foreach x (mapcar
                            (function
                              (lambda (x)
                                (cdr (assoc 62 (entget x)))))
                            (mapcar 'cadr (ssnamex ss)))
                 
                 (if (not (or (null x) (vl-position x lst)))
                   (setq lst (cons x lst)))))
           
             (setq lst (vl-remove-if
                         (function
                           (lambda (x)
                             (vl-position (strcase x) '("BYLAYER" "BYBLOCK"))))
                         (mapcar 'itoa lst)))))

    (if (not (eq "" (setq wc (get_tile "wc_str"))))
      (progn
        (setq lst
          (vl-remove-if-not
            (function
              (lambda (x)
                (wcmatch x wc))) lst))

        (and (not lst) (setq lst '("-- No Matches --")))))
    
    (start_list "sel_sel")
    (mapcar 'add_list (setq lst (acad_strlsort lst)))
    (end_list)
    
  lst)


  (defun AcCm-Color (/ acVer ac)
    (setq acVer (substr (getvar "ACADVER") 1 2))
    
    (if (not (vl-catch-all-error-p
               (setq ac
                 (vl-catch-all-apply 'vla-GetInterfaceObject
                   (list *acad (strcat "AutoCAD.AcCmColor." acVer))))))
      ac nil))
  

  (defun dcl_write (fname / pat path ofile)
    
    (if (not (findfile fname))
      (if (setq pat (findfile "ZWCAD.PAT"))
        (progn
          (setq path (vl-filename-directory pat))
          
          (or (eq "\\" (substr path (strlen path)))
              (setq path (strcat path "\\")))
          
          (setq ofile (open (strcat path fname) "w"))
          (foreach str
                   
            '("//;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;//"
              "//;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;//"
              "//                                                                               //"
              "//                      --=={  Area Calculator  }==--                          //"
              "//                                                                               //"
              "//             AreaCal.dcl for use in conjunction with AreaCal.lsp                 //"
              "//             Copyright © June 2009, by Lee McDonnell (Lee Mac)                 //"
              "//                                                                               //"
              "//;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;//"
              "//;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;//"
              ""
              "//  Sub-Assembly Definitions"
              ""
              "butt12 : button { width = 12; fixed_width = true; alignment = centered; }"
              "pop15  : popup_list { width = 15; fixed_width = true; alignment = centered; }"
              "tog    : toggle { alignment = centered; fixed_width = false; }"
              "bar    : image  {  width = 33.26; height = 0.74; color = -15; alignment = centered; }"
              ""
              "//  Main Dialog"
              ""
              "areacal : dialog { key = \"dctitle\";"
              "  : text { value = \"Copyright (c) 2009 Lee McDonnell\"; alignment = right; }"
              "  "
              "  : boxed_column { label = \"Filter\"; fixed_width = true; width = 45;"
              "    : popup_list { key = \"sel_fil\";alignment = centered; }"
              "    spacer_1; "
              "  }"
              "  "
              "  : boxed_column { label = \"Selection\";"
              "    : list_box { key = \"sel_sel\"; multiple_select = true; alignment = centered; }"
              "    : edit_box { key = \"wc_str\" ; label = \"Filter String:\"; edit_limit = 50;"
              "                 value = \"*\"; alignment = centered; }"
              "    spacer_1; "
              "  }"
              "  "
              "  : boxed_column { label = \"Table Style\";"
              "    : popup_list { key = \"tbl_styl\"; alignment = centered; }"
              "    spacer_1; "
              "  }"
              "  "
              "  : errtile { width = 34; }"
              "  : row {"
              "    : butt12 { key = \"opt\"; label = \"Options\"; }"
              "    : butt12 { key = \"accept\"; label = \"OK\"; is_default = true; }"
              "    : butt12 { key = \"cancel\"; label = \"Cancel\"; is_cancel = true; }"
              "  }"
              "}"
              ""
              ""  
              "areacal_opt : dialog { key = \"stitle\";"
              "  spacer;"
              "  : row { alignment = centered; "
              "    spacer;"
              "    : column { alignment = centered;"
              "      : tog { key = \"ha\"; label = \"Hatch\"; }"              
;              "      : tog { key = \"pl\"; label = \"Polyline\"; }"
              "    }"
              ""
;               "    : column { alignment = centered;"
;               "      : tog { key = \"el\"; label = \"Ellipse\";}"
;               "      : tog { key = \"ar\"; label = \"Arc\"; }"
;               "    }"
;               ""
;               "    : column { alignment = centered;"
;               "      : tog { key = \"lw\"; label = \"LW Polyline\"; }"              
;               "      : tog { key = \"ci\"; label = \"Circle\"; }"
;               "    }"
;               ""
;               "    : column { alignment = centered;"
;               "      : tog { key = \"sp\"; label = \"Spline\"; }"
;               "      : tog { key = \"al\"; label = \"Select All\"; }"
;               "    }"
              "  }"
              "  : row {"
              "    : spacer { width = 0.1; fixed_width = true; }"
              "    : bar { key = \"sep1\"; }"
              "    : spacer { width = 0.1; fixed_width = true; }"
              "  }"
              ""
              "  : row { alignment = centered; children_alignment = centered;"
              ""
              "    spacer;"
              "    : column { "
              "      : spacer { height = 0.1; fixed_height = true; }"
              "      : text { label = \"Precision:\"; }"
              "    }"
              "    : pop15 { key = \"prec\"; }"
              ""
              "    spacer;"
              ""
              "    : column {"
              "      : spacer { height = 0.1; fixed_height = true; }"
              "      : text { label = \"Output:\"; }"
              "    }"
              "    : pop15 { key = \"outp\"; }"
              "    spacer;"
              ""
              "  }"
              ""
              "  spacer;"
              "  : row {"
              "    : spacer { width = 0.1; fixed_width = true; }"
              "    : bar { key = \"sep2\"; }"
              "    : spacer { width = 0.1; fixed_width = true; }"
              "  }"
              ""
              "  ok_cancel;"
              "}"
              ""              
              "/*"
              "//;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;"
              ""
              "                          End of Program Code"
              ""
              "//;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;"
              "*/")
            
            (write-line str ofile))
          
          (setq ofile (close ofile))
          
        t)
    nil)
  t))

  
  (defun GetObjString (code / n x str)
    (setq n -1 str "")

    ; (foreach x '("LINE" "LWPOLYLINE" "POLYLINE" "ARC" "CIRCLE" "SPLINE" "ELLIPSE")
	(foreach x '("HATCH" )	; w przyszłości może jeszcze region
      (if (not (zerop (logand code (expt 2 (setq n (1+ n))))))
        (setq str (strcat str x (chr 44)))))

    (vl-string-right-trim "," str)
	)
  

  
  (defun DCL:FillList (id values / ) 
	(start_list id )
    (mapcar 'add_list values)
    (end_list)
  )
  
  (defun Obj_Settings (dcTag / Set_tiles Tile_Bit tmp)

    (defun Set_tiles (code / n x)
      (setq n -1)

      ;(foreach x '("li" "lw" "pl" "ar" "ci" "sp" "el")
	  (foreach x '("ha")
        (if (not (zerop (logand code (expt 2 (setq n (1+ n))))))
          (set_tile x "1")
          (set_tile x "0")
		)
	  )
	)
    

    (defun Tile_Bit (key value)

      (*

        (if (eq value "0")
          (progn
            (set_tile "al" "0") -1) 1)

        ; (expt 2 (vl-position key '("li" "lw" "pl" "ar" "ci" "sp" "el")))))
		(expt 2 (vl-position key '("ha"))))
	)
    
      
    (cond (  (not (new_dialog "areacal_opt" dcTag))

             (princ "\n** Options Dialog Could not be Loaded **"))

          (t
             (set_tile "stitle" opTitle)

             (foreach x '("sep1" "sep2")
               (start_image x)
               (mapcar (function vector_image) '(0 0) '(6 5) '(300 300) '(6 5) '(8 7))
               (end_image))

             (Set_tiles *obj:set*)
             (setq tmp *obj:set*) ;; For Cancel
			 
			 ( DCL:FillList "prec" (list "0" "0.0" "0.00" "0.000" "0.0000"
                                 "0.00000" "0.000000" "0.0000000" "0.00000000") )

             
			 
             (set_tile "prec" (itoa *len:pre*))

			 ( DCL:FillList "outp" (list "ACAD Table" "TXT File" "CSV File" ) )
             
             (set_tile "outp" *len:out*)

             (action_tile "prec" "(setq *len:pre* (atoi $value))")
             (action_tile "outp" "(setq *len:out* $value)")

             (action_tile "ha"   "(setq tmp (+ tmp (Tile_Bit \"ha\" $value)))")			 
;             (action_tile "li"   "(setq tmp (+ tmp (Tile_Bit \"li\" $value)))")
;             (action_tile "lw"   "(setq tmp (+ tmp (Tile_Bit \"lw\" $value)))")
;             (action_tile "pl"   "(setq tmp (+ tmp (Tile_Bit \"pl\" $value)))")
;             (action_tile "ar"   "(setq tmp (+ tmp (Tile_Bit \"ar\" $value)))")
;             (action_tile "ci"   "(setq tmp (+ tmp (Tile_Bit \"ci\" $value)))")
;             (action_tile "sp"   "(setq tmp (+ tmp (Tile_Bit \"sp\" $value)))")
;             (action_tile "el"   "(setq tmp (+ tmp (Tile_Bit \"el\" $value)))")
           
             (action_tile "al" "(if (eq \"1\" $value) (progn (setq tmp 127) (Set_Tiles tmp)))")

             (action_tile "accept"
               (vl-prin1-to-string
                 (quote
                   (progn
                     (cond (  (zerop tmp)
                              (alert "Please Select at Least One Object"))

                           (t (setq *obj:set* tmp)
                              (done_dialog)))))))
                           
             (action_tile "cancel" "(done_dialog)")

             (start_dialog)))
	)


  ;;  --=={ Main Function }==--
  
  
  (defun GetActiveDoc ( / ) 
	(vla-get-ActiveDocument(setq *acad (vlax-get-Acad-Object)))
  )
  (defun GetActiveSpace ( / doc ) 
  (setq doc (GetActiveDoc) )
  (if (zerop (vla-get-activespace doc))
              (if (= (vla-get-mspace doc) :vlax-true)
                (vla-get-modelspace doc)
                (vla-get-paperspace doc))
              (vla-get-modelspace doc))
  )
  
  (defun ByLayerSelected ( / ) 
	(eq "0" *pop:def*)
  )
  (defun ByLinetypeSelected ( / ) 
	(eq  "1" *pop:def*)
  )
  
  (defun ByColorSelected ( / ) 
	(eq "2" *pop:def*)
  )
  
  (defun SelectByLayer (olst / lay z len_sub ss ent lenlst) 
	(foreach lay olst
       (if (setq z -1 
				 len_sub 0. 
				 ss (ssget "_X" (list (cons 0 (GetObjString *obj:set*))
									  (cons 8 lay)
								))
			)
		  (progn
			(while 
				(setq ent (ssname ss (setq z (1+ z))))
				(setq len_sub (+ len_sub (vlax-get-property (vlax-ename->vla-object ent ) 'Area )))
			)
			(setq lenlst (cons (list lay len_sub) lenlst))
		)
		  (princ (strcat "\n** No Objects Found on Layer: " lay " **"))
		)
	)
	lenlst
)

(defun SelectByLinetype (olst / lt oulst tdef ssc Elst lenlst ) 
; 	(setq olst (list "Continuous" ))
	
    (foreach lt 
		(setq laystr "" )
		(setq oulst (mapcar (function strcase) olst))
		(while (setq tdef (tblnext "LAYER" (not tdef)))
			(if (eq lt (strcase (cdr (assoc 6 tdef))))
				(setq 	laystr (strcat (cdr (assoc 2 tdef)) (chr 44) laystr)
						laylst (cons   (cdr (assoc 2 tdef)) laylst))
			)
		)
   
		(setq laystr (vl-string-right-trim (chr 44) laystr))
		(if (setq ss (ssget "_X" (list (cons 0 (GetObjString *obj:set*))
                                  (cons -4 "<OR")
                                    (cons 6 lt)
                                    (cons 8 laystr)
                                  (cons -4 "OR>"))))
		  (progn     
			(setq Elst
				(vl-remove-if
				(function
					(lambda (x / l)
					(and
						(vl-position
						(cdr (assoc 8 (entget x))) laylst)
							(setq l (cdr (assoc 6 (entget x))))
							(not (eq (strcase l) lt)))))
					
					(mapcar 'cadr (ssnamex ss))))
			
			(setq lenlst (ReadAreas Elst lt))
			
            (princ (strcat "\n** No Objects Found With Linetype " lt " **"))
			)
                  
            (setq tdef nil laylst nil ss nil)
		)
	)
	lenlst
)

(defun SelectByColor (olst  / Elst x c ss tdef col lenlst ) 
	; (setq olst (list "140" "102" "37" ) )
	; (setq col (car oilst ))
	; (setq laystr  "" )
	(setq oilst (mapcar 'atoi olst))
	(foreach col oilst
        (setq laystr "")
        (while (setq tdef (tblnext "LAYER" (not tdef)))
           (if (eq col (cdr (assoc 62 tdef)))
             (setq laystr (strcat (cdr (assoc 2 tdef)) (chr 44) laystr)
                   laylst (cons   (cdr (assoc 2 tdef)) laylst))
			)
		)
         
			(setq laystr (vl-string-right-trim (chr 44) laystr))
                         
			(if (setq ss (ssget "_X" (list (cons 0 (GetObjString *obj:set*))
                                       (cons -4 "<OR")
                                         (cons 62 col)
                                         (cons 8 laystr)
                                       (cons -4 "OR>"))))
			(progn
            (setq Elst
              (vl-remove-if
                (function
                  (lambda (x / c)
                    (and
                      (vl-position
                        (cdr (assoc 8 (entget x))) laylst)
                          (setq c (cdr (assoc 62 (entget x))))
                            (not (eq c col)))))
                  
                  (mapcar 'cadr (ssnamex ss))
			  )
			)			
            (setq lenlst (append lenlst (ReadAreas Elst (itoa col))))
			
           )
           (princ (strcat "\n** No Objects Found With Colour " (itoa col) " **"))
			)
        
        (setq tdef nil  laylst nil)
	)	
lenlst
)


(defun SelectByHatchPattern (olst / lt oulst ss arealst ) 
    (foreach hp olst
		(if (setq ss (ssget "_X" (list (cons 0 (GetObjString *obj:set*))
 									  (cons 2 hp)
 								)))
		  (progn     
			(setq z -1 
					len_sub 0. 
					)
			(while 
 				(setq ent (ssname ss (setq z (1+ z))))
 				(setq len_sub (+ len_sub (vlax-get-property (vlax-ename->vla-object ent ) 'Area )))
 			)
 			(setq arealst (cons (list hp len_sub) arealst))
		  )
          (princ (strcat "\n** No Objects Found With HatchPattern " hp " **"))
		)
        (setq ss nil)
	)
	arealst
)


(defun ReadAreas (Elst param / lenlst x ) 
	(setq lenlst
		(cons	
		  (list param
			(apply (function +)
			  (mapcar
				(function
				  (lambda (x)
					(vlax-get-property (vlax-ename->vla-object x ) 'Area )
				  )
				)
				Elst
			  )
			)
		  )
		  lenlst
		)
	)
	lenlst
)

  
  (setq doc (GetActiveDoc)
        spc (GetActiveSpace) )
  
  
  (defun SaveAsTable (lenlst insertionPoint tbsStyle header / doc spc uflag tblObj i ) 
	; (setq lenlst (SelectByLayer (list "Kafelki" "Panele podłogowe" "Patio" "Wykładzina" ))  insertionPoint (list 0 0 0  ))
	
	(setq doc (GetActiveDoc)
        spc (GetActiveSpace) )
	
	(defun CalColumnWidth (lenlst header  / ) 
		(* (apply 'max
                 (mapcar 'strlen
                   (append (list header )
                     (apply 'append
                       (mapcar
                         (function
                           (lambda (x)
                             (list (car x) (rtos (cadr x) 2 *len:pre*)))) lenlst))))
			) 
			1.5 
			(getvar "DIMTXT")
		)
	)
		
	(setq uflag (not (vla-StartUndoMark doc)) i 2)
                  
    (setq tblObj
      (vla-addTable spc
					(vlax-3D-point insertionPoint)
					(+ 2 (length lenlst))
					2 
					(* 1.5 (getvar "DIMTXT"))
					(CalColumnWidth lenlst header)
            ))

    (vla-put-StyleName tblObj tbsStyle)
    (vla-setText tblObj 0 0 "Area Calculation")
    (vla-setText tblObj 1 0 header)
    (vla-setText tblObj 1 1 "Area")

    (foreach x (reverse lenlst)
      (vla-setText tblObj i 0 (car x))
      (vla-setText tblObj i 1 (rtos (cadr x) 2 *len:pre*))

      (setq i (1+ i)))

    (setq uflag (vla-EndUndoMark doc))
)

  (cond (  (not (>= (distof (substr (getvar "ACADVER") 1 4)) 16.1))  ;; ACAD 2005
         
           (princ "\n** Table Object Not Available in this Version **"))
        
        (  (eq 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar "CLAYER"))))))
         
           (princ "\n** Current Layer Locked **"))
        
        (  (not (dcl_write fname))
         
           (princ "\n** DCL File Could not be Written **"))
        
        (  (<= (setq dcTag (load_dialog fname)) 0)
         
           (princ "\n** Error Loading DCL **"))
        
        (  (not (new_dialog "areacal" dcTag))
         
           (princ "** Error Loading Area Calculator Dialog **"))
        
        (  (not (setq sLst (get_tbl_styl)))
         
           (princ "\n** Error Loading TableStyles **"))
        
        (t
			(DCL:FillList "tbl_styl" (setq sLst (acad_strlsort sLst)) )
			(DCL:FillList "sel_fil" (GetFilterList) )

          (set_tile "dctitle" dcTitle)
         
          (set_tile "sel_fil"  *pop:def*)
          (set_tile "sel_sel"  *lst:def*)
          (set_tile "tbl_styl" *tbl:stl*)
          (setq lst (list_upd (atoi *pop:def*)))

          (if (eq "0" *len:out*)
            (mode_tile "tbl_styl" 0)
            (mode_tile "tbl_styl" 1))

          (action_tile "sel_fil"
            (vl-prin1-to-string
              (quote
                (progn
                  (setq lst (list_upd (atoi $value))) (set_tile "error" "")
                  (setq *lst:def* (set_tile "sel_sel" "0"))))))
                
          (action_tile "wc_str"
            (vl-prin1-to-string
              (quote
                (progn
                  (setq lst (list_upd (atoi (get_tile "sel_fil"))))))))

          (action_tile "opt"
            (vl-prin1-to-string
              (quote
                (progn
                  (Obj_Settings dcTag)
                  (if (eq "0" *len:out*)
                    (mode_tile "tbl_styl" 0)
                    (mode_tile "tbl_styl" 1))))))
                  
          (action_tile "accept"  "(setq olst (errchk lst))")
          (action_tile "cancel"  "(done_dialog)")
         
          (start_dialog)
          (setq dcTag (unload_dialog dcTag))

         ;; --=={ Alternative Pre-DCL Selection Method  }==--

          ;|
          (while
            (progn
              (initget 128 "Select List All Done")
              (setq lt (getkword "\nSpecify Linetype to List [Select/List/All] <Done>: "))
				(cond ((not lt) nil) ; Enter
                    ((eq "Done" lt) nil)
                    ((eq "Select" lt)
                     (if (setq ent (car (nentsel "\nSelect Object: ")))
                       (progn
                         (setq lt (strcase
                                    (vla-get-linetype
                                      (setq Obj (vlax-ename->vla-object ent)))))
                         (cond ((eq lt "BYLAYER")
                                (if (vl-catch-all-error-p
                                      (vl-catch-all-apply
                                        (function
                                          (lambda ( )
                                            (setq lt
                                              (strcase
                                                (vla-get-linetype
                                                  (vla-item
                                                    (vla-get-Layers doc) (vla-get-layer Obj)))))))))
                                  (princ "\n<< Error Retrieving Linetype >>")
                                  (if ltlst
                                    (if (vl-position lt ltlst)
                                      (princ (strcat "\n<< " lt " Linetype Already Listed >>"))
                                      (progn
                                        (setq ltlst (cons lt ltlst))
                                        (princ (strcat "\n<< " lt " Linetype Added to List >>"))))
                                    (progn
                                      (setq ltlst (cons lt ltlst))
                                      (princ (strcat "\n<< " lt " Linetype Added to List >>"))))))
                               (t (if ltlst
                                    (if (vl-position lt ltlst)
                                      (princ (strcat "\n<< " lt " Linetype Already Listed >>"))
                                      (progn
                                        (setq ltlst (cons lt ltlst))
                                        (princ (strcat "\n<< " lt " Linetype Added to List >>"))))
                                    (progn
                                      (setq ltlst (cons lt ltlst))
                                      (princ (strcat "\n<< " lt " Linetype Added to List >>")))))))
                       t)) ; Stay in Loop
                    ((eq "List" lt)
                     (if ltlst
                       (progn
                         (foreach lt ltlst
                           (princ (strcat "\n" (Pad lt 46 30)))) (textscr) t) ; Stay in Loop
                       (princ "\n<< No List Created >>")))
                    ((eq "All" lt)
                     (setq ltlst nil)
                     (while (setq l (tblnext "LTYPE" (not l)))
                       (setq ltlst (cons (cdr (assoc 2 l)) ltlst))) nil) ; Exit Loop
                    ((and (snvalid lt)
                          (tblsearch "LTYPE" lt))
                     (setq ltlst (cons (strcase lt) ltlst)))
                    (t (princ "\n<< Linetype not Found in Drawing >>"))
				)
			)
		)
          |;

         ;; --===============================================================--
         

          (if (and olst (not (vl-position "-- No Matches --" olst)))
            (progn
                
				(cond
					(  (ByLayerSelected) 
                     (setq lenlst(SelectByLayer olst ))
					)                
                    (  (ByLinetypeSelected)
						(setq lenlst (SelectByHatchPattern olst ))
					)
                    (  (ByColorSelected) 
						(setq lenlst (SelectByColor olst ))
					)
				)

              (if lenlst 

                (cond (  (and (eq "0" *len:out*) (setq bPt (getpoint "\nSelect Point for Table: ")))
					(setq tableStyle (nth (atoi *tbl:stl*) sLst)
							header (strcat (nth (atoi *pop:def*) (GetFilterList)) " Name") )
					( SaveAsTable lenlst bPt tableStyle header )
						 )

                      (  (and (eq "1" *len:out*) (setq file (getfiled "Select Output File" "" "txt" 9)))

                         (setq ofile (open file "a"))
                         (write-line "\nArea Calculation" ofile)
                         (write-line (strcat (Pad (strcat "\n" (nth (atoi *pop:def*) fLst) " Name") 32 31) "Area\n") ofile)

                         (mapcar
                           (function
                             (lambda (x)
                               (write-line (strcat (Pad (car x) 32 30) (rtos (cadr x) 2 *len:pre*)) ofile)))
                           (reverse lenlst))

                         (setq ofile (close ofile))
						)

                      (  (and (eq "2" *len:out*) (setq file (getfiled "Select Output File" "" "csv" 9)))

                         (setq ofile (open file "a"))
                         (write-line "Area Calculation" ofile)
                         (write-line (strcat (nth (atoi *pop:def*) fLst) " Name,Area") ofile)

                         (mapcar
                           (function
                             (lambda (x)
                               (write-line (strcat (car x) (chr 44) (rtos (cadr x) 2 *len:pre*)) ofile)))
                           (reverse lenlst))

                         (setq ofile (close ofile))))))            
            
            (princ "\n*Cancel*"))))

  (princ)
)

(princ "\nř¤ş°`°ş¤ř  AreaCal.lsp ~ Copyright © by Lee McDonnell  ř¤ş°`°ş¤ř")
(princ "\n   ~¤~          ...Type \"AreaCal\" to Invoke...            ~¤~   ")
(princ)


;;;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;;;
;;                                                                               ;;
;;                             End of Program Code                               ;;
;;                                                                               ;;
;;;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;;;



LenCal V1.7ZWCAD.lsp

AreaCal V1.0ZWCAD.lsp

Link to comment
Share on other sites

  • 1 month later...
  • 10 months later...

Witam

Program został dostosowany do ZWCada + 2015. Dopasowanie do wersji bazujących na jądrze IntelliCAD, do których należy ZWCAD 2011 może zająć trochę czasu. Postaram się tym zająć w najbliższym czasie, ale na chwilę obecną trudno jest mi oszacować ile może to potrwać.

Pozdrawiam

Link to comment
Share on other sites

  • 2 weeks later...

Pracując w ZWCAD ,wystarczy taki plik zapisać w dowolnym miejscu na dysku i w ZWCADzie menu Narzędzia->Wczytaj aplikację wybrać ten plik, zaznaczyć go z listy i kilkąć przycisk [Wczytaj].

W ostatnim AutoCADzie na którym pracowałem było analogicznie.

Po wczytaniu dostępne będzie polecenie AreaCal, które można po prostu wpisać , można też utworzyć sobie ikonkę i przypisać do niej polecenie.

Link to comment
Share on other sites

  • 3 months later...
  • 2 weeks later...
  • 5 years later...

Sprawdziłem działanie aplikacji na ZWCAD 2023 zadziałała poprawnie - została wstawiona tabela z wartościami.
Być może problem będzie ukryty gdzieś w pliku na którym Pan testuje. Jeśli to możliwe proszę przesłać fragment pliku na którym moglibyśmy wykonać testy.

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Loading...
 Share