[编程交流] 创建绘图列表，但是

; ** ============[ DwgLst.lsp ]============== ** ;
; **                                          ** ;
; **  FUNCTION:                               ** ;
; **  Will Automatically Create a Drawing     ** ;
; **  List based on TitleBlock Attribute      ** ;
; **  Values.                                 ** ;
; **                                          ** ;
; ** ======================================== ** ;
; **                                          ** ;
; **  SYNTAX: DWGLST                          ** ;
; **                                          ** ;
; **  AUTHOR:                                 ** ;
; **  Copyright © 2009, Lee McDonnell         ** ;
; **  Contact Lee Mac:   CADTutor.net         ** ;
; **                     TheSwamp.org         ** ;
; **                                          ** ;
; ** ======================================== ** ;
; **                                          ** ;
; **  RESTRICTIONS:                           ** ;
; **  Machine must be able to run             ** ;
; **  Microsoft Excel.                        ** ;
; **                                          ** ;
; ** ======================================== ** ;
; **                                          ** ;
; **  USAGE:                                  ** ;
; **  Attributes from every instance of a     ** ;
; **  Specified Block are Extracted to        ** ;
; **  Excel.                                  ** ;
; **                                          ** ;
; **  An Excel file may be selected or        ** ;
; **  upon the user hitting Cancel at         ** ;
; **  the prompt, a new Excel file is         ** ;
; **  created.                                ** ;
; **                                          ** ;
; **  Block Name and Attribute Tag List may   ** ;
; **  be Changed in the Settings Panel below. ** ;
; **  Attribute Values will be written to     ** ;
; **  Excel in the order they appear in the   ** ;
; **  list.                                   ** ;
; **                                          ** ;
; ** ======================================== ** ;
; **                                          ** ;
; **  VERSION:                                ** ;
; **  1.0  ~  01.07.2009                      ** ;
; **  2.0  ~  02.07.2009                      ** ;
; **                                          ** ;
; ** ======================================== ** ;
; =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;
(defun c:DwgLst  (/  BlkName ValLst *acad
                    Shell fDir Dir dwLst acVer
                    cAtt attLst oLst file xlApp
                    xlShe Ucells xlCells Col Row
                    *error*
                 )
 
 (vl-load-com)
 (setq
 ;; =-=-=-=-=[ Settings ]=-=-=-=-=- ;;
   BlkName  "titleblock"             ;; { Block Name }
   ValLst '("NUMBER" "DATE" "NAME")  ;; { Attribute Tag List }
 ;; =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= ;;
 )
 ;; =-=-=-=[ Error Handler ]=-=-=-=- ;;
 (defun *error* (msg)
   (mapcar 'ObjRel
     (list xlApp xlShe UCells xlCells dbx *acad))
   (if
     (not
       (wcmatch
         (strcase msg)
           "*BREAK,*CANCEL*,*EXIT*"))
     (princ
       (strcat
         "\n<< Error: " msg " >>"))
     (princ "\n*Cancel*"))
   (princ))
 ;; =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;
 (cond ((not (eq 'STR (type BlkName)))
        (princ "\n<< Block Name not a String >>"))
       ((not (vl-consp ValLst))
        (princ "\n<< Attribute Tag List Invalid >>"))
       ((not
          (vl-every
            (function
              (lambda (x)
                (eq 'STR (type x)))) ValLst))
        (princ "\n<< Attribute Tag List Must only Contain Strings >>"))
       (t
         (setq *acad (vlax-get-acad-object)
               Shell (vla-getInterfaceObject *acad "Shell.Application")
                fDir (vlax-invoke-method Shell 'BrowseForFolder
                       (vla-get-HWND *acad) "Select Directory: " 80))
        (ObjRel Shell)
        (if fDir
          (progn
            (setq Dir
              (vlax-get-property
                (vlax-get-property fDir 'Self)
                'Path))
            (if (not (eq "\" (substr Dir (strlen Dir))))
              (setq Dir (strcat Dir "\")))
            (princ "\nProcessing...")
            (foreach dwg (setq dwLst
                           (mapcar
                             (function
                               (lambda (x)
                                 (strcat Dir x)))
                             (vl-directory-files Dir "*.dwg" 1)))
              (vlax-for doc (vla-get-Documents *acad)
                (and (eq (strcase (vla-get-fullname doc)) (strcase dwg))
                     (setq dbx doc)))      
              (and (not dbx)
                   (setq dbx
                     (vlax-create-object
                       (if (< (setq acVer (atoi (getvar "ACADVER"))) 16)
                         "ObjectDBX.AxDbDocument"
                         (strcat "ObjectDBX.AxDbDocument." (itoa acVer))))))          
              (if (not (vl-catch-all-error-p
                          (vl-catch-all-apply
                            'vla-open (list dbx dwg))))
                (progn
                  (vlax-for lay (vla-get-Layouts dbx)
                    (vlax-for Obj (vla-get-Block lay)
                      (if
                        (and
                          (eq
                            (vla-get-ObjectName Obj) "AcDbBlockReference")
                          (eq
                            (strcase
                              (vla-get-Name Obj)) (strcase BlkName)))
                        (progn
                          (foreach Att
                            (append
                              (vlax-safearray->list
                                (vlax-variant-value
                                  (vla-GetAttributes Obj)))
                              (if
                                (not
                                  (vl-catch-all-error-p
                                    (setq cAtt
                                      (vl-catch-all-apply
                                        'vlax-safearray->list
                                          (list
                                            (vlax-variant-value
                                              (vla-getConstantAttributes Obj)))))))
                                cAtt))
                            (if (vl-position
                                  (strcase
                                    (vla-get-TagString Att)) ValLst)
                              (setq attlst
                                (cons
                                  (cons
                                    (vla-get-TagString Att)
                                      (vla-get-TextString Att)) attlst))))
                            (setq olst
                              (cons
                                (mapcar
                                  (function
                                    (lambda (x)
                                      (assoc x attlst))) ValLst) olst) attlst nil))))))
                (princ (strcat "\n<< Error Opening Dwg: " dwg " >>")))
              (princ (chr 46))
              (ObjRel dbx) (setq dbx nil))
            ;; -=-=-=-=-=-=-[ Write to Excel ]-=-=-=-=-=-=- ;;
            (if oLst
              (progn
                (if (setq file (getfiled "Select Excel File" "" "xls" )
                  (progn
                    (setq xlApp (vlax-get-or-create-object "Excel.Application")
                          xlshe (vlax-get-property
                                  (vlax-get
                                    (vla-open
                                      (vlax-get xlApp "Workbooks")
                                      file)
                                    "Sheets")
                                  "Item" 1)
                          Ucells  (vlax-get xlshe "Usedrange")
                          xlCells (vlax-get xlshe "Cells"))
                    (setq Col (- (vlax-get
                                   (vlax-get ucells "Columns")
                                   "Count")
                                 2)
                          row     (1+
                                    (vlax-get
                                      (vlax-get ucells "Rows")
                                      "Count"))))
                  (progn
                    (setq xlApp (vlax-get-or-create-object "Excel.Application")
                          xlshe (vlax-get-property
                                  (vlax-get
                                    (vlax-invoke-method
                                      (vlax-get xlApp "Workbooks")
                                      "Add")
                                    "Sheets")
                                  "Item" 1)
                          xlCells (vlax-get xlshe "Cells") Col 1 row 1)
                    (foreach Tag ValLst
                      (vlax-put-property xlCells "Item" row Col Tag)
                      (setq Col (1+ Col)))
                    (setq Col 1 row 2)))
                (vla-put-visible xlApp :vlax-true)
                (foreach Sht (reverse oLst)
                  (if (< 65536 row)
                    (setq Col (1+ (length ValLst)))
                    (setq Col 1))
                  (foreach Tag Sht
                    (vlax-put-property xlCells "Item" row Col (cdr Tag))
                    (setq Col (1+ Col)))
                  (setq row (1+ row)))
                (gc) (gc)
                (alert "Close Excel File Manually")
                (princ
                  (strcat "\n<< " (rtos (length dwLst) 2 0) " Drawings Processed >>")))
              (princ "\n<< No TitleBlocks Found in Drawing >>")))
          (princ "\n*Cancel*"))
        (mapcar 'ObjRel
          (list xlApp xlShe UCells xlCells dbx *acad))))
 (princ))
;; =-=-=-=-=[ Object Release ]=-=-=-=-= ;;
(defun ObjRel (Obj)
 (and Obj
   (eq 'VLA-OBJECT (type Obj))
     (not (vlax-object-released-p Obj))
       (vl-catch-all-apply
         'vlax-release-object
           (list Obj))))
(vl-load-com)
(princ
 (vl-list->string
   '(10 42 42 32 68 119 103 76 115 116 46 108 115 112 32 98
     121 32 76 101 101 32 77 99 68 111 110 110 101 108 108
     44 32 67 111 112 121 114 105 103 104 116 32 169 32 74
     117 108 121 32 50 48 48 57 32 42 42 10 32 32 32 32 32
     32 32 32 32 32 32 32 45 32 84 121 112 101 32 34 68 87
     71 76 83 84 34 32 116 111 32 73 110 118 111 107 101 32 45)))
(princ)
;|
;;;¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,;
                         End of Program Code                          
;;;¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,;
|;