[编程交流] Lisp使用块创建bom表

(defun c:BC ( / *error* mutter ss doc )
 ;; © Lee Mac  ~  05.06.10
 (defun *error* ( msg )
   (and mutter (setvar 'nomutt mutter))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )
 (or *title (setq *title "Block Data"))
 (or *prev  (setq *prev  "ON"))
 (setq mutter (getvar 'nomutt))
 (setvar 'nomutt 1)
 (princ "\nSelect Blocks to Count <All> : ")
 (cond (  (not (progn (setq ss (cond (  (ssget      '((0 . "INSERT"))))
                                     (  (ssget "_X" '((0 . "INSERT"))))))
                      (setvar 'nomutt mutter) ss))                  
          (princ "\n** No Blocks Found **")
       )
       (
         (_DisplayResult
           (mapcar
             (function
               (lambda ( x ) (list (car x) (itoa (cadr x))))
             )
             (
               (lambda ( / l n )
                 (vlax-for obj
                   (setq ss
                     (vla-get-ActiveSelectionSet
                       (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
                     )
                   )
                   (if (zerop (logand 45 (cdr (assoc 70 (tblsearch "BLOCK" (setq n (BlockName obj)))))))
                     (setq l (assoc++ n l))
                   )
                 )
                 l
               )
             )
           )
         )
       )
       (  (princ "\n** No Blocks Found **")  )
 )
 (princ)
)
(defun _DisplayResult ( lst / rLen )
 (if lst
   (progn
     (setq rLen
       (+ 3
         (apply (function max)
           (cons 5
             (mapcar (function strlen)
               (mapcar (function cadr) lst)
             )
           )
         )
       )
     )
     (mapcar
       (function
         (lambda ( item )
           (princ
             (strcat "\n"
               (PadRight (TidyString (car  item) 40) "."   40) "|"
               (PadLeft  (cadr item) "." rLen)
             )
           )
         )
       )
       (append
         (list '("ID" "MANUFACTURER" "PART NUMBER" "DESCRIPTION" "QUANTITY")
           (list (PadRight "" "-" 40) (PadLeft  "" "-" rLen))
         )
         (setq lst
           (vl-sort lst
             (function
               (lambda ( a b ) (< (car a) (car b)))
             )
           )
         )
         (list
           (list (PadRight "" "-" 40) (PadLeft "" "-" rLen))
         )
       )
     )
     (terpri)
     (if (> (atof (getvar 'ACADVER)) 16.)
       (progn
         (while
           (progn
             (initget "Yes No Settings")
             (setq choix (getkword "\nTable? [Yes/No/Settings] <Yes> : "))
             (cond (  (or (not choix) (eq "Yes" choix))
                    
                      (GrMove
                        (AddTable
                          (GetActiveSpace
                            (vla-get-ActiveDocument
                              (vlax-get-acad-object)
                            )
                          )
                          (getvar 'VIEWCTR) *title
                          (cons '("ID" "MANUFACTURER" "PART NUMBER" "DESCRIPTION" "QUANTITY") lst)
                          (eq "ON" *prev)
                        )
                        'InsertionPoint "\nPlace Table... " 0
                      )
                    nil
                   )
                   (  (eq "Settings" choix)
                      (while
                        (progn
                          (initget "Title Preview Exit")
                          (princ (strcat "\n<< Title: " (if (eq "" *title) "-None-" *title) ", Block Preview: " *prev " >>"))
                          (setq subchoix (getkword "\nEdit Settings [Title/Preview/Exit] <Exit> : "))
                          (cond (  (or (not subchoix) (eq "Exit" subchoix)) nil  )
                                (  (eq "Title" subchoix)
                                   (setq *title (getstring t "\nSpecify Table Title or <Enter> for None: "))
                                )
                                (t (initget "ON OFF")
                                   (setq *prev (cond ((getkword "\nBlock Preview Setting [ON/OFF] <ON> : ")) ("ON")))
                                )                         
                          )
                        )
                      )
                     t
                   )
                   (  (textscr)  )
             )
           )
         )
         t
       )
       (not (textscr))
     )          
   )
 )      
)
(defun assoc++ ( key lst )
 (
   (lambda ( pair )
     (cond
       ( pair
         (subst (list (car pair) (1+ (cadr pair))) pair lst)
       )
       ( (cons (list key 1) lst) )
     )
   )
   (assoc key lst)
 )
)
(defun Is64Bit nil
 (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
)
(defun BlockName ( obj )
 (vlax-get-property obj
   (if (vlax-property-available-p obj 'EffectiveName)
     'EffectiveName 'Name
   )
 )
)
(defun GetActiveSpace ( doc )
 (vlax-get-property doc
   (if (or (eq acModelSpace (vla-get-ActiveSpace doc))
           (eq :vlax-true   (vla-get-MSpace doc)))
     'ModelSpace 'PaperSpace
   )
 )
)
(defun GetObjectID ( obj doc )
 (if (eq "X64" (strcase (getenv "PROCESSOR_ARCHITECTURE")))
   (vlax-invoke-method (vla-get-Utility doc) 'GetObjectIdString obj :vlax-false)
   (itoa (vla-get-Objectid obj))
 )
)
(defun Itemp ( coll item )
 (if
   (not
     (vl-catch-all-error-p
       (setq item
         (vl-catch-all-apply
           (function vla-item) (list coll item)
         )
       )
     )
   )
   item
 )
)
(defun AddTable ( block pt title data preview / blks doc tObj tStyle )
 
 (setq tStyle (GetTableStyle (getvar 'CTABLESTYLE)))
 
 (vlax-put-property
   (setq tObj
     (vla-AddTable block
       (vlax-3D-point pt) (1+ (length data))
       (+ (if preview 1 0) (length (car data)))
       (* 1.8 (vla-getTextHeight tStyle acDataRow))
       (* 0.8
         (apply (function max)
           (mapcar (function strlen)
             (apply (function append) data)
           )
         )
         (vla-getTextHeight tStyle acDataRow)
       )
     )
   )
   'StyleName (getvar 'CTABLESTYLE)
 )  
 (vla-put-RegenerateTableSuppressed tObj :vlax-true)
 
 (setq blks
   (vla-get-blocks
     (setq doc
       (vla-get-ActiveDocument
         (vlax-get-acad-object)
       )
     )
   )
 )
 (if preview
   (progn
     (vla-SetText tObj 1 0 "Preview")
     (
       (lambda ( row )
         (mapcar
           (function
             (lambda ( block ) (setq row (1+ row))
               (vla-SetCellType tObj row 0 acBlockCell)
               (vla-SetBlockTableRecordId tObj row 0
                 (GetObjectID (Itemp blks block) doc) t
               )
             )
           )
           (mapcar (function car) (cdr data))
         )
       )
       1
     )
   )
 )
 (
   (lambda ( row )
     (mapcar
       (function
         (lambda ( rowitem ) (setq row (1+ row))
           (
             (lambda ( column )
               (mapcar
                 (function
                   (lambda ( item )
                     (vla-SetText tObj row
                       (setq column (1+ column)) item
                     )
                   )
                 )
                 rowitem
               )
             )
             (if preview 0 -1)
           )
         )
       )
       data
     )
   )
   0
 )
 
 (if (eq "" title)
   (vla-deleterows tObj 0 1)
   (vla-SetText tObj 0 0 title)
 )  
 (vla-put-RegenerateTableSuppressed tObj :vlax-false)
 
 tObj
)
(defun GetTableStyle ( Name )
 (if (setq Dict
       (Itemp
         (vla-get-Dictionaries
           (vla-get-ActiveDocument
             (vlax-get-acad-object)
           )
         )
         "ACAD_TABLESTYLE"
       )
     )
   (Itemp Dict Name)
 )
)
(defun GrMove ( obj prop msg cur / *error* gr data )
 (defun *error* ( msg )
   (and obj (not (vlax-erased-p obj)) (vla-delete obj))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )
 
 (if (vlax-property-available-p obj prop)
   (progn
     (princ msg)
     (while
       (and (= 5 (car (setq gr (grread t 13 cur))))
            (listp (setq data (cadr gr))))
       (vlax-put-property obj prop (vlax-3D-point data))
     )
     data
   )
 )
)
(defun TidyString ( str len )
 (if (> (strlen str) len)
   (strcat (substr str 1 (- len 3)) "...") str
 )
)
(defun PadRight ( str char len )
 (while (< (strlen str) len)
   (setq str (strcat str char))
 )
 str
)
(defun PadLeft ( str char len )
 (while (< (strlen str) len)
   (setq str (strcat char str))
 )
 str
)
(princ "\nø¤º°`°º¤ø  Count.lsp ~ Copyright © by Lee McDonnell  ø¤º°`°º¤ø")
(princ "\n   ~¤~          ...Type "Count" to Invoke...            ~¤~   ")
(princ)
;;;¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,;;;
;;                                                                               ;;
;;                             End of Program Code                               ;;
;;                                                                               ;;
;;;ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,¤º°`°º¤;;;