[编程交流] 重命名块

(defun c:RenB (/ obj old new)
 ;; Rename Selected Block
 ;; Required Subroutines: AT:GeSel, AT:Getstring
 ;; Alan J. Thompson, 03.10.10 / 07.15.10
 (if
   (and
     (AT:GetSel
       entsel
       "\nSelect block to rename: "
       (lambda (x)
         (if
           (and (eq "INSERT" (cdr (assoc 0 (entget (car x)))))
                (/= 4
                    (logand (cdr (assoc 70 (tblsearch "BLOCK" (cdr (assoc 2 (entget (car x))))))) 4)
                )
           )
            (setq obj (vlax-ename->vla-object (car x)))
         )
       )
     )
     (setq old (if (vlax-property-available-p obj 'effectivename)
                 (vla-get-effectivename obj)
                 (vla-get-name obj)
               )
     )
     (not (vl-position
            (setq new (AT:GetString "Specify new block name:" old))
            (list old "" nil)
          )
     )
   )
    (cond
      ((tblsearch "BLOCK" new) (alert (strcat """ new "" already exists!")))
      ((not (snvalid new)) (alert (strcat """ new "" is an invalid name!")))
      ((and (snvalid new) (not (tblsearch "block" new)))
       (if
         (vl-catch-all-error-p
           (vl-catch-all-apply
             'vla-put-name
             (list
               (vla-item (vla-get-blocks
                           (cond (*AcadDoc*)
                                 ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
                           )
                         )
                         old
               )
               new
             )
           )
         )
          (alert (strcat "Block: " old " could not be renamed to: " new))
          (alert (strcat "Block: " old " renamed to: " new))
       )
      )
    )
 )
 (princ)
)
(defun AT:GetSel (meth msg fnc / ent)
 ;; meth - selection method (entsel, nentsel, nentselp)
 ;; msg - message to display (nil for default)
 ;; fnc - optional function to apply to selected object
 ;; Ex: (AT:GetSel entsel "\nSelect arc: " (lambda (x) (eq (cdr (assoc 0 (entget (car x)))) "ARC")))
 ;; Alan J. Thompson, 05.25.10
 (while
   (progn (setvar 'ERRNO 0)
          (setq ent (meth (cond (msg)
                                ("\nSelect object: ")
                          )
                    )
          )
          (cond ((eq (getvar 'ERRNO) 7) (princ "\nMissed, try again."))
                ((eq (type (car ent)) 'ENAME)
                 (if (and fnc (not (fnc ent)))
                   (princ "\nInvalid object!")
                 )
                )
          )
   )
 )
 ent
)
(defun AT:GetString (#Title #Default / #FileName #FileOpen #DclID #NewString)
 ;; Getstring Dialog Box
 ;; #Title - Title of dialog box
 ;; #Default - Default string within edit box
 ;; Alan J. Thompson, 08.25.09
 (setq #FileName (vl-filename-mktemp "" "" ".dcl")
       #FileOpen (open #FileName "W")
 )
 (foreach x '("TempEditBox : dialog {" "key = "Title";" "label = "";"
              "initial_focus = "Edit";" "spacer;" ": row {" ": column {" "alignment = centered;"
              "fixed_width = true;" ": text {" "label = "";" "}" "}" ": edit_box {"
              "key = "Edit";" "allow_accept = true;" "edit_width = 40;" "fixed_width = true;" "}"
              "}" "spacer;" ": row {" "fixed_width = true;" "alignment = centered;" ": ok_button {"
              "width = 11;" "}" ": cancel_button {" "width = 11;" "}" "}" "}//"
             )
   (write-line x #FileOpen)
 )
 (close #FileOpen)
 (setq #DclID (load_dialog #FileName))
 (new_dialog "TempEditBox" #DclID)
 (set_tile "Title" #Title)
 (set_tile "Edit" #Default)
 (action_tile "accept" "(setq #NewString (get_tile "Edit"))(done_dialog)")
 (action_tile "cancel" "(done_dialog)")
 (start_dialog)
 (unload_dialog #DclID)
 (vl-file-delete #FileName)
 #NewString
)