[编程交流] 插入块，提示使用p

;;;  Tlindell 2007
;;;
;;;  This routine is designed to prompt parameters and attributes when a block is inserted in a drawing.
;;;  The routine will engage after the insert command, a block is dragged from a toolpalette or the Design Center.
;;;  The routine turns off normal attribute prompting and issues it's own.  This was to fix certain prompting issues.
;;;  The routine filters out any parameters that do not show up on the Properties palette.
;;;
;;;*******************************************************************
;;;support functions
(vl-load-com)
(vl-load-reactors)
;;;*******************************************************************
;;;callback functions
(defun gp:binsertatts (a b / ss obj objattr nwstr)
 (if (or (eq (car b) "EXECUTETOOL") (eq (car b) "DROPGEOM") (eq (car b) "INSERT") (eq (car b) "-INSERT"))
   (setvar "attreq" 0)
 )
)
(defun gp:binsertatte (a b / ss->objlist ss obj objattr nwstr objdyn newvalue prmpts cnt dyn dynp)
 (defun ss->objlist (ss / cnt objlist)
   (setq cnt (sslength ss))
   (repeat cnt
     (setq objlist (append objlist (list (vlax-ename->vla-object (ssname ss (- cnt 1))))))
     (setq cnt (- cnt 1))
   )
   (setq ss nil)
   objlist
 )
 (if (or (eq (car b) "EXECUTETOOL") (eq (car b) "DROPGEOM") (eq (car b) "INSERT") (eq (car b) "-INSERT"))
   (progn
     (setq dyn (getvar "dynmode"))
     (setq dynp (getvar "dynprompt"))
     (setvar "dynprompt" 1)
     (setvar "dynmode" 1)
     (setq ss (ssget "L"))
     (setq obj (ss->objlist ss))
     (foreach o obj
       (if (= (cdr (assoc 0 (entget (vlax-vla-object->ename o)))) "INSERT")
         (progn
           (if (= (vla-get-HasAttributes o) :vlax-true)
             (progn
               (setq objattr (vlax-safearray->list (vlax-variant-value (vla-GetAttributes o))))
               (foreach oa objattr
                 (setq oatr oa)
                 (if (= (vla-get-Constant oa) :vlax-false)
                   (progn
                     (setq nwstr (getstring (strcat "\nSpecify " (vla-get-TagString oa) ": <" (vla-get-TextString oa) ">: ")))
                     (if (/= nwstr "") (vla-put-TextString oa nwstr))
                     (setq nwstr nil)
                   )
                 )
               )
             )
           )
           (if (= (vla-get-IsDynamicBlock o) :vlax-true)
             (progn
               (setq objdyn (vlax-safearray->list (vlax-variant-value (vla-GetDynamicBlockProperties o))))
               (foreach od objdyn
                 (if (and (= (vla-get-Show od) :vlax-true) (= (vla-get-ReadOnly od) :vlax-false) (/= (vla-get-PropertyName od) "Origin"))
                   (progn
                     (if (= (vlax-safearray-get-u-bound (vlax-variant-value (vla-get-AllowedValues od)) 1) -1)
                       (progn
                         (if (= (vla-get-Description od) "")
                           (setq prmpts (strcat "\nEnter value for " (vla-get-PropertyName od) ":"))
                           (setq prmpts (strcat "\nEnter value for " (vla-get-Description od) ":"))
                         )
                         (cond
                           ((= (vla-get-UnitsType od) acAngular) (setq newvalue (getorient prmpts)))
                           ((= (vla-get-UnitsType od) acDistance) (setq newvalue (getdist prmpts)))
                           ((= (vla-get-UnitsType od) acArea) (setq newvalue (getreal prmpts)))
                         )
                         (if (/= newvalue nil) (vla-put-Value od (vlax-make-variant newvalue)))
                       )
                       (progn
                         (setq prmpts "[")
                         (setq cnt 1)
                         (foreach pt (vlax-safearray->list (vlax-variant-value (vla-get-AllowedValues od)))
                           (if (= (vla-get-UnitsType od) acNoUnits)
                             (if (numberp (vlax-variant-value pt))
                               (if (= (vlax-variant-value pt) 0)
                                 (setq prmpts (strcat prmpts (itoa cnt) ").NotFlipped "))
                                 (setq prmpts (strcat prmpts (itoa cnt) ").Flipped "))
                               )
                               (setq prmpts (strcat prmpts (itoa cnt) ")." (vl-string-translate "/" "|" (vl-string-translate " " "-" (vlax-variant-value pt))) " "))
                             )
                             (setq prmpts (strcat prmpts (itoa cnt) ")." (vl-string-translate "/" "|" (vl-string-translate " " "-" (rtos (vlax-variant-value pt)))) " "))
                           )
                           (setq cnt (+ cnt 1))
                         )
                         (setq prmpts (strcat (vl-string-right-trim " " prmpts) "]"))
                         (initget 0 (vl-string-trim "[]" prmpts))
                         (if (= (vla-get-Description od) "")
                           (setq newvalue (getkword (strcat "\nEnter value for " (vla-get-PropertyName od) ":" (vl-string-translate " " "/" prmpts))))
                           (setq newvalue (getkword (strcat "\nEnter value for " (vla-get-Description od) ":" (vl-string-translate " " "/" prmpts))))
                         )
                         (if (/= newvalue nil)
                           (progn
                             (setq newvalue (nth (- (atoi (substr newvalue 1 (vl-string-position 41 newvalue))) 1) (vlax-safearray->list (vlax-variant-value (vla-get-AllowedValues od)))))
                             (vla-put-Value od newvalue)
                           )
                         )
                       )
                     )
                   )
                 )
               )
             )
           )
         )
       )
     )
     (setvar "dynmode" dyn)
     (setvar "dynprompt" dynp)
   )
 )
 (setvar "attreq" 1)
 (princ)
)
;;;*******************************************************************
;;;reactors
(setq rinsrte (vlr-command-reactor nil '((:vlr-commandEnded . gp:binsertatte))))
(setq rinsrts (vlr-command-reactor nil '((:vlr-commandWillStart . gp:binsertatts))))