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...
  • 10 months later...

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...