;;; (c) 2012 Ediciones ARTUAL, S.L. Barcelona, España.
;;; Copyright © 2012-2020 by Reinaldo N. Togores. All rights reserved.
;;; Use of this code is allowed mentioning the book and its author.
;;;Chapter 25. Visual LISP as ActiveX client.
(defun connect-excel (/)
(setq excel-app (vlax-get-or-create-object "Excel.Application")
wbook-coll (vlax-get-property excel-app "Workbooks")
wbname (strcat (vl-filename-base (getvar "dwgname"))
".xls"))
(setq wbook (vl-catch-all-apply
'vlax-get-property
(list wbook-coll "Item" wbname)))
(cond
((vl-catch-all-error-p wbook)
(setq wbook (vlax-invoke-method wbook-coll "Add"))
(vlax-invoke-method
wbook
"SaveAs"
(strcat (getvar "dwgprefix") wbname) ; Filename
56 ; FileFormat
"" ; Password
"" ; Write Reservation Password
:vlax-false ; ReadOnlyRecommended
:vlax-false ; CreateBackup
1))) ; AccessMode As XlSaveAsAccessMode
(setq sheet-coll (vlax-get-property wbook "Sheets"))
(vla-put-visible excel-app :vlax-true))
;;;Listing 25.1. CONNECT-EXCEL function.
(defun disconnect-excel ()
(vlax-release-object excel-app)
(gc))
;;;Listing 25.2. DISCONNECT-EXCEL function.
(defun app-err (msg)
(if
(and excel-app
(not (vlax-object-released-p excel-app)))
(vlax-release-object excel-app))
(prompt msg))
;;;Listing 25.3. APP-ERR function.
(defun list->excel (name lst / *error* excel-cells wsheet sheet-coll wbook wbname
wbook-coll excel-app)
(setq *error* app-err)
(vl-load-com)
(connect-excel)
(setq wsheet (vl-catch-all-apply
'vlax-get-property
(list sheet-coll "Item" name)))
(cond
((vl-catch-all-error-p wsheet)
(setq wsheet (vlax-invoke-method sheet-coll "Add"))
(vlax-put-property wsheet "Name" name)))
(setq excel-cells (vlax-get-property wsheet "Cells"))
(process-table lst)
(disconnect-excel))
;;;Listing 25.4. LIST->EXCEL function.
(defun process-table (lst / numrow numcol)
(setq numrow 1
numcol 0)
(foreach field (car lst)
(data->cell
numrow
(setq numcol (1+ numcol))
(car field)))
(while (setq row (car lst))
(setq numrow (1+ numrow)
lst (cdr lst))
(process-row row numrow)))
;;;Listing 25.5. PROCESS-TABLE function.
(defun process-row (row numrow / numcol)
(setq numcol 0)
(foreach field row
(data->cell
numrow
(setq numcol (1+ numcol))
(cdr field))))
;;;Listing 25.6. PROCESS-ROW function.
(defun data->cell (row col value)
(vlax-put-property
excel-cells
"Item"
row
col
(vl-princ-to-string value)))
;;;Listing 25.7. DATA->CELL auxiliary function.
(defun C:EXCEL-ATTRIBUTES (/ block-list)
(if (display-dialog "attributes" "./dcl/attributes.dcl")
(progn
(if (setq block-list (read-blocks))
(fill-list "block_list" block-list)
(set_tile "error"
"No blocks in the active drawing"))
(action_tile
"block_list"
"(check-attributes $value)")
(action_tile
"accept"
"(extract (get_tile \"block_list\"))")
(action_tile "cancel" "(done_dialog 0)")
(start_dialog)
(unload_dialog dcl_id)
(princ))))
;;;Listing 25.9. Main function C:EXCEL-ATTRIBUTES.
(defun fill-list (list-tile block-list)
(start_list list-tile)
(mapcar 'add_list
(mapcar '(lambda (term) (strcat (car term) "\t" (cdr term)))
block-list))
(end_list))
;;;Listing 25.10. FILL-LIST function.
(defun check-attributes (value block-list)
(if
(not
(equal (cdr (nth (atoi value) block-list)) "ATTRIB"))
(set_tile "error"
"The selected block has no attributes")
(set_tile "error" "")))
;;;Listing 25.11. CHECK-ATTRIBUTES function.
(defun extract (value block-list / selection name)
(if block-list
(setq selection (nth (atoi value) block-list)))
(if (= (cdr selection) "ATTRIB")
(progn (set_tile "error" "Processing, please wait...")
(setq name (car selection))
(list->excel name (sel-block name))
(done_dialog))))
;;;Listing 25.12. EXTRACT function.
(defun read-blocks (/ name blk-list)
(vlax-for obj
(vla-get-blocks *aevl:drawing*)
(setq name (vla-get-name obj))
(if (and (not (wcmatch name "`**,*|*"))
(equal (vla-get-IsXref obj) :vlax-false))
(if (ssget "X" (list (cons 0 "INSERT") (cons 2 name)))
(setq blk-list (cons
(cons name
(if (has-attributes? obj)
"ATTRIB"
""))
blk-list)))))
(setq blk-list (vl-sort blk-list '(lambda (n1 n2) (< (car n1) (car n2)))))
blk-list)
;;;Listing 25.13. READ-BLOCKS function.
(defun has-attributes? (blkdef-obj / result)
(vlax-for obj
blkdef-obj
(if
(equal (vla-get-ObjectName obj)
"AcDbAttributeDefinition")
(setq result t)))
result)
;;;Listing 25.14. HAS-ATTRIBUTES? function.
No comments:
Post a Comment