[编程交流] Lisp动态块（&D）

;; Retrieves All Properties from a Dynamic Block
;; Args: obj ~ Dynamic Block VLA-Object
;; Returns: ((<property name> <value>) ...)
(defun GetDynProps (obj)
 ;; Lee Mac  ~  07.04.10
 (mapcar
   (function
     (lambda (x / v)
       (list (vla-get-PropertyName x)
             (if (= 8192 (logand 8192 (vlax-variant-type (setq v (vla-get-value x)))))
               (vlax-safearray->list (vlax-variant-value v))
               (vlax-variant-value v)))))
     
   (vlax-invoke obj 'GetDynamicBlockProperties)))
;; Retrieves All Properties from a Dynamic Block
;; Args: obj ~ Dynamic Block VLA-Object
;; Returns: ((<property name> <value>) ...)
(defun GetDynProps (obj)
 ;; Lee Mac  ~  07.04.10
 (mapcar
   (function
     (lambda (x) (list (vla-get-PropertyName x) (vlax-get x 'Value))))
   (vlax-invoke obj 'GetDynamicBlockProperties)))
;; Changes a Dynamic Block Property Value
;; Args: obj  ~ Dynamic Block VLA-Object
;;       prop ~ Property Name
;;       val  ~ New Value
;; Returns: New Value (val)
(defun PutDynPropValue (obj prop val)
 ;; Lee Mac  ~  07.04.10
 (mapcar
   (function
     (lambda (x)
       (if (eq (strcase prop) (strcase (vla-get-propertyName x)))
         (vla-put-value x
           (vlax-make-variant val
             (vlax-variant-type (vla-get-value x)))))))
   (vlax-invoke obj 'GetDynamicBlockProperties)) val)
;; Retrieves the Allowed Values for a Specific Property
;; Args: obj  ~ Dynamic Block VLA-Object
;;       prop ~ Property Name
;; Returns: List of Allowed Values (or nil)
(defun GetPropAllowedValues (obj prop / a)
 ;; Lee Mac  ~  07.04.10
 (mapcar
   (function
     (lambda (x / w)
       (if (eq (strcase prop) (strcase (vla-get-propertyName x)))
         (setq a
           (mapcar
             (function
               (lambda (v)
                 (if (= 8192 (logand 8192 (vlax-variant-type v)))
                   (vlax-safearray->list (vlax-variant-value v))
                     (vlax-variant-value v))))
             
             (if (< 0 (vlax-safearray-get-u-bound
                        (setq w (vlax-variant-value
                                  (vla-get-AllowedValues x))) 1))
               
               (vlax-safearray->list w)))))))
   
   (vlax-invoke obj 'GetDynamicBlockProperties)) a)
;; Retrieves the Allowed Values for a Specific Property
;; Args: obj  ~ Dynamic Block VLA-Object
;;       prop ~ Property Name
;; Returns: List of Allowed Values (or nil)
(defun GetPropAllowedValues (obj prop / a)
 ;; Lee Mac  ~  07.04.10
 (mapcar
   (function
     (lambda (x)
       (if (eq (strcase prop) (strcase (vla-get-propertyName x)))
         (setq a (vlax-get x 'AllowedValues)))))
   (vlax-invoke obj 'GetDynamicBlockProperties)) a)
;; Retrieves the Allowed Values for all Properties
;; Args: obj  ~ Dynamic Block VLA-Object
;; Returns: ((<property name> (<Allowed Values>)) ...)
(defun GetAllowedValues (obj)
 ;; Lee Mac  ~  07.04.10
 (mapcar
   (function
     (lambda (x / w)
       (list (vla-get-propertyname x)
             (mapcar
               (function
                 (lambda (v)
                   (if (= 8192 (logand 8192 (vlax-variant-type v)))
                     (vlax-safearray->list (vlax-variant-value v))
                       (vlax-variant-value v))))
               (if (< 0 (vlax-safearray-get-u-bound
                          (setq w (vlax-variant-value
                                    (vla-get-AllowedValues x))) 1))
                 
                 (vlax-safearray->list w))))))
   
   (vlax-invoke obj 'GetDynamicBlockProperties)))
;; Retrieves the Allowed Values for all Properties
;; Args: obj  ~ Dynamic Block VLA-Object
;; Returns: ((<property name> (<Allowed Values>)) ...)
(defun GetAllowedValues (obj)
 ;; Lee Mac  ~  07.04.10
 (mapcar
   (function
     (lambda (x)
       (list (vla-get-propertyname x)
             (vlax-get x 'AllowedValues))))
   (vlax-invoke obj 'GetDynamicBlockProperties)))

(defun c:InsertBlock ( / block space point )
 (vl-load-com)
 ;; Lee Mac  ~  05.05.10
 (setq block nil) ;; Block Name or nil
 (setq space
   (if
     (or
       (eq AcModelSpace
         (vla-get-ActiveSpace
           (setq doc
             (vla-get-ActiveDocument
               (vlax-get-acad-object)
             )
           )
         )
       )
       (eq :vlax-true
         (vla-get-MSpace doc)
       )
     )
     (vla-get-ModelSpace doc)
     (vla-get-PaperSpace doc)
   )
 )        
 (if (setq block (GetBlock block))
   (while
     (setq point
       (getpoint "\nSpecify Point for Insertion: "))
     
     (InsertBlock space block point)
   )
 )
 
 (princ)
)
(defun GetBlock ( block )
 ;; Lee Mac  ~  05.05.10
 (cond
   (
     (not
       (and
         (or block
           (setq block
             (getfiled "Select Block" "" "dwg" 16)
           )
         )
         (or
           (and
             (eq "" (vl-filename-extension block))
             (or
               (tblsearch "BLOCK" block)
               (setq block
                 (findfile
                   (strcat block ".dwg")
                 )
               )
             )
           )
           (setq block (findfile block))
         )
       )
     )
    nil
   )
   ( block )
 )
)
(defun InsertBlock ( Block Name Point )
 (vla-InsertBlock Block
   (vlax-3D-point Point) Name 1. 1. 1. 0.
 )
)

(defun c:InsertBlock ( / block tag space point )
 (vl-load-com)
 ;; Lee Mac  ~  05.05.10
 (setq block "PANEL") ;; Block Name or nil
 (setq tag nil)   ;; Tag Name or nil
 (setq space
   (if
     (or
       (eq AcModelSpace
         (vla-get-ActiveSpace
           (setq doc
             (vla-get-ActiveDocument
               (vlax-get-acad-object)
             )
           )
         )
       )
       (eq :vlax-true
         (vla-get-MSpace doc)
       )
     )
     (vla-get-ModelSpace doc)
     (vla-get-PaperSpace doc)
   )
 )        
 (if
   (and
     (setq block (GetBlock block))
     (setq *num*
       (1-
         (cond
           (
             (getint
               (strcat "\nSpecify Starting Number <"
                 (itoa
                   (setq *num*
                     (cond ( *num* ) ( 1 ))
                   )
                 )
                 "> : "
               )
             )
           )
           ( *num* )
         )
       )
     )
   )
   (while
     (setq *num* (1+ *num*)
           point (getpoint "\nSpecify Point for Insertion: "))
     
     (if (and (setq obj (InsertBlock space block point)) tag)
       (PutAttValue obj tag (itoa *num*))
     )
   )
 )
 
 (princ)
)
(defun PutAttValue ( object tag value )
 ;; Lee Mac  ~  05.05.10
 (mapcar
   (function
     (lambda ( attrib )
       (and
         (eq tag (vla-get-TagString attrib))
         (vla-put-TextString attrib value)
       )
     )
   )
   (vlax-invoke object 'GetAttributes)
 )
 value
)
(defun GetBlock ( block )
 ;; Lee Mac  ~  05.05.10
 (cond
   (
     (not
       (and
         (or block
           (setq block
             (getfiled "Select Block" "" "dwg" 16)
           )
         )
         (or
           (and
             (vl-position
               (vl-filename-extension block) '("" nil)
             )
             (or
               (tblsearch "BLOCK" block)
               (setq block
                 (findfile
                   (strcat block ".dwg")
                 )
               )
             )
           )
           (setq block (findfile block))
         )
       )
     )
    nil
   )
   ( block )
 )
)
(defun InsertBlock ( Block Name Point )
 (if
   (not
     (vl-catch-all-error-p
       (setq result
         (vl-catch-all-apply (function vla-insertblock)
           (list Block (vlax-3D-point point) Name 1. 1. 1. 0.)
         )
       )
     )
   )
   result
 )
)