[kirillwu]

В файле имеются множество вхождений динамического блока. У динамического блока есть атрибут с тэгом "ИМЯ_001", файл с блоком прилагаю. У всех вхождений одно и тоже имя блока "Стойка. Требуется лисп, который переименует каждое вхождение в блока в значение атрибута с тэгом "ИМЯ_001". Нашел в интернете чужой лисп, который позволяет переименовать вхождение блока в значение, вводимое с клавиатуры. Требуется чуть доработать этот лисп, чтобы была возможность блок переименовать в значение атрибута, не вводя ничего с клавиатуры.
Например я имею в чертеже 100 блоков с именем "стойка" Из них 70 с атрибутом "ИМЯ_001" - со значением "СТ-1", И 30 с атрибутом "ИМЯ_001" - со значением "СТ-2", После ввода команды выделяю нужные для изменения блоки, и создается 70 блоков с именем "СТ-1" и 30 блоков "СТ-2", с сохранением их динамических свойств.

Код:

[Выделить все]

 
CopyRenameBlockV1-5.lsp © 2018 Lee Mac
DarkLightVLIDE
;;-----------------=={ Copy/Rename Block Reference }==------------------;;
;;                                                                      ;;
;;  This program allows a user to copy and/or rename a single block     ;;
;;  reference in the working drawing.                                   ;;
;;                                                                      ;;
;;  Many existing programs enable the user to rename the block          ;;
;;  definition for a given block reference, with the new name           ;;
;;  subsequently reflected across all references of the block           ;;
;;  definition in the drawing. However, this program will allow a       ;;
;;  single selected block reference to be renamed (or for the user to   ;;
;;  create a renamed copy of the selected block reference), by          ;;
;;  generating a duplicate renamed block definition for the selected    ;;
;;  block.                                                              ;;
;;                                                                      ;;
;;  The program may be called from the command-line using either 'CB'   ;;
;;  to create a renamed copy of a selected block reference, or 'RB' to  ;;
;;  simply rename the selected block reference.                         ;;
;;                                                                      ;;
;;  Following selection of a block reference, the user is prompted to   ;;
;;  specify a name for the selected/copied block reference; a default   ;;
;;  block name composed of the original block name concatenated with    ;;
;;  both an underscore and the minimum integer required for uniqueness  ;;
;;  within the block collection of the active drawing is offered.       ;;
;;                                                                      ;;
;;  The program will then proceed to duplicate the block definition     ;;
;;  using the new block name. To accomplish this without resulting in   ;;
;;  a duplicate key in the block collection of the active drawing, the  ;;
;;  program utilises an ObjectDBX interface to which the block          ;;
;;  definition of the selected block reference is deep-cloned, renamed, ;;
;;  and then deep-cloned back to the active drawing. This method also   ;;
;;  enables Dynamic Block definitions to be successfully copied         ;;
;;  & renamed.                                                          ;;
;;                                                                      ;;
;;  Finally, this program will perform successfully in all UCS/Views    ;;
;;  and is compatible with Anonymous Blocks, Dynamic Blocks & XRefs.    ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2013  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.5    -    05-07-2013                                      ;;
;;----------------------------------------------------------------------;;
 
(defun c:cb nil (LM:RenameBlockReference   t))
(defun c:rb nil (LM:RenameBlockReference nil))
 
(defun LM:RenameBlockReference ( cpy / *error* abc app dbc dbx def doc dxf new old prp src tmp vrs )
 
    (defun *error* ( msg )
        (if (and (= 'vla-object (type dbx)) (not (vlax-object-released-p dbx)))
            (vlax-release-object dbx)
        )
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
    
    (while
        (progn
            (setvar 'errno 0)
            (setq src (car (entsel (strcat "\nSelect block reference to " (if cpy "copy & " "") "rename: "))))
            (cond
                (   (= 7 (getvar 'errno))
                    (princ "\nMissed, try again.")
                )
                (   (= 'ename (type src))
                    (setq dxf (entget src))
                    (cond
                        (   (/= "INSERT" (cdr (assoc 0 dxf)))
                            (princ "\nPlease select a block reference.")
                        )
                        (   (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (cdr (assoc 8 dxf)))))))
                            (princ "\nSelected block is on a locked layer.")
                        )
                    )
                )
            )
        )
    )
    (if (= 'ename (type src))
        (progn
            (setq app (vlax-get-acad-object)
                  doc (vla-get-activedocument app)
                  src (vlax-ename->vla-object src)
                  old (vlax-get-property src (if (vlax-property-available-p src 'effectivename) 'effectivename 'name))
                  tmp 0
            )
            (while (tblsearch "block" (setq def (strcat (vl-string-left-trim "*" old) "_" (itoa (setq tmp (1+ tmp)))))))
            (while
                (and (/= "" (setq new (getstring t (strcat "\nSpecify new block name <" def ">: "))))
                    (or (not (snvalid new))
                        (tblsearch "block" new)
                    )
                )
                (princ "\nBlock name invalid or already exists.")
            )
            (if (= "" new)
                (setq new def)
            )
            (setq dbx
                (vl-catch-all-apply 'vla-getinterfaceobject
                    (list app
                        (if (< (setq vrs (atoi (getvar 'acadver))) 16)
                            "objectdbx.axdbdocument"
                            (strcat "objectdbx.axdbdocument." (itoa vrs))
                        )
                    )
                )
            )
            (if (or (null dbx) (vl-catch-all-error-p dbx))
                (princ "\nUnable to interface with ObjectDBX.")
                (progn
                    (setq abc (vla-get-blocks doc)
                          dbc (vla-get-blocks dbx)
                    )
                    (vlax-invoke doc 'copyobjects (list (vla-item abc old)) dbc)
                    (if (wcmatch old "`**")
                        (vla-put-name (vla-item dbc (1- (vla-get-count dbc))) new)
                        (vla-put-name (vla-item dbc old) new)
                    )
                    (vlax-invoke dbx 'copyobjects (list (vla-item dbc new)) abc)
                    (vlax-release-object dbx)
                    (if cpy (setq src (vla-copy src)))
                    (if
                        (and
                            (vlax-property-available-p src 'isdynamicblock)
                            (= :vlax-true (vla-get-isdynamicblock src))
                        )
                        (progn
                            (setq prp (mapcar 'vla-get-value (vlax-invoke src 'getdynamicblockproperties)))
                            (vla-put-name src new)
                            (mapcar
                               '(lambda ( a b )
                                    (if (/= "ORIGIN" (strcase (vla-get-propertyname a)))
                                        (vla-put-value a b)
                                    )
                                )
                                (vlax-invoke src 'getdynamicblockproperties) prp
                            )
                        )
                        (vla-put-name src new)
                    )
                    (if (= :vlax-true (vla-get-isxref (setq def (vla-item (vla-get-blocks doc) new))))
                        (vla-reload def)
                    )
                    (if cpy (sssetfirst nil (ssadd (vlax-vla-object->ename src))))
                )
            )
        )
    )
    (princ)
)
 
;;----------------------------------------------------------------------;;
 
(vl-load-com)
(princ
    (strcat
        "\n:: CopyRenameBlock.lsp | Version 1.5 | \\U+00A9 Lee Mac "
        (menucmd "m=$(edtime,$(getvar,date),YYYY)")
        " www.lee-mac.com ::"
        "\n:: Available Commands:"
        "\n::    \"CB\"  -  Copy & Rename Block Reference."
        "\n::    \"RB\"  -  Rename Block Reference."
    )
)
(princ)
 
;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;

______________________________________________________________________________________
Вложенный лисп к сожалению работает только с одним вхождением. Нужно чтобы была возможность выбрать несколько вхождений и переименовать их в значение аттрибута, с сохранением их всех динамических парамметров.

Сообщение несколько раз редактировал, извините за первоначальную неграмотность

[Nike]

Код:

[Выделить все]

  
CopyRenameBlockV1-5.lsp © 2018 Lee Mac
DarkLightVLIDE
;;-----------------=={ Copy/Rename Block Reference }==------------------;;
;;                                                                      ;;
;;  This program allows a user to copy and/or rename a single block     ;;
;;  reference in the working drawing.                                   ;;
;;                                                                      ;;
;;  Many existing programs enable the user to rename the block          ;;
;;  definition for a given block reference, with the new name           ;;
;;  subsequently reflected across all references of the block           ;;
;;  definition in the drawing. However, this program will allow a       ;;
;;  single selected block reference to be renamed (or for the user to   ;;
;;  create a renamed copy of the selected block reference), by          ;;
;;  generating a duplicate renamed block definition for the selected    ;;
;;  block.                                                              ;;
;;                                                                      ;;
;;  The program may be called from the command-line using either 'CB'   ;;
;;  to create a renamed copy of a selected block reference, or 'RB' to  ;;
;;  simply rename the selected block reference.                         ;;
;;                                                                      ;;
;;  Following selection of a block reference, the user is prompted to   ;;
;;  specify a name for the selected/copied block reference; a default   ;;
;;  block name composed of the original block name concatenated with    ;;
;;  both an underscore and the minimum integer required for uniqueness  ;;
;;  within the block collection of the active drawing is offered.       ;;
;;                                                                      ;;
;;  The program will then proceed to duplicate the block definition     ;;
;;  using the new block name. To accomplish this without resulting in   ;;
;;  a duplicate key in the block collection of the active drawing, the  ;;
;;  program utilises an ObjectDBX interface to which the block          ;;
;;  definition of the selected block reference is deep-cloned, renamed, ;;
;;  and then deep-cloned back to the active drawing. This method also   ;;
;;  enables Dynamic Block definitions to be successfully copied         ;;
;;  & renamed.                                                          ;;
;;                                                                      ;;
;;  Finally, this program will perform successfully in all UCS/Views    ;;
;;  and is compatible with Anonymous Blocks, Dynamic Blocks & XRefs.    ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2013  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.5    -    05-07-2013                                      ;;
;;----------------------------------------------------------------------;;
 
(defun c:cb nil (LM:RenameBlockReference   t))
(defun c:rb nil (LM:RenameBlockReference nil))
 
(defun LM:RenameBlockReference ( cpy / *error* abc app dbc dbx def doc dxf new old prp src tmp vrs )
 
    (defun *error* ( msg )
        (if (and (= 'vla-object (type dbx)) (not (vlax-object-released-p dbx)))
            (vlax-release-object dbx)
        )
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
    
    (while
        (progn
            (setvar 'errno 0)
            (setq src (car (entsel (strcat "\nSelect block reference to " (if cpy "copy & " "") "rename: "))))          
            (cond
                (   (= 7 (getvar 'errno))
                    (princ "\nMissed, try again.")
                )
                (   (= 'ename (type src))
                    (setq dxf (entget src))
                    (cond
                        (   (/= "INSERT" (cdr (assoc 0 dxf)))
                            (princ "\nPlease select a block reference.")
                        )
                        (   (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (cdr (assoc 8 dxf)))))))
                            (princ "\nSelected block is on a locked layer.")
                        )
                    )
                )
            )
        )
    )
    (if (= 'ename (type src))
        (progn
            (setq app (vlax-get-acad-object)
                  doc (vla-get-activedocument app)
                  src (vlax-ename->vla-object src)
                  old (vlax-get-property src (if (vlax-property-available-p src 'effectivename) 'effectivename 'name))
                  tmp 0
            )
            (while (tblsearch "block" ;(setq def (strcat (vl-string-left-trim "*" old) "_" (itoa (setq tmp (1+ tmp)))))
 
;;----------------------------------------------------------------------;;
                     (setq def (LM:vl-getattributevalue src "ИМЯ_001"))
;;----------------------------------------------------------------------;;
                     ))
            (while
                (and (/= "" (setq new (getstring t (strcat "\nSpecify new block name <" def ">: "))))
                    (or (not (snvalid new))
                        (tblsearch "block" new)
                    )
                )
                (princ "\nBlock name invalid or already exists.")
            )
            (if (= "" new)
                (setq new def)
            )
            (setq dbx
                (vl-catch-all-apply 'vla-getinterfaceobject
                    (list app
                        (if (< (setq vrs (atoi (getvar 'acadver))) 16)
                            "objectdbx.axdbdocument"
                            (strcat "objectdbx.axdbdocument." (itoa vrs))
                        )
                    )
                )
            )
            (if (or (null dbx) (vl-catch-all-error-p dbx))
                (princ "\nUnable to interface with ObjectDBX.")
                (progn
                    (setq abc (vla-get-blocks doc)
                          dbc (vla-get-blocks dbx)
                    )
                    (vlax-invoke doc 'copyobjects (list (vla-item abc old)) dbc)
                    (if (wcmatch old "`**")
                        (vla-put-name (vla-item dbc (1- (vla-get-count dbc))) new)
                        (vla-put-name (vla-item dbc old) new)
                    )
                    (vlax-invoke dbx 'copyobjects (list (vla-item dbc new)) abc)
                    (vlax-release-object dbx)
                    (if cpy (setq src (vla-copy src)))
                    (if
                        (and
                            (vlax-property-available-p src 'isdynamicblock)
                            (= :vlax-true (vla-get-isdynamicblock src))
                        )
                        (progn
                            (setq prp (mapcar 'vla-get-value (vlax-invoke src 'getdynamicblockproperties)))
                            (vla-put-name src new)
                            (mapcar
                               '(lambda ( a b )
                                    (if (/= "ORIGIN" (strcase (vla-get-propertyname a)))
                                        (vla-put-value a b)
                                    )
                                )
                                (vlax-invoke src 'getdynamicblockproperties) prp
                            )
                        )
                        (vla-put-name src new)
                    )
                    (if (= :vlax-true (vla-get-isxref (setq def (vla-item (vla-get-blocks doc) new))))
                        (vla-reload def)
                    )
                    (if cpy (sssetfirst nil (ssadd (vlax-vla-object->ename src))))
                )
            )
        )
    )
    (princ)
)
 
;;----------------------------------------------------------------------;;
 
(vl-load-com)
(princ
    (strcat
        "\n:: CopyRenameBlock.lsp | Version 1.5 | \\U+00A9 Lee Mac "
        (menucmd "m=$(edtime,$(getvar,date),YYYY)")
        " www.lee-mac.com ::"
        "\n:: Available Commands:"
        "\n::    \"CB\"  -  Copy & Rename Block Reference."
        "\n::    \"RB\"  -  Rename Block Reference."
    )
)
(princ)
 
;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;

(defun LM:vl-getattributevalue ( blk tag )
    (setq tag (strcase tag))
    (vl-some '(lambda ( att ) (if (= tag (strcase (vla-get-tagstring att))) (vla-get-textstring att))) (vlax-invoke blk 'getattributes))
)

[kirillwu]

Сообщение от Nike Код: [Выделить все] CopyRenameBlockV1-5.lsp © 2018 Lee Mac DarkLightVLIDE ;;-----------------=={ Copy/Rename Block Reference }==------------------;; ;; ;; ;; This program allows a user to copy and/or rename a single block ;; ;; reference in the working drawing. ;; ;; ;; ;; Many existing programs enable the user to rename the block ;; ;; definition for a given block reference, with the new name ;; ;; subsequently reflected across all references of the block ;; ;; definition in the drawing. However, this program will allow a ;; ;; single selected block reference to be renamed (or for the user to ;; ;; create a renamed copy of the selected block reference), by ;; ;; generating a duplicate renamed block definition for the selected ;; ;; block. ;; ;; ;; ;; The program may be called from the command-line using either 'CB' ;; ;; to create a renamed copy of a selected block reference, or 'RB' to ;; ;; simply rename the selected block reference. ;; ;; ;; ;; Following selection of a block reference, the user is prompted to ;; ;; specify a name for the selected/copied block reference; a default ;; ;; block name composed of the original block name concatenated with ;; ;; both an underscore and the minimum integer required for uniqueness ;; ;; within the block collection of the active drawing is offered. ;; ;; ;; ;; The program will then proceed to duplicate the block definition ;; ;; using the new block name. To accomplish this without resulting in ;; ;; a duplicate key in the block collection of the active drawing, the ;; ;; program utilises an ObjectDBX interface to which the block ;; ;; definition of the selected block reference is deep-cloned, renamed, ;; ;; and then deep-cloned back to the active drawing. This method also ;; ;; enables Dynamic Block definitions to be successfully copied ;; ;; & renamed. ;; ;; ;; ;; Finally, this program will perform successfully in all UCS/Views ;; ;; and is compatible with Anonymous Blocks, Dynamic Blocks & XRefs. ;; ;;----------------------------------------------------------------------;; ;; Author: Lee Mac, Copyright © 2013 - www.lee-mac.com ;; ;;----------------------------------------------------------------------;; ;; Version 1.5 - 05-07-2013 ;; ;;----------------------------------------------------------------------;; (defun c:cb nil (LM:RenameBlockReference t)) (defun c:rb nil (LM:RenameBlockReference nil)) (defun LM:RenameBlockReference ( cpy / *error* abc app dbc dbx def doc dxf new old prp src tmp vrs ) (defun *error* ( msg ) (if (and (= 'vla-object (type dbx)) (not (vlax-object-released-p dbx))) (vlax-release-object dbx) ) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\nError: " msg)) ) (princ) ) (while (progn (setvar 'errno 0) (setq src (car (entsel (strcat "\nSelect block reference to " (if cpy "copy & " "") "rename: ")))) (cond ( (= 7 (getvar 'errno)) (princ "\nMissed, try again.") ) ( (= 'ename (type src)) (setq dxf (entget src)) (cond ( (/= "INSERT" (cdr (assoc 0 dxf))) (princ "\nPlease select a block reference.") ) ( (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (cdr (assoc 8 dxf))))))) (princ "\nSelected block is on a locked layer.") ) ) ) ) ) ) (if (= 'ename (type src)) (progn (setq app (vlax-get-acad-object) doc (vla-get-activedocument app) src (vlax-ename->vla-object src) old (vlax-get-property src (if (vlax-property-available-p src 'effectivename) 'effectivename 'name)) tmp 0 ) (while (tblsearch "block" ;(setq def (strcat (vl-string-left-trim "*" old) "_" (itoa (setq tmp (1+ tmp))))) ;;----------------------------------------------------------------------;; (setq def (LM:vl-getattributevalue src "ИМЯ_001")) ;;----------------------------------------------------------------------;; )) (while (and (/= "" (setq new (getstring t (strcat "\nSpecify new block name <" def ">: ")))) (or (not (snvalid new)) (tblsearch "block" new) ) ) (princ "\nBlock name invalid or already exists.") ) (if (= "" new) (setq new def) ) (setq dbx (vl-catch-all-apply 'vla-getinterfaceobject (list app (if (< (setq vrs (atoi (getvar 'acadver))) 16) "objectdbx.axdbdocument" (strcat "objectdbx.axdbdocument." (itoa vrs)) ) ) ) ) (if (or (null dbx) (vl-catch-all-error-p dbx)) (princ "\nUnable to interface with ObjectDBX.") (progn (setq abc (vla-get-blocks doc) dbc (vla-get-blocks dbx) ) (vlax-invoke doc 'copyobjects (list (vla-item abc old)) dbc) (if (wcmatch old "`**") (vla-put-name (vla-item dbc (1- (vla-get-count dbc))) new) (vla-put-name (vla-item dbc old) new) ) (vlax-invoke dbx 'copyobjects (list (vla-item dbc new)) abc) (vlax-release-object dbx) (if cpy (setq src (vla-copy src))) (if (and (vlax-property-available-p src 'isdynamicblock) (= :vlax-true (vla-get-isdynamicblock src)) ) (progn (setq prp (mapcar 'vla-get-value (vlax-invoke src 'getdynamicblockproperties))) (vla-put-name src new) (mapcar '(lambda ( a b ) (if (/= "ORIGIN" (strcase (vla-get-propertyname a))) (vla-put-value a b) ) ) (vlax-invoke src 'getdynamicblockproperties) prp ) ) (vla-put-name src new) ) (if (= :vlax-true (vla-get-isxref (setq def (vla-item (vla-get-blocks doc) new)))) (vla-reload def) ) (if cpy (sssetfirst nil (ssadd (vlax-vla-object->ename src)))) ) ) ) ) (princ) ) ;;----------------------------------------------------------------------;; (vl-load-com) (princ (strcat "\n:: CopyRenameBlock.lsp | Version 1.5 | \\U+00A9 Lee Mac " (menucmd "m=$(edtime,$(getvar,date),YYYY)") " www.lee-mac.com ::" "\n:: Available Commands:" "\n:: \"CB\" - Copy & Rename Block Reference." "\n:: \"RB\" - Rename Block Reference." ) ) (princ) ;;----------------------------------------------------------------------;; ;; End of File ;; ;;----------------------------------------------------------------------;; (defun LM:vl-getattributevalue ( blk tag ) (setq tag (strcase tag)) (vl-some '(lambda ( att ) (if (= tag (strcase (vla-get-tagstring att))) (vla-get-textstring att))) (vlax-invoke blk 'getattributes)) )

Спасибо большое, за ответ.
При выполнении вашего кода вылетает из автокада, если выбрать следующий блок с таким же значением аттрибута, как предыдущий. Прилагаю файл в котором вылетает.
У меня в чертеже имеется несколько одинаковых по параметрам динамических блоков с одинаковым значением атрибута. Хотелось бы, чтобы команда работала не только с одним вхождением, а выделить нужные для переименования блоки в большом колличестве.
Например я имею в чертеже 100 блоков с именем "стойка" Из них 70 с атрибутом "ИМЯ_001" - со значением "СТ-1", И 30 с атрибутом "ИМЯ_001" - со значением "СТ-2", После ввода команды выделяю нужные для изменения блоки, и создается 70 блоков с именем "СТ-1" и 30 блоков "СТ-2", с сохранением их динамических свойств.

[Nike]

Переименовать массово все анонимные вхождения одного блока я не знаю как.
Предлагаю первым переименованным заменить заранее выбранные остальные с помощью этого лиспа:

Код:

[Выделить все]

 (defun c:replace_blocks (/ ACTDOC COPOBJ ERRCOUNT EXTLST
        EXTSET FROMCEN LAYCOL MAXPT CURLAY
        MINPT OBJLAY OKCOUNT OLAYST
        SCLAY TOCEN TOOBJ VLAOBJ *ERROR*)
  (vl-load-com)
  (defun *ERROR*(msg)
    (if olaySt
      (vla-put-Lock objLay olaySt)
      ); end if
    (vla-EndUndoMark actDoc)
    (princ)
    ); end of *ERROR*
  (defun GetBoundingCenter(vlaObj / blPt trPt cnPt)
  (vla-GetBoundingBox vlaObj 'minPt 'maxPt)
      (setq blPt(vlax-safearray->list minPt)
       trPt(vlax-safearray->list maxPt)
       cnPt(vlax-3D-point
        (list
             (+(car blPt)(/(-(car trPt)(car blPt))2))
             (+(cadr blPt)(/(-(cadr trPt)(cadr blPt))2))
          0.0
            ); end list
      ); end vlax-3D-point
     ); end setq
  ); end of GetBoundingCenter
  (if(not(setq extSet(ssget "_I")))
    (progn
      (princ "\nВыберите объекты, которые нужно заменить ")
      (setq extSet(ssget))
      ); end progn
    ); end if
  (if(not extSet)
    (princ "\nDistination objects isn't selected!")
    ); end if
  (if
    (and
    extSet
    (setq toObj(entsel "\nУкажите объект-образец "))
    ); and and
    (progn
      (setq actDoc
        (vla-get-ActiveDocument
          (vlax-get-Acad-object))
       layCol
        (vla-get-Layers actDoc)
       extLst
        (mapcar 'vlax-ename->vla-object
                    (vl-remove-if 'listp
                     (mapcar 'cadr(ssnamex extSet))))
       vlaObj(vlax-ename->vla-object(car toObj))
       objLay(vla-Item layCol
             (vla-get-Layer vlaObj))
       olaySt(vla-get-Lock objLay)
       fromCen(GetBoundingCenter vlaObj)
       errCount 0
       okCount 0
       ); end setq
      (vla-StartUndoMark actDoc)
      (foreach obj extLst
   (setq toCen(GetBoundingCenter obj)
         scLay(vla-Item layCol
              (vla-get-Layer obj))
              );end setq
   (if(/= :vlax-true(vla-get-Lock scLay))
     (progn
     (setq curLay(vla-get-Layer obj))
     (setq curRot(vla-get-rotation obj))
     (vla-put-Lock objLay :vlax-false)
     (setq copObj(vla-copy vlaObj))
     (vla-Move copObj fromCen toCen)
     (vla-put-Layer copObj curLay)
     (vla-put-rotation copObj curRot)
     (vla-put-Lock objLay olaySt)
     (vla-Delete obj)
     (setq okCount(1+ okCount))
     ); end progn
     (setq errCount(1+ errCount))
     ); end if
   ); end foreach
      (princ
   (strcat "\n" (itoa okCount) " were changed. "
      (if(/= 0 errCount)
        (strcat (itoa errCount) " were on locked layer! ")
        ""
        ); end if
      ); end strcat
   ); end princ
      (vla-EndUndoMark actDoc)
      ); end progn
    (princ "\nSource object isn't selected! ")
    ); end if
  (princ)
  );

[engngr]

Для чего это нужно?

[kirillwu]

Сообщение от engngr Для чего это нужно?

Дело в том, что у меня на работе главный конструктор очень консервативен в автокаде. Когда в автокаде проявились динамические блоки, у меня в компании был придуман стандарт оформления, в котором каждый блок спецификации должен быть назван по своей маркировке. Всем крайне не удобно работать с моим файлом. Спецификации привыкли проверять командой "выбрать подобные", которая с моими блоками не работает корректно. На команду "найти" никто не хочет переходить.

Возможно проще написать лисп, аналог команды "выбрать подобные"? Только выделяющую блоки не только по одинаковому именю, слою и т.д. А еще учитывающая разность в атрибутах?

[Кулик Алексей aka kpblc]

Пускай изучат команду _.dataextraction

[kirillwu]

Сообщение от Кулик Алексей aka kpblc Пускай изучат команду _.dataextraction

Изучена! Главный конструктор теряет визуальный интерфейс без команды "выбрать подобные", к сожалению ничего не могу с этим поделать(

----- добавлено через ~16 мин. -----

Сообщение от Nike Переименовать массово все анонимные вхождения одного блока я не знаю как. Предлагаю первым переименованным заменить заранее выбранные остальные с помощью этого лиспа: Код: [Выделить все] (defun c:replase_blocks (/ACTDOC COPOBJ ERRCOUNT EXTLST EXTSET FROMCEN LAYCOL MAXPT CURLAY MINPT OBJLAY OKCOUNT OLAYST SCLAY TOCEN TOOBJ VLAOBJ *ERROR*) (vl-load-com) (defun *ERROR*(msg) (if olaySt (vla-put-Lock objLay olaySt) ); end if (vla-EndUndoMark actDoc) (princ) ); end of *ERROR* (defun GetBoundingCenter(vlaObj / blPt trPt cnPt) (vla-GetBoundingBox vlaObj 'minPt 'maxPt) (setq blPt(vlax-safearray->list minPt) trPt(vlax-safearray->list maxPt) cnPt(vlax-3D-point (list (+(car blPt)(/(-(car trPt)(car blPt))2)) (+(cadr blPt)(/(-(cadr trPt)(cadr blPt))2)) 0.0 ); end list ); end vlax-3D-point ); end setq ); end of GetBoundingCenter (if(not(setq extSet(ssget "_I"))) (progn (princ "\nВыберите объекты, которые нужно заменить ") (setq extSet(ssget)) ); end progn ); end if (if(not extSet) (princ "\nDistination objects isn't selected!") ); end if (if (and extSet (setq toObj(entsel "\nУкажите объект-образец ")) ); and and (progn (setq actDoc (vla-get-ActiveDocument (vlax-get-Acad-object)) layCol (vla-get-Layers actDoc) extLst (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr(ssnamex extSet)))) vlaObj(vlax-ename->vla-object(car toObj)) objLay(vla-Item layCol (vla-get-Layer vlaObj)) olaySt(vla-get-Lock objLay) fromCen(GetBoundingCenter vlaObj) errCount 0 okCount 0 ); end setq (vla-StartUndoMark actDoc) (foreach obj extLst (setq toCen(GetBoundingCenter obj) scLay(vla-Item layCol (vla-get-Layer obj)) );end setq (if(/= :vlax-true(vla-get-Lock scLay)) (progn (setq curLay(vla-get-Layer obj)) (setq curRot(vla-get-rotation obj)) (vla-put-Lock objLay :vlax-false) (setq copObj(vla-copy vlaObj)) (vla-Move copObj fromCen toCen) (vla-put-Layer copObj curLay) (vla-put-rotation copObj curRot) (vla-put-Lock objLay olaySt) (vla-Delete obj) (setq okCount(1+ okCount)) ); end progn (setq errCount(1+ errCount)) ); end if ); end foreach (princ (strcat "\n" (itoa okCount) " were changed. " (if(/= 0 errCount) (strcat (itoa errCount) " were on locked layer! ") "" ); end if ); end strcat ); end princ (vla-EndUndoMark actDoc) ); end progn (princ "\nSource object isn't selected! ") ); end if (princ) );

Выдает ошибку "слишком мало аргументов"

[Nike]

Сообщение от kirillwu Выдает ошибку "слишком мало аргументов"

исправил

----- добавлено через ~6 мин. -----

Сообщение от kirillwu Спецификации привыкли проверять командой "выбрать подобные", которая с моими блоками не работает корректно. На команду "найти" никто не хочет переходить.

Это поможет:
Выбор блоков по значению атрибутов.

Код:

[Выделить все]

 (defun c:get-blocks-by-tag-and-val (/                         attr                      tag
                                    value                     selset                    res
                                    fun_get-attr              _kpblc-conv-selset-to-ename
                                    _kpblc-conv-vla-to-list   _kpblc-conv-ent-to-vla    _kpblc-conv-ent-to-ename
                                    _kpblc-conv-list-to-string                          _kpblc-conv-value-to-string
                                    )

  (defun _kpblc-conv-list-to-string (lst sep)
                                    ;|
*    Преобразование списка в строку
*    Параметры вызова:
	lst	обрабатываемй список
	sep	разделитель. nil -> " "
|;
    (setq lst (mapcar (function _kpblc-conv-value-to-string) lst)
          sep (if sep
                sep
                " "
                ) ;_ end of if
          ) ;_ end of setq
    (strcat (car lst)
            (apply (function strcat)
                   (mapcar
                     (function
                       (lambda (x)
                         (strcat sep x)
                         ) ;_ end of lambda
                       ) ;_ end of function
                     (cdr lst)
                     ) ;_ end of mapcar
                   ) ;_ end of apply
            ) ;_ end of strcat
    ) ;_ end of defun

  (defun _kpblc-conv-value-to-string (value /)
                                     ;|
*    конвертация значения в строку.
|;
    (cond
      ((= (type value) 'str) value)
      ((= (type value) 'int) (itoa value))
      ((= (type value) 'real) (rtos value 2 14))
      ((not value) "")
      (t (vl-princ-to-string value))
      ) ;_ end of cond
    ) ;_ end of defun


  (defun fun_get-attr (blk)
    (append (_kpblc-conv-vla-to-list (vla-getattributes blk))
            (_kpblc-conv-vla-to-list (vla-getconstantattributes blk))
            ) ;_ end of append
    ) ;_ end of defun

  (defun _kpblc-conv-selset-to-ename (selset / tab item)
                                     ;|
*    Преобразование набора, полученного через ssget, в список ename-представлени
* примитивов.
*    Параметры вызова:
	selset	набор примитивов
*    Примеры вызова:
(_kpblc-conv-selset-to-ename (ssget))
|;
    (cond
      ((not selset) nil)
      ((= (type selset) 'pickset)
       (repeat (setq tab  nil
                     item (sslength selset)
                     ) ;_ end setq
         (setq tab (cons (ssname selset (setq item (1- item))) tab))
         ) ;_ end repeat
       )
      ((= (type selset) 'vla-object)
       (_kpblc-conv-vla-to-list selset)
       )
      ((listp selset) selset)
      ) ;_ end of cond
    ) ;_ end of defun

  (defun _kpblc-conv-vla-to-list (value / res)
                                 ;|
*    Преобразовывает vlax-variant или vlax-safearray в список.
|;
    (cond
      ((listp value)
       (mapcar '_kpblc-conv-vla-to-list value)
       )
      ((= (type value) 'variant)
       (_kpblc-conv-vla-to-list (vlax-variant-value value))
       )
      ((= (type value) 'safearray)
       (if (>= (vlax-safearray-get-u-bound value 1) 0)
         (_kpblc-conv-vla-to-list (vlax-safearray->list value))
         ) ;_ end of if
       )
      ((and (member (type value) (list 'ename 'str 'vla-object))
            (= (type (_kpblc-conv-ent-to-vla value)) 'vla-object)
            (vlax-property-available-p (_kpblc-conv-ent-to-vla value) 'count)
            ) ;_ end of and
       (vlax-for sub (_kpblc-conv-ent-to-vla value)
         (setq res (cons sub res))
         ) ;_ end of vlax-for
       )
      (t value)
      ) ;_ end of cond
    ) ;_ end of defun

  (defun _kpblc-conv-ent-to-ename (ent_value /)
                                  ;|
*    Функция преобразования полученного значения в ename
*    Параметры вызова:
*	ent_value	значение, которое надо преобразовать в примитив. Может
*			быть именем примитива, vla-указателем или просто
*			списком.
*			Если не принадлежит ни одному из указанных типов,
*			возвращается nil
*    Примеры вызова:
(_kpblc-conv-ent-to-ename (entlast))
(_kpblc-conv-ent-to-ename (vlax-ename->vla-object (entlast)))
|;
    (cond
      ((= (type ent_value) 'vla-object)
       (vlax-vla-object->ename ent_value)
       )
      ((= (type ent_value) 'ename) ent_value)
      ((= (type ent_value) 'str) (handent ent_value))
      ((= (type ent_value) 'list) (cdr (assoc -1 ent_value)))
      (t nil)
      ) ;_ end of cond
    ) ;_ end of defun

  (defun _kpblc-conv-ent-to-vla (ent_value / res)
                                ;|
*    Функция преобразования полученного значения в vla-указатель.
*    Параметры вызова:
*	ent_value	значение, которое надо преобразовать в указатель. Может
*			быть именем примитива, vla-указателем или просто
*			списком.
*			Если не принадлежит ни одному из указанных типов,
*			возвращается nil
*    Примеры вызова:
(_kpblc-conv-ent-to-vla (entlast))
(_kpblc-conv-ent-to-vla (vlax-ename->vla-object (entlast)))
|;
    (cond
      ((= (type ent_value) 'vla-object) ent_value)
      ((= (type ent_value) 'ename) (vlax-ename->vla-object ent_value))
      ((setq res (_kpblc-conv-ent-to-ename ent_value))
       (vlax-ename->vla-object res)
       )
      ) ;_ end of cond
    ) ;_ end of defun


  (vl-load-com)
  (if
    (and
      (or (and (= (type (setq attr (vl-catch-all-apply
                                     (function
                                       (lambda ()
                                         (car (nentsel "\nУкажите атрибут <Вводить с клавиатуры> : "))
                                         ) ;_ end of lambda
                                       ) ;_ end of function
                                     ) ;_ end of vl-catch-all-apply
                              ) ;_ end of setq
                        ) ;_ end of type
                  'ename
                  ) ;_ end of =
               (= (cdr (assoc 0 (entget attr))) "ATTRIB")
               (setq attr  (vlax-ename->vla-object attr)
                     tag   (vla-get-tagstring attr)
                     value (vla-get-textstring attr)
                     ) ;_ end of setq
               ) ;_ end of and
          (and (= (type (setq tag (vl-catch-all-apply
                                    (function
                                      (lambda ()
                                        (getstring "\nВведите тэг атрибута для фильтрации <Отмена> : ")
                                        ) ;_ end of lambda
                                      ) ;_ end of function
                                    ) ;_ end of vl-catch-all-apply
                              ) ;_ end of setq
                        ) ;_ end of type
                  'str
                  ) ;_ end of =
               (= (type
                    (setq value (vl-catch-all-apply
                                  (function
                                    (lambda ()
                                      (getstring "\nВведите значение атрибута для фильтрации (с учетом маски) <Отмена> : ")
                                      ) ;_ end of lambda
                                    ) ;_ end of function
                                  ) ;_ end of vl-catch-all-apply
                          ) ;_ end of setq
                    ) ;_ end of type
                  'str
                  ) ;_ end of =
               ) ;_ end of and
          ) ;_ end of or
      (= (type (setq selset (vl-catch-all-apply
                              (function
                                (lambda ()
                                  (ssget '((0 . "INSERT") (66 . 1)))
                                  ) ;_ end of lambda
                                ) ;_ end of function
                              ) ;_ end of vl-catch-all-apply
                     ) ;_ end of setq
               ) ;_ end of type
         ) ;_ end of =
      ) ;_ end of and
     (progn
       (setq tag    (strcase tag)
             value  (strcase value)
             selset (vl-remove-if-not
                      (function
                        (lambda (x / lst)
                          (setq lst (mapcar
                                      (function
                                        (lambda (i)
                                          (cons (strcase (vla-get-tagstring i))
                                                (strcase (vla-get-textstring i))
                                                ) ;_ end of cons
                                          ) ;_ end of lambda
                                        ) ;_ end of function
                                      (fun_get-attr (vlax-ename->vla-object x))
                                      ) ;_ end of mapcar
                                ) ;_ end of setq
          ;(function vla-get-textstring) (fun_get-attr (vlax-ename->vla-object x))))
                          (vl-remove-if-not
                            (function
                              (lambda (a)
                                (and (or (= (car a) tag) (wcmatch (car a) tag))
                                     (or (= (cdr a) value) (wcmatch (cdr a) value))
                                     ) ;_ end of and
                                ) ;_ end of lambda
                              ) ;_ end of function
                            lst
                            ) ;_ end of vl-remove-if-not
                          ) ;_ end of lambda
                        ) ;_ end of function
                      (_kpblc-conv-selset-to-ename selset)
                      ) ;_ end of vl-remove-if-not
             res    (ssadd)
             ) ;_ end of setq
       (foreach item selset
         (ssadd item res)
         ) ;_ end of foreach
       (sssetfirst res res)
       ) ;_ end of progn
     ) ;_ end of if
  (princ)
  ) ;_ end of defun

[kirillwu]

----- добавлено через ~5 мин. -----

Сообщение от Nike исправил

Спасибо большое, заработало.

Если соединить эти два лиспа. Получится то, что требует. Спасибо.

[engngr]

Если каждому идентичному по сути блоку давать различные имена, то частично теряется смысл их использования, в частности - экономия ресурсов.

[Сергей812]

Сообщение от engngr Если каждому идентичному по сути блоку давать различные имена, то частично теряется смысл их использования, в частности - экономия ресурсов.

Динамические блоки сами по себе неплохо засоряют чертеж промежуточными анонимными блоками) Так что определением блока больше/меньше в чертеже - в данном случае уже особой роли не играет, имхо.

[Nike]

Сообщение от kirillwu Если соединить эти два лиспа. Получится то, что требует. Спасибо.

Держи. Скрестил ужа с ежом.

Код:

[Выделить все]

   
  
CopyRenameBlockV1-5.lsp © 2018 Lee Mac
DarkLightVLIDE
;;-----------------=={ Copy/Rename Block Reference }==------------------;;
;;                                                                      ;;
;;  This program allows a user to copy and/or rename a single block     ;;
;;  reference in the working drawing.                                   ;;
;;                                                                      ;;
;;  Many existing programs enable the user to rename the block          ;;
;;  definition for a given block reference, with the new name           ;;
;;  subsequently reflected across all references of the block           ;;
;;  definition in the drawing. However, this program will allow a       ;;
;;  single selected block reference to be renamed (or for the user to   ;;
;;  create a renamed copy of the selected block reference), by          ;;
;;  generating a duplicate renamed block definition for the selected    ;;
;;  block.                                                              ;;
;;                                                                      ;;
;;  The program may be called from the command-line using either 'CB'   ;;
;;  to create a renamed copy of a selected block reference, or 'RB' to  ;;
;;  simply rename the selected block reference.                         ;;
;;                                                                      ;;
;;  Following selection of a block reference, the user is prompted to   ;;
;;  specify a name for the selected/copied block reference; a default   ;;
;;  block name composed of the original block name concatenated with    ;;
;;  both an underscore and the minimum integer required for uniqueness  ;;
;;  within the block collection of the active drawing is offered.       ;;
;;                                                                      ;;
;;  The program will then proceed to duplicate the block definition     ;;
;;  using the new block name. To accomplish this without resulting in   ;;
;;  a duplicate key in the block collection of the active drawing, the  ;;
;;  program utilises an ObjectDBX interface to which the block          ;;
;;  definition of the selected block reference is deep-cloned, renamed, ;;
;;  and then deep-cloned back to the active drawing. This method also   ;;
;;  enables Dynamic Block definitions to be successfully copied         ;;
;;  & renamed.                                                          ;;
;;                                                                      ;;
;;  Finally, this program will perform successfully in all UCS/Views    ;;
;;  and is compatible with Anonymous Blocks, Dynamic Blocks & XRefs.    ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2013  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.5    -    05-07-2013                                      ;;
;;----------------------------------------------------------------------;;
 
(defun c:cb nil (LM:RenameBlockReference   t))
(defun c:rb nil (LM:RenameBlockReference nil))
 
(defun LM:RenameBlockReference ( cpy / *error* abc app dbc dbx def doc dxf new old prp src tmp vrs )
 
    (defun *error* ( msg )
        (if (and (= 'vla-object (type dbx)) (not (vlax-object-released-p dbx)))
            (vlax-release-object dbx)
        )
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
    
    (while
        (progn
            (setvar 'errno 0)
            (setq src (car (entsel (strcat "\nSelect block reference to " (if cpy "copy & " "") "rename: "))))          
            (cond
                (   (= 7 (getvar 'errno))
                    (princ "\nMissed, try again.")
                )
                (   (= 'ename (type src))
                    (setq dxf (entget src))
                    (cond
                        (   (/= "INSERT" (cdr (assoc 0 dxf)))
                            (princ "\nPlease select a block reference.")
                        )
                        (   (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (cdr (assoc 8 dxf)))))))
                            (princ "\nSelected block is on a locked layer.")
                        )
                    )
                )
            )
        )
    )
    (if (= 'ename (type src))
        (progn
            (setq app (vlax-get-acad-object)
                  doc (vla-get-activedocument app)
                  src (vlax-ename->vla-object src)
                  old (vlax-get-property src (if (vlax-property-available-p src 'effectivename) 'effectivename 'name))
                  tmp 0
            )
;;;            (while (tblsearch "block" ;(setq def (strcat (vl-string-left-trim "*" old) "_" (itoa (setq tmp (1+ tmp)))))
 
;;----------------------------------------------------------------------;;
                     (setq def (LM:vl-getattributevalue src "ИМЯ_001"))
;;----------------------------------------------------------------------;;
;;;                     ))
            (while
               (and (/= "" (setq new (getstring t (strcat "\nSpecify new block name <" def ">: "))))
                    (or (not (snvalid new))
                        (tblsearch "block" new)
                    )
                )
                (princ "\nBlock name invalid or already exists.")
            )
            (if (= "" new)
                (setq new def)
            )
            (setq dbx
                (vl-catch-all-apply 'vla-getinterfaceobject
                    (list app
                        (if (< (setq vrs (atoi (getvar 'acadver))) 16)
                            "objectdbx.axdbdocument"
                            (strcat "objectdbx.axdbdocument." (itoa vrs))
                        )
                    )
                )
            )
            (if (or (null dbx) (vl-catch-all-error-p dbx))
                (princ "\nUnable to interface with ObjectDBX.")
                (progn
                    (setq abc (vla-get-blocks doc)
                          dbc (vla-get-blocks dbx)
                    )
                    (vlax-invoke doc 'copyobjects (list (vla-item abc old)) dbc)
                    (if (wcmatch old "`**")
                        (vla-put-name (vla-item dbc (1- (vla-get-count dbc))) new)
                        (vla-put-name (vla-item dbc old) new)
                    )
                    (vlax-invoke dbx 'copyobjects (list (vla-item dbc new)) abc)
                    (vlax-release-object dbx)
                    (if cpy (setq src (vla-copy src)))
                    (if
                        (and
                            (vlax-property-available-p src 'isdynamicblock)
                            (= :vlax-true (vla-get-isdynamicblock src))
                        )
                        (progn
                            (setq prp (mapcar 'vla-get-value (vlax-invoke src 'getdynamicblockproperties)))
                            (vla-put-name src new)
                            (mapcar
                               '(lambda ( a b )
                                    (if (/= "ORIGIN" (strcase (vla-get-propertyname a)))
                                        (vla-put-value a b)
                                    )
                                )
                                (vlax-invoke src 'getdynamicblockproperties) prp
                            )
                        )
                        (vla-put-name src new)
                    )
                    (if (= :vlax-true (vla-get-isxref (setq def (vla-item (vla-get-blocks doc) new))))
                        (vla-reload def)
                    )
                    (if cpy (sssetfirst nil (ssadd (vlax-vla-object->ename src))))
                )
            )
        )
    )
    (princ)
  (c:select_blocks_by_attr)
  (c:replase_blocks)
)
 
;;----------------------------------------------------------------------;;
 
(vl-load-com)
(princ
    (strcat
        "\n:: CopyRenameBlock.lsp | Version 1.5 | \\U+00A9 Lee Mac "
        (menucmd "m=$(edtime,$(getvar,date),YYYY)")
        " www.lee-mac.com ::"
        "\n:: Available Commands:"
        "\n::    \"CB\"  -  Copy & Rename Block Reference."
        "\n::    \"RB\"  -  Rename Block Reference."
    )
)
(princ)
 
;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;


(defun LM:vl-getattributevalue ( blk tag )
    (setq tag (strcase tag))
    (vl-some '(lambda ( att ) (if (= tag (strcase (vla-get-tagstring att))) (vla-get-textstring att))) (vlax-invoke blk 'getattributes))
)



(defun c:replase_blocks (/ ACTDOC COPOBJ ERRCOUNT EXTLST
       EXTSET FROMCEN LAYCOL MAXPT CURLAY
       MINPT OBJLAY OKCOUNT OLAYST
       SCLAY TOCEN TOOBJ VLAOBJ *ERROR*)
 (vl-load-com)
 ; end of *ERROR*
 (defun GetBoundingCenter(vlaObj / blPt trPt cnPt)
 (vla-GetBoundingBox vlaObj 'minPt 'maxPt)
     (setq blPt(vlax-safearray->list minPt)
      trPt(vlax-safearray->list maxPt)
      cnPt(vlax-3D-point
       (list
            (+(car blPt)(/(-(car trPt)(car blPt))2))
            (+(cadr blPt)(/(-(cadr trPt)(cadr blPt))2))
         0.0
           ); end list
     ); end vlax-3D-point
    ); end setq
 ); end of GetBoundingCenter
 (if(not(setq extSet(ssget "_I")))
   (progn
     (princ "\nВыберите объекты, которые нужно заменить ")
     (setq extSet(ssget))
     ); end progn
   ); end if
 (if(not extSet)
   (princ "\nDistination objects isn't selected!")
   ); end if
 (if
   (and
   extSet
   (setq toObj (entsel "\nУкажите объект-образец "))
      ); and and
   (progn
     (setq actDoc
       (vla-get-ActiveDocument
         (vlax-get-Acad-object))
      layCol
       (vla-get-Layers actDoc)
      extLst
       (mapcar 'vlax-ename->vla-object
                   (vl-remove-if 'listp
                    (mapcar 'cadr(ssnamex extSet))))
      vlaObj(vlax-ename->vla-object (car toObj))
      objLay(vla-Item layCol
            (vla-get-Layer vlaObj))
      olaySt(vla-get-Lock objLay)
      fromCen(GetBoundingCenter vlaObj)
      errCount 0
      okCount 0
      ); end setq
     (vla-StartUndoMark actDoc)
     (foreach obj extLst
  (setq toCen(GetBoundingCenter obj)
        scLay(vla-Item layCol
             (vla-get-Layer obj))
             );end setq
  (if(/= :vlax-true(vla-get-Lock scLay))
    (progn
    (setq curLay(vla-get-Layer obj))
    (setq curRot(vla-get-rotation obj))
    (vla-put-Lock objLay :vlax-false)
    (setq copObj(vla-copy vlaObj))
    (vla-Move copObj fromCen toCen)
    (vla-put-Layer copObj curLay)
    (vla-put-rotation copObj curRot)
    (vla-put-Lock objLay olaySt)
    (vla-Delete obj)
    (setq okCount(1+ okCount))
    ); end progn
    (setq errCount(1+ errCount))
    ); end if
  ); end foreach
     (princ
  (strcat "\n" (itoa okCount) " were changed. "
     (if(/= 0 errCount)
       (strcat (itoa errCount) " were on locked layer! ")
       ""
       ); end if
     ); end strcat
  ); end princ
     (vla-EndUndoMark actDoc)
     ); end progn
   (princ "\nSource object isn't selected! ")
   ); end if
 (princ)
 );



(defun C:select_blocks_by_attr ()

;;;  (setq e1 (nentsel "\nSelect attribute to filter: "))
;;;
;;;  (if (null e1)
;;;    (progn (setq ex_tag nil) (quit))
;;;    (progn
;;;      (while (/= (cdr (assoc 0 (entget (car e1)))) "ATTRIB")
;;;        (princ "Attribute not found. ")
;;;        (princ (cdr (assoc 0 (entget (car e1)))))
;;;        (RT1)
;;;      ) ;end while
;;;
;;;    ) ;end progn
;;;  ) ;end if

  (setvar "cmdecho" 0)
;;;  (setq eget (entget (car e1)))
  (setq EX_STR new) ;EXISTING TEXTSTRING
  (setq ex_tag "ИМЯ_001") ;EXISTING tag

;;;  (setq PT1 (cadr E1))
;;;  (setq SS0 (ssget PT1))
;;; (setq BLKNAME (cdr (assoc 2 (entget (ssname SS0 0)))))
;;;  (setq effBLKNAME (vla-get-effectivename (vlax-ename->vla-object (ssname SS0 0))))
  (setq BLKNAME old)
  (setq effBLKNAME old)

  (prompt (strcat "\n ** Блок: " blkname "   Атрибут: " ex_tag "   >: " ex_str))


 ;______________ SELECTING BLOCKS "BLKNAME" _________________

  (setq LST1 (list '(0 . "INSERT") (cons 2 effBLKNAME)))
  (setvar "nomutt" 1)
;;;  (setq SS1 (ssget "_X" LST1))
;;;  (setq ss1 (ssget '((0 . "INSERT"))))
  (setq ss1 (ssget "_X" '((0 . "INSERT"))))
  (mapcar
    '(lambda (name)
       (if (/= (vl-catch-all-apply 'vla-get-effectivename (list (vlax-ename->vla-object name))) effBLKNAME)
         (ssdel name ss1)

       ) ;_ end of if
     ) ;_ end of lambda
    (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss1)))
  )
    ; (SETQ SS1 (SSGET LST1))
    ; (IF (NULL SS1) (SETQ SS1 (SSGET "_X" LST1)) )
  (setvar "nomutt" 0)

  (setq SSM (ssadd))
  (setq len1 (sslength ss1)
        n1   0
        ssx  (ssadd)
  ) ;_ end of setq


  (while (< n1 len1) ;WHILE 1
    (setq ename1  (ssname ss1 n1)
          eget1   (entget ename1)
          CTRL1   nil
          COUNTER 0
          str1    ""
    ) ;_ end of setq
    (setq en1 ename1)
 ;____ Find Tag Level
    (while (and (null ctrl1) (/= (cdr (assoc 0 (entget (setq en1 (entnext en1))))) "SEQEND"))
      (setq tag1 (cdr (assoc 2 (entget en1))))
      (if (= tag1 ex_tag)
        (setq str1  (cdr (assoc 1 (entget en1)))
              ctrl1 t
        ) ;_ end of setq
      ) ;_ end of if
      (setq counter (1+ counter))
    ) ;end while2
 ;_____

    ;(if (= str1 ex_str) (princ str1))
    (if (= (strcase str1) (strcase ex_str))
      (setq ssx (ssadd ename1 ssx))
    ) ;_ end of if
    (setq n1 (1+ n1))
  ) ; end WHILE1


  (setq lenx (sslength ssx))
  (command "_.select" ssx "")
  (prompt (strcat "\n ** Всего найдено : ** " (itoa lenx) " **"))

  (command "_zoom" "_o" ssx "")
  (command "._zoom" "0.5X")
  (setvar "cmdecho" 1)
  (sssetfirst nil ssx)
  (princ)
)

[VVA]

Мой вариант

[kirillwu]

Сообщение от VVA Мой вариант

Попробовал у себя. Подскажите, пожалуйста: правильно ли я понял: Ввёл команду, выделил шесть блоков в кружочке "оригинал". На месте одного из них создался новый блок, с именем, совпадающим с значения атрибута того блока, на котором создался. Ноо с пустым атрибутом и только один. Получается для получения нужного мне результата нужно вызвать команду, нажать на каждый блок, который нужно переименовать по отдельности. А затем скопировать значения атрибута "ИМЯ_001"на каждый из созданный блоков в ручную?

Хотелось бы между "Оригиналом" и "Результатом" - выполнить одно применение вашего лиспа.
Огромное вам спасибо за ответы в этой теме!!

[VVA]

Сообщение от kirillwu Получается для получения нужного мне результата нужно вызвать команду, нажать на каждый блок, который нужно переименовать по отдельности. А затем скопировать значения атрибута "ИМЯ_001"на каждый из созданный блоков в ручную?

Нет
kirillwu, проверил на другой машине. Автокад 2013x64, W7x64
Команда вводится 1 раз, блоки создаются по имени атрибута и копируются их значения

[kirillwu]

Сообщение от VVA Нет kirillwu, проверил на другой машине. Автокад 2013x64, W7x64 Команда вводится 1 раз, блоки создаются по имени атрибута и копируются их значения

"New block "Ст-03.18-01" created succesfully; ошибка: no function definition: MIP-CONV-TO-STR"

Забыл упомянуть, если выделять блоки массово в командной строке вылезает эта надпись

[VVA]

Сообщение от kirillwu "New block "Ст-03.18-01" created succesfully; ошибка: no function definition: MIP-CONV-TO-STR"

обновил #14. Перезагрузи лисп

[kirillwu]

Сообщение от VVA обновил #14. Перезагрузи лисп

Огромное вам спасибо!!!

[kirillwu]

Сообщение от VVA обновил #14. Перезагрузи лисп

Приветствую! Не могли бы вы еще чуть помочь. После выполнения лиспа в #14 аттрибуты, являющиеся многострочными становятся однострочными. Возможно ли это убрать?
Тестовый файл в вложении

[VVA]

kirillwu, Тестируй

[koMon]

Сообщение от kirillwu В файле имеются множество вхождений динамического блока. … атрибут с тэгом "ИМЯ_001" … имя блока "Стойка". … лисп … переименует каждое вхождение в блока в значение атрибута с тэгом "ИМЯ_001"… с сохранением их динамических свойств.

Собственно вариант без dbx.
Выбираем все блоки, обрабатываем только с именем "Стойка". Пишем блок wblock-ом в TEMP, снимаем значения атрибутов, динамические свойства c оригинального блока, копируем блок в TEMP с именем равным значению атрибута "ИМЯ_001", вставялем его в обрабатываемый чертёж, восстанвливаем значения атрибутов, динамические свойства, удаляем оригинальный блок. Далее по циклу для всех выбранных блоков. удаляем файлы из TEMP.

Без обвесов.

Код:

[Выделить все]

 
(defun c:Block_to_NAME001 ()
	(setq acad_Object (vlax-get-acad-object)
		  acad_preferences (vla-get-Preferences acad_object)
		  Temp_File_Path (vla-get-TempFilePath (vla-get-Files acad_preferences))
		  document_object (vla-get-Activedocument acad_Object)
		  modelSpace_object (vla-get-modelSpace document_object)
		  blocks_collection (vla-get-blocks document_object)
		  blocks_pickset (ssget "_X" '((0 . "Insert")))
		  blocks_selected (sslength blocks_pickset)
		  blocks_processed 0
		  temp_blocks_written_list '()
		  renamed_blocks_written_list '()
		  var_set (setvar 'cmdecho 0)
	)
	(while (< 0 (sslength blocks_pickset))
		(setq current_block_object (vlax-ename->vla-object (ssname blocks_pickset 0)))
			(if (member (strcase (vla-get-effectivename current_block_object)) (mapcar 'strcase '("Стойка" "Ригель" "Кронштейн" "Заполнения")))
				(progn
					(setq attribute_values_list '()
						  attribute_values_list (append attribute_values_list (list (cons "Name" (vla-get-effectivename current_block_object))))
						  attribute_values_list (append attribute_values_list (list (cons "Insertion_Point" (vla-get-insertionpoint current_block_object))))
						  attributes_objects_list (vlax-safearray->list (vlax-variant-value (vla-getattributes current_block_object)))
					)
					(foreach attribute_object attributes_objects_list
						(setq attribute_values_list (append attribute_values_list (list (cons (vla-get-tagstring attribute_object) (vla-get-textstring attribute_object)))))
					)
					(if (= :vlax-true (vla-get-isdynamicblock current_block_object))
						(progn
							(setq dynamic_properties_list (vlax-safearray->list (vlax-variant-value (vla-getdynamicblockproperties current_block_object))))
							(foreach dynamic_property dynamic_properties_list
								(if (/= "Origin" (vla-get-PropertyName dynamic_property))
							 		(setq attribute_values_list (append attribute_values_list (list (cons (vla-get-PropertyName dynamic_property) (vla-get-value dynamic_property)))))
								)
							)
						)
					)
					(if (or
							(null temp_blocks_written_list)
							(not (member (cdr (assoc "Name" attribute_values_list)) temp_blocks_written_list))
						)
							(progn
								(setq temp_blocks_written_list (cons (cdr (assoc "Name" attribute_values_list)) temp_blocks_written_list))
								(setq temp_block_name (strcat Temp_File_Path (cdr (assoc "Name" attribute_values_list))))
								(command "_-WBLOCK" temp_block_name (cdr (assoc "Name" attribute_values_list)))
							)
					)
					(if (or
							(null renamed_blocks_written_list)
							(not (member (cdr (assoc "ИМЯ_001" attribute_values_list)) renamed_blocks_written_list))
						)
							(progn
								(vl-file-copy (strcat Temp_File_Path (cdr (assoc "Name" attribute_values_list)) ".dwg") (strcat Temp_File_Path (cdr (assoc "ИМЯ_001" attribute_values_list)) ".dwg"))
								(setq renamed_blocks_written_list (cons (cdr (assoc "ИМЯ_001" attribute_values_list)) renamed_blocks_written_list))
							)
					)
					(setq current_block_Reference_Object (vla-InsertBlock modelSpace_object (cdr (assoc "Insertion_Point" attribute_values_list)) (strcat Temp_File_Path (cdr (assoc "ИМЯ_001" attribute_values_list)) ".dwg") 1 1 1 0)
						  attributes_objects_list (vlax-safearray->list (vlax-variant-value (vla-getattributes current_block_Reference_Object)))
					)
					(foreach attribute_object attributes_objects_list
						(if (/= "ПОЛОЖЕНИЕ" (vla-get-tagstring attribute_object))
							(vla-put-textstring attribute_object (cdr (assoc (vla-get-tagstring attribute_object) attribute_values_list)))
						)
					)
					(setq dynamic_properties_list (vlax-safearray->list (vlax-variant-value (vla-getdynamicblockproperties current_block_Reference_Object))))
					(foreach dynamic_property dynamic_properties_list
						(if (/= "Origin" (vla-get-PropertyName dynamic_property))
							(vla-put-value dynamic_property (cdr (assoc (vla-get-PropertyName dynamic_property) attribute_values_list)))
						)
					)
					(vla-update current_block_Reference_Object)
					(vla-erase current_block_object)
					(setq blocks_processed (1+ blocks_processed))
				)
			)
		(setq blocks_pickset (ssdel (ssname blocks_pickset 0) blocks_pickset))
	)
	(mapcar '(lambda (file_name)
					(vl-file-delete (strcat Temp_File_Path file_name ".dwg"))
			)
			(append temp_blocks_written_list renamed_blocks_written_list)
	)
	(princ (strcat "\nНайдено блоков: " (itoa blocks_selected) ", переименовано блоков: " (itoa blocks_processed)))
	(setvar 'cmdecho 1)
	(princ)
)

[Сергей812]

Код:

[Выделить все]

 vl-file-delete (strcat Temp_File_Path file_name ".dwg")

как показывает опыт, если стоит антивирус - то удаление файла порою приходиться делать несколько раз, пока операция не окажется успешной. Или смириться с "мусором".

[koMon]

Сообщение от Сергей812 Или смириться с "мусором".

ну так TEMP и есть сборщик мусора) его нужно периодически прочищать, а то он может распухнуть так. что

[kirillwu]

Сообщение от koMon Собственно вариант без dbx. Выбираем все блоки, обрабатываем только с именем "Стойка". Пишем блок wblock-ом в TEMP, снимаем значения атрибутов, динамические свойства c оригинального блока, копируем блок в TEMP с именем равным значению атрибута "ИМЯ_001", вставялем его в обрабатываемый чертёж, восстанвливаем значения атрибутов, динамические свойства, удаляем оригинальный блок. Далее по циклу для всех выбранных блоков. удаляем файлы из TEMP. Без обвесов. Код: [Выделить все] (defun c:Block_to_NAME001 () (setq acad_Object (vlax-get-acad-object) acad_preferences (vla-get-Preferences acad_object) Temp_File_Path (vla-get-TempFilePath (vla-get-Files acad_preferences)) document_object (vla-get-Activedocument acad_Object) modelSpace_object (vla-get-modelSpace document_object) blocks_collection (vla-get-blocks document_object) blocks_pickset (ssget "_X" '((0 . "Insert"))) blocks_selected (sslength blocks_pickset) blocks_processed 0 temp_blocks_written_list '() renamed_blocks_written_list '() var_set (setvar 'cmdecho 0) ) (while (< 0 (sslength blocks_pickset)) (setq current_block_object (vlax-ename->vla-object (ssname blocks_pickset 0))) (if (member (strcase (vla-get-effectivename current_block_object)) (mapcar 'strcase '("Стойка"))) (progn (setq attribute_values_list '() attribute_values_list (append attribute_values_list (list (cons "Name" (vla-get-effectivename current_block_object)))) attribute_values_list (append attribute_values_list (list (cons "Insertion_Point" (vla-get-insertionpoint current_block_object)))) attributes_objects_list (vlax-safearray->list (vlax-variant-value (vla-getattributes current_block_object))) ) (foreach attribute_object attributes_objects_list (setq attribute_values_list (append attribute_values_list (list (cons (vla-get-tagstring attribute_object) (vla-get-textstring attribute_object))))) ) (if (= :vlax-true (vla-get-isdynamicblock current_block_object)) (progn (setq dynamic_properties_list (vlax-safearray->list (vlax-variant-value (vla-getdynamicblockproperties current_block_object)))) (foreach dynamic_property dynamic_properties_list (if (/= "Origin" (vla-get-PropertyName dynamic_property)) (setq attribute_values_list (append attribute_values_list (list (cons (vla-get-PropertyName dynamic_property) (vla-get-value dynamic_property))))) ) ) ) ) (if (or (null temp_blocks_written_list) (not (member (cdr (assoc "Name" attribute_values_list)) temp_blocks_written_list)) ) (progn (setq temp_blocks_written_list (cons (cdr (assoc "Name" attribute_values_list)) temp_blocks_written_list)) (setq temp_block_name (strcat Temp_File_Path (cdr (assoc "Name" attribute_values_list)))) (command "_-WBLOCK" temp_block_name (cdr (assoc "Name" attribute_values_list))) ) ) (if (or (null renamed_blocks_written_list) (not (member (cdr (assoc "ИМЯ_001" attribute_values_list)) renamed_blocks_written_list)) ) (progn (vl-file-copy (strcat Temp_File_Path (cdr (assoc "Name" attribute_values_list)) ".dwg") (strcat Temp_File_Path (cdr (assoc "ИМЯ_001" attribute_values_list)) ".dwg")) (setq renamed_blocks_written_list (cons (cdr (assoc "ИМЯ_001" attribute_values_list)) renamed_blocks_written_list)) ) ) (setq current_block_Reference_Object (vla-InsertBlock modelSpace_object (cdr (assoc "Insertion_Point" attribute_values_list)) (strcat Temp_File_Path (cdr (assoc "ИМЯ_001" attribute_values_list)) ".dwg") 1 1 1 0) attributes_objects_list (vlax-safearray->list (vlax-variant-value (vla-getattributes current_block_Reference_Object))) ) (foreach attribute_object attributes_objects_list (if (/= "ПОЛОЖЕНИЕ" (vla-get-tagstring attribute_object)) (vla-put-textstring attribute_object (cdr (assoc (vla-get-tagstring attribute_object) attribute_values_list))) ) ) (setq dynamic_properties_list (vlax-safearray->list (vlax-variant-value (vla-getdynamicblockproperties current_block_Reference_Object)))) (foreach dynamic_property dynamic_properties_list (if (/= "Origin" (vla-get-PropertyName dynamic_property)) (vla-put-value dynamic_property (cdr (assoc (vla-get-PropertyName dynamic_property) attribute_values_list))) ) ) (vla-update current_block_Reference_Object) (vla-erase current_block_object) (setq blocks_processed (1+ blocks_processed)) ) ) (setq blocks_pickset (ssdel (ssname blocks_pickset 0) blocks_pickset)) ) (mapcar '(lambda (file_name) (vl-file-delete (strcat Temp_File_Path file_name ".dwg")) ) (append temp_blocks_written_list renamed_blocks_written_list) ) (princ (strcat "\nНайдено блоков: " (itoa blocks_selected) ", переименовано блоков: " (itoa blocks_processed))) (setvar 'cmdecho 1) (princ) )

Спасибо, но у меня в файле есть не только блоки с именем "Стойка", есть блоки с именем "Ригель", "Кронштейн", "Заполнения"

[kirillwu]

Сообщение от VVA kirillwu, Тестируй

Приветствую. В этом файле не работает. Не понимаю почему именно с этими блоками команда не срабатывает.

[koMon]

Сообщение от kirillwu Спасибо, но у меня в файле есть не только блоки с именем "Стойка", есть блоки с именем "Ригель", "Кронштейн", "Заполнения"

В список добавляются имена требуемых блоков), скорректировал #22

Код:

[Выделить все]

 (if (member (strcase (vla-get-effectivename current_block_object)) (mapcar 'strcase '("Стойка" "Ригель" "Кронштейн" "Заполнения")))

----- добавлено через ~20 мин. -----
имя_001 содержит управляющие коды, нужно корректировать обработку этого атрибута, иначе обрушение автокада!

закостылил) если конечно оно надо

Код:

[Выделить все]

 
(defun c:Block_to_NAME001 ()
	(setq acad_Object (vlax-get-acad-object)
		  acad_preferences (vla-get-Preferences acad_object)
		  Temp_File_Path (vla-get-TempFilePath (vla-get-Files acad_preferences))
		  document_object (vla-get-Activedocument acad_Object)
		  modelSpace_object (vla-get-modelSpace document_object)
		  blocks_collection (vla-get-blocks document_object)
		  blocks_pickset (ssget "_X" '((0 . "Insert")))
		  blocks_selected (sslength blocks_pickset)
		  blocks_processed 0
		  temp_blocks_written_list '()
		  renamed_blocks_written_list '()
		  var_set (setvar 'cmdecho 0)
	)
	(while (< 0 (sslength blocks_pickset))
		(setq current_block_object (vlax-ename->vla-object (ssname blocks_pickset 0)))
			(if (member (strcase (vla-get-effectivename current_block_object)) (mapcar 'strcase '("Стойка" "Ригель" "Кронштейн" "Заполнения")))
				(progn
					(setq attribute_values_list '()
						  attribute_values_list (append attribute_values_list (list (cons "Name" (vla-get-effectivename current_block_object))))
						  attribute_values_list (append attribute_values_list (list (cons "Insertion_Point" (vla-get-insertionpoint current_block_object))))
						  attributes_objects_list (vlax-safearray->list (vlax-variant-value (vla-getattributes current_block_object)))
					)
					(foreach attribute_object attributes_objects_list
						(setq attribute_values_list (append attribute_values_list (list (cons (vla-get-tagstring attribute_object) (vla-get-textstring attribute_object)))))
					)
					(if (= :vlax-true (vla-get-isdynamicblock current_block_object))
						(progn
							(setq dynamic_properties_list (vlax-safearray->list (vlax-variant-value (vla-getdynamicblockproperties current_block_object))))
							(foreach dynamic_property dynamic_properties_list
								(if (/= "Origin" (vla-get-PropertyName dynamic_property))
							 		(setq attribute_values_list (append attribute_values_list (list (cons (vla-get-PropertyName dynamic_property) (vla-get-value dynamic_property)))))
								)
							)
						)
					)
					(if (or
							(null temp_blocks_written_list)
							(not (member (cdr (assoc "Name" attribute_values_list)) temp_blocks_written_list))
						)
							(progn
								(setq temp_blocks_written_list (cons (cdr (assoc "Name" attribute_values_list)) temp_blocks_written_list)
									  temp_block_name (strcat Temp_File_Path (cdr (assoc "Name" attribute_values_list)))
								)
								(command "_-WBLOCK" temp_block_name (cdr (assoc "Name" attribute_values_list)))
							)
					)
					(if (or
							(null renamed_blocks_written_list)
							(not (member (cdr (assoc "ИМЯ_001" attribute_values_list)) renamed_blocks_written_list))
						)
							(progn
								(vl-file-copy (strcat Temp_File_Path (cdr (assoc "Name" attribute_values_list)) ".dwg") (setq block_name_corrected (strcat Temp_File_Path
																																						   (if (member 59 (reverse (vl-string->list (cdr (assoc "ИМЯ_001" attribute_values_list)))))
																																								(substr (cdr (assoc "ИМЯ_001" attribute_values_list)) (- (length (vl-string->list (cdr (assoc "ИМЯ_001" attribute_values_list)))) (vl-position 59 (reverse (vl-string->list (cdr (assoc "ИМЯ_001" attribute_values_list))))) -1))
																																								(cdr (assoc "ИМЯ_001" attribute_values_list))
																																						   )
																																						   ".dwg"
																																					)
																														)
								)
								(setq renamed_blocks_written_list (cons block_name_corrected renamed_blocks_written_list))
							)
					)
					(setq current_block_Reference_Object (vla-InsertBlock modelSpace_object (cdr (assoc "Insertion_Point" attribute_values_list)) block_name_corrected 1 1 1 0)
						  attributes_objects_list (vlax-safearray->list (vlax-variant-value (vla-getattributes current_block_Reference_Object)))
					)
					(foreach attribute_object attributes_objects_list
						(if (/= "ПОЛОЖЕНИЕ" (vla-get-tagstring attribute_object))
							(vla-put-textstring attribute_object (cdr (assoc (vla-get-tagstring attribute_object) attribute_values_list)))
						)
					)
					(setq dynamic_properties_list (vlax-safearray->list (vlax-variant-value (vla-getdynamicblockproperties current_block_Reference_Object))))
					(foreach dynamic_property dynamic_properties_list
						(if (/= "Origin" (vla-get-PropertyName dynamic_property))
							(vla-put-value dynamic_property (cdr (assoc (vla-get-PropertyName dynamic_property) attribute_values_list)))
						)
					)
					(vla-update current_block_Reference_Object)
					(vla-erase current_block_object)
					(setq blocks_processed (1+ blocks_processed))
				)
			)
		(setq blocks_pickset (ssdel (ssname blocks_pickset 0) blocks_pickset))
	)
	(mapcar '(lambda (file_name)
					(vl-file-delete (strcat Temp_File_Path file_name ".dwg"))
			)
			(append temp_blocks_written_list renamed_blocks_written_list)
	)
	(princ (strcat "\nНайдено блоков: " (itoa blocks_selected) ", переименовано блоков: " (itoa blocks_processed)))
	(setvar 'cmdecho 1)
	(princ)
)

----- добавлено через ~11 мин. -----
с name_001 проблема восстановления(

----- добавлено через ~17 мин. -----
хотя видимости отслеживает…

[Сергей812]

Сообщение от koMon В список добавляются имена требуемых блоков), скорректировал #22

а как же просканировать чертеж и найдя все определения блоков с тэгом "ИМЯ_001" - а потом вывести в чеклист для выбора пользователем?)

[kirillwu]

Сообщение от koMon В список добавляются имена требуемых блоков), скорректировал #22 Код: [Выделить все] (if (member (strcase (vla-get-effectivename current_block_object)) (mapcar 'strcase '("Стойка" "Ригель" "Кронштейн" "Заполнения"))) ----- добавлено через ~20 мин. ----- имя_001 содержит управляющие коды, нужно корректировать обработку этого атрибута, иначе обрушение автокада! закостылил) если конечно оно надо Код: [Выделить все] (defun c:Block_to_NAME001 () (setq acad_Object (vlax-get-acad-object) acad_preferences (vla-get-Preferences acad_object) Temp_File_Path (vla-get-TempFilePath (vla-get-Files acad_preferences)) document_object (vla-get-Activedocument acad_Object) modelSpace_object (vla-get-modelSpace document_object) blocks_collection (vla-get-blocks document_object) blocks_pickset (ssget "_X" '((0 . "Insert"))) blocks_selected (sslength blocks_pickset) blocks_processed 0 temp_blocks_written_list '() renamed_blocks_written_list '() var_set (setvar 'cmdecho 0) ) (while (< 0 (sslength blocks_pickset)) (setq current_block_object (vlax-ename->vla-object (ssname blocks_pickset 0))) (if (member (strcase (vla-get-effectivename current_block_object)) (mapcar 'strcase '("Стойка" "Ригель" "Кронштейн" "Заполнения"))) (progn (setq attribute_values_list '() attribute_values_list (append attribute_values_list (list (cons "Name" (vla-get-effectivename current_block_object)))) attribute_values_list (append attribute_values_list (list (cons "Insertion_Point" (vla-get-insertionpoint current_block_object)))) attributes_objects_list (vlax-safearray->list (vlax-variant-value (vla-getattributes current_block_object))) ) (foreach attribute_object attributes_objects_list (setq attribute_values_list (append attribute_values_list (list (cons (vla-get-tagstring attribute_object) (vla-get-textstring attribute_object))))) ) (if (= :vlax-true (vla-get-isdynamicblock current_block_object)) (progn (setq dynamic_properties_list (vlax-safearray->list (vlax-variant-value (vla-getdynamicblockproperties current_block_object)))) (foreach dynamic_property dynamic_properties_list (if (/= "Origin" (vla-get-PropertyName dynamic_property)) (setq attribute_values_list (append attribute_values_list (list (cons (vla-get-PropertyName dynamic_property) (vla-get-value dynamic_property))))) ) ) ) ) (if (or (null temp_blocks_written_list) (not (member (cdr (assoc "Name" attribute_values_list)) temp_blocks_written_list)) ) (progn (setq temp_blocks_written_list (cons (cdr (assoc "Name" attribute_values_list)) temp_blocks_written_list) temp_block_name (strcat Temp_File_Path (cdr (assoc "Name" attribute_values_list))) ) (command "_-WBLOCK" temp_block_name (cdr (assoc "Name" attribute_values_list))) ) ) (if (or (null renamed_blocks_written_list) (not (member (cdr (assoc "ИМЯ_001" attribute_values_list)) renamed_blocks_written_list)) ) (progn (vl-file-copy (strcat Temp_File_Path (cdr (assoc "Name" attribute_values_list)) ".dwg") (setq block_name_corrected (strcat Temp_File_Path (if (member 59 (reverse (vl-string->list (cdr (assoc "ИМЯ_001" attribute_values_list))))) (substr (cdr (assoc "ИМЯ_001" attribute_values_list)) (- (length (vl-string->list (cdr (assoc "ИМЯ_001" attribute_values_list)))) (vl-position 59 (reverse (vl-string->list (cdr (assoc "ИМЯ_001" attribute_values_list))))) -1)) (cdr (assoc "ИМЯ_001" attribute_values_list)) ) ".dwg" ) ) ) (setq renamed_blocks_written_list (cons block_name_corrected renamed_blocks_written_list)) ) ) (setq current_block_Reference_Object (vla-InsertBlock modelSpace_object (cdr (assoc "Insertion_Point" attribute_values_list)) block_name_corrected 1 1 1 0) attributes_objects_list (vlax-safearray->list (vlax-variant-value (vla-getattributes current_block_Reference_Object))) ) (foreach attribute_object attributes_objects_list (if (/= "ПОЛОЖЕНИЕ" (vla-get-tagstring attribute_object)) (vla-put-textstring attribute_object (cdr (assoc (vla-get-tagstring attribute_object) attribute_values_list))) ) ) (setq dynamic_properties_list (vlax-safearray->list (vlax-variant-value (vla-getdynamicblockproperties current_block_Reference_Object)))) (foreach dynamic_property dynamic_properties_list (if (/= "Origin" (vla-get-PropertyName dynamic_property)) (vla-put-value dynamic_property (cdr (assoc (vla-get-PropertyName dynamic_property) attribute_values_list))) ) ) (vla-update current_block_Reference_Object) (vla-erase current_block_object) (setq blocks_processed (1+ blocks_processed)) ) ) (setq blocks_pickset (ssdel (ssname blocks_pickset 0) blocks_pickset)) ) (mapcar '(lambda (file_name) (vl-file-delete (strcat Temp_File_Path file_name ".dwg")) ) (append temp_blocks_written_list renamed_blocks_written_list) ) (princ (strcat "\nНайдено блоков: " (itoa blocks_selected) ", переименовано блоков: " (itoa blocks_processed))) (setvar 'cmdecho 1) (princ) ) ----- добавлено через ~11 мин. ----- с name_001 проблема восстановления( ----- добавлено через ~17 мин. ----- хотя видимости отслеживает…

А еще попробуйте в блоках в файле, который содержится в посте #26 - и выскочит ошибка

[Сергей812]

В лиспе есть подобная функция?

[koMon]

Сообщение от Сергей812 В лиспе есть подобная функция?

я не знаю о такой функции, но её написать вообще не проблема, вопрос - что делать, когда имя будет содержать спецсимволы?

Сообщение от kirillwu А еще попробуйте в блоках в файле, который содержится в посте #26 - и выскочит ошибка

да нет ошибка не выскакивает, файл отрабатывается весь, но акад ругается на наличие дублируемых блоков, которые вложены в блок кронштейн и тупо их игнорит.

[Сергей812]

Сообщение от koMon я не знаю о такой функции

snvalid ?

Сообщение от koMon вопрос - что делать, когда имя будет содержать спецсимволы?

Форматирование удалить, а потом вступать в диалог с пользователем скорее всего в случае невалидности имени.

[koMon]

Сообщение от Сергей812 snvalid ?

а что так скромно)?
так-то поинтересней будет snvalid
день прожит не зря!)))

Сообщение от Сергей812 а потом вступать в диалог с пользователем

ну здесь-то это излишнее) задача тупо переименовать, для удобовыбираемости вышестоящим специалистом), а принципиально - да.
вот я даже не ставил проверку на уже наличие в базе вставляемого блока из-за чего выскакивают highly likely сообщения о наличии описания блока.

[Сергей812]

Если просто стоит задача выделить блоки с одинаковым значением атрибута - то можно с другой стороны: просто перехватывать команду "выбрать подобные" в обработчике событий и если выделен блок с тэгом "ИМЯ_001" - найти и выделить все другие с тем же значением атрибута. А если нет - пропускать исходную команду дальше. Но это тоже надо "ломать" традиции - ставить всем программу в автозагрузку.

Сообщение от koMon ну здесь-то это излишнее) задача тупо переименовать

Ну-ну. Во вставках двух разных блоков будет одинаковое значение указанного атрибута (просто человеческий фактор) - как создать два определения блока с одним и там же именем?

[koMon]

Сообщение от Сергей812 как создать два определения блока с одним и там же именем

никак), останется только один.
отлавливать человеческий фактор

[VVA]

Сообщение от Сергей812 Если просто стоит задача выделить блоки с одинаковым значением атрибута

Выбор вхождений блока по фильтру на свойства и значения атрибутов
Выбор блоков по значению атрибутов
Выбор блоков по значениям динамических параметров

[koMon]

Сообщение от koMon но акад ругается на наличие дублируемых блоков

добавил проверку на наличие в базе уже определённого блока, но вложенных блоков тьма, поэтому акад при кажом вставлении такого блока всё равно мило ругается)

Код:

[Выделить все]

 
;**************************************************************************************************************************************

(defun correct_attribute (in_attribute)

   (if (member 59 (reverse (vl-string->list in_attribute)))
			(substr in_attribute (- (length (vl-string->list in_attribute)) (vl-position 59 (reverse (vl-string->list in_attribute))) -1))
			in_attribute
   )
)

;**************************************************************************************************************************************

(defun c:Block_to_NAME001 ()
	(setq acad_Object (vlax-get-acad-object)
		  acad_preferences (vla-get-Preferences acad_object)
		  Temp_File_Path (vla-get-TempFilePath (vla-get-Files acad_preferences))
		  document_object (vla-get-Activedocument acad_Object)
		  dwg_blocks_collection (vla-get-blocks document_object)
		  modelSpace_object (vla-get-modelSpace document_object)
		  blocks_collection (vla-get-blocks document_object)
		  blocks_pickset (ssget "_X" '((0 . "Insert")))
		  blocks_selected (sslength blocks_pickset)
		  blocks_processed 0
		  temp_blocks_written_list '()
		  renamed_blocks_written_list '()
		  var_set (setvar 'cmdecho 0)
	)
	(while (< 0 (sslength blocks_pickset))
		(setq current_block_object (vlax-ename->vla-object (ssname blocks_pickset 0)))
			(if (member (strcase (vla-get-effectivename current_block_object)) (mapcar 'strcase '("Стойка" "Ригель" "Кронштейн" "Заполнения")))
				(progn
					(setq attribute_values_list '()
						  attribute_values_list (append attribute_values_list (list (cons "Name" (vla-get-effectivename current_block_object))))
						  attribute_values_list (append attribute_values_list (list (cons "Insertion_Point" (vla-get-insertionpoint current_block_object))))
						  attributes_objects_list (vlax-safearray->list (vlax-variant-value (vla-getattributes current_block_object)))
					)
					(foreach attribute_object attributes_objects_list
						(setq attribute_values_list (append attribute_values_list (list (cons (vla-get-tagstring attribute_object) (vla-get-textstring attribute_object)))))
					)
					(if (= :vlax-true (vla-get-isdynamicblock current_block_object))
						(progn
							(setq dynamic_properties_list (vlax-safearray->list (vlax-variant-value (vla-getdynamicblockproperties current_block_object))))
							(foreach dynamic_property dynamic_properties_list
								(if (/= "Origin" (vla-get-PropertyName dynamic_property))
							 		(setq attribute_values_list (append attribute_values_list (list (cons (vla-get-PropertyName dynamic_property) (vla-get-value dynamic_property)))))
								)
							)
						)
					)
					(if (or
							(null temp_blocks_written_list)
							(not (member (correct_attribute (cdr (assoc "Name" attribute_values_list))) temp_blocks_written_list))
						)
							(progn
								(setq temp_blocks_written_list (cons (correct_attribute (cdr (assoc "Name" attribute_values_list))) temp_blocks_written_list)
									  temp_block_name (strcat Temp_File_Path (correct_attribute (cdr (assoc "Name" attribute_values_list))))
								)
								(command "_-WBLOCK" temp_block_name (cdr (assoc "Name" attribute_values_list)))
							)
					)
					(if (or
							(null renamed_blocks_written_list)
							(not (member (correct_attribute (cdr (assoc "ИМЯ_001" attribute_values_list))) renamed_blocks_written_list))
						)
							(progn
								(vl-file-copy (strcat Temp_File_Path (cdr (assoc "Name" attribute_values_list)) ".dwg") (strcat Temp_File_Path (correct_attribute (cdr (assoc "ИМЯ_001" attribute_values_list))) ".dwg"))
								(setq renamed_blocks_written_list (cons (correct_attribute (cdr (assoc "ИМЯ_001" attribute_values_list))) renamed_blocks_written_list))
							)
					)
					(setq current_block_Reference_Object
															(if (/= 'VL-CATCH-ALL-APPLY-ERROR (type (vl-catch-all-apply 'vla-item (list dwg_blocks_collection (correct_attribute (cdr (assoc "ИМЯ_001" attribute_values_list)))))))
																(vla-InsertBlock modelSpace_object (cdr (assoc "Insertion_Point" attribute_values_list)) (correct_attribute (cdr (assoc "ИМЯ_001" attribute_values_list))) 1 1 1 0)
																(vla-InsertBlock modelSpace_object (cdr (assoc "Insertion_Point" attribute_values_list)) (strcat Temp_File_Path (correct_attribute (cdr (assoc "ИМЯ_001" attribute_values_list))) ".dwg") 1 1 1 0)
															)
						  attributes_objects_list (vlax-safearray->list (vlax-variant-value (vla-getattributes current_block_Reference_Object)))
					)
					(foreach attribute_object attributes_objects_list
						(if (/= "ПОЛОЖЕНИЕ" (vla-get-tagstring attribute_object))
							(vla-put-textstring attribute_object (cdr (assoc (vla-get-tagstring attribute_object) attribute_values_list)))
						)
					)
					(setq dynamic_properties_list (vlax-safearray->list (vlax-variant-value (vla-getdynamicblockproperties current_block_Reference_Object))))
					(foreach dynamic_property dynamic_properties_list
						(if (/= "Origin" (vla-get-PropertyName dynamic_property))
							(vla-put-value dynamic_property (cdr (assoc (vla-get-PropertyName dynamic_property) attribute_values_list)))
						)
					)
					(vla-update current_block_Reference_Object)
					(vla-erase current_block_object)
					(setq blocks_processed (1+ blocks_processed))
				)
			)
		(setq blocks_pickset (ssdel (ssname blocks_pickset 0) blocks_pickset))
	)
	(mapcar '(lambda (file_name)
					(vl-file-delete (strcat Temp_File_Path file_name ".dwg"))
			)
			(append temp_blocks_written_list renamed_blocks_written_list)
	)
	(princ (strcat "\nНайдено блоков: " (itoa blocks_selected) ", переименовано блоков: " (itoa blocks_processed)))
	(setvar 'cmdecho 1)
	(princ)
)

----- добавлено через ~5 мин. -----
kirillwu, давайте уже попробуем "Ригель", "Заполнения" и что там ещё у вас есть!-)

[Сергей812]

Сообщение от koMon никак), останется только один. отлавливать человеческий фактор

т.е. вступать в диалог с пользователем, а не поганить чертеж по тихому)

----- добавлено через ~6 мин. -----
по нормальному надо сначала проанализировать чертеж, найти все конфликты (по именам, по одинаковым значениям атрибутов в блоках с разными "родителями", блоки на заблокированных слоях и т.д.), запросить реакцию пользователя (причем желательно, в удобоваримом варианте типа выбора очередного конфликта на палитре с автопозиционированием чертежа на "проблемном" блоке) и лишь при отсутствии неразрешимых конфликтов запустить саму обработку чертежа.

[koMon]

Сообщение от Сергей812 поганить

как это совсем не GOOD!^)

Сообщение от Сергей812 по нормальному надо сначала … и лишь при отсутствии неразрешимых конфликтов запустить саму обработку чертежа

если у ТС использованных блоков по пальцам двух рук пересчитать, то "неразрешимиые конфликты" можно отследить уже до запуска обработки, да и собственно принять оперативные меры для устранения этой самой неразрешимости. и потом разве несколько предсказуемых действий обработки могут безвозвратно ис******** чертёж?^)
но вот ежели их у него сотни, тогда ДА, тогда КОНЕЧНО!

мне почему-то кажется, что пора мне говорить "пас")))

[Сергей812]

Offtop:

Сообщение от koMon мне почему-то кажется, что пора мне говорить "пас")))

чем смогли - тем и помогли..) проще главного конструктора научиться пользоваться извлечением данных тем же, имхо.. или уже в раздел исполнителей для полноценной программы с развитыми диалогами

[koMon]

Сергей812,

Сообщение от koMon мне почему-то кажется, что пора мне говорить "пас")))

А нет, показалось)))
Я тут посмотрел, kirillwu, ещё один тест давал в #20, ну и ещё малёк подшаманил. только вот маску на мтекст, по ходу ручками нужно делать.
надо бы функцию на снятие форматируюших кодов написать по-правильнее. а так в целом заменяет блоки вполне себе прилично, не по тихому поганя цельный чертёх)))

сборный результат теста (DXF->RAR) выкладываю.

Код:

[Выделить все]

 
;**************************************************************************************************************************************

(defun correct_attribute (in_attribute)

   (if (= 125 (car (reverse (vl-string->list in_attribute)))) (setq in_attribute (vl-list->string (reverse (cdr (reverse (vl-string->list in_attribute)))))))

   (if (member 59 (reverse (vl-string->list in_attribute)))
           (substr in_attribute (- (length (vl-string->list in_attribute)) (vl-position 59 (reverse (vl-string->list in_attribute))) -1))
           in_attribute
   )
)

;**************************************************************************************************************************************

(defun c:Block_to_NAME001 ()
	(setq acad_Object (vlax-get-acad-object)
		  acad_preferences (vla-get-Preferences acad_object)
		  Temp_File_Path (vla-get-TempFilePath (vla-get-Files acad_preferences))
		  document_object (vla-get-Activedocument acad_Object)
		  dwg_blocks_collection (vla-get-blocks document_object)
		  modelSpace_object (vla-get-modelSpace document_object)
		  blocks_collection (vla-get-blocks document_object)
		  blocks_pickset (ssget "_X" '((0 . "Insert")))
		  blocks_selected (sslength blocks_pickset)
		  blocks_processed 0
		  temp_blocks_written_list '()
		  renamed_blocks_written_list '()
		  var_set (setvar 'cmdecho 0)
	)
	(while (< 0 (sslength blocks_pickset))
		(setq current_block_object (vlax-ename->vla-object (ssname blocks_pickset 0)))
			(if (member (strcase (vla-get-effectivename current_block_object)) (mapcar 'strcase '("Стойка" "Ригель" "Кронштейн" "Заполнения" "Заполнение в балконку")))
				(progn
					(setq block_values_list '()
						  block_values_list (append block_values_list (list (cons "Layer" (vla-get-layer current_block_object))))
						  block_values_list (append block_values_list (list (cons "Name" (vla-get-effectivename current_block_object))))
						  block_values_list (append block_values_list (list (cons "Insertion_Point" (vla-get-insertionpoint current_block_object))))
						  attributes_objects_list (vlax-safearray->list (vlax-variant-value (vla-getattributes current_block_object)))
					)
					(foreach attribute_object attributes_objects_list
						(setq block_values_list (append block_values_list (list (cons (vla-get-tagstring attribute_object) (vla-get-textstring attribute_object))))
						  	  block_values_list (append block_values_list (list (cons "Attribute_Insertion_Point" (vla-get-insertionpoint attribute_object))))
						  	  block_values_list (append block_values_list (list (cons "Scale_Factor" (vla-get-scalefactor attribute_object))))
						  	  block_values_list (append block_values_list (list (cons "TextAlignmentPoint" (vla-get-TextAlignmentPoint attribute_object))))
						  	  block_values_list (append block_values_list (list (cons "Alignment" (vla-get-Alignment attribute_object))))
						)

						(if (= :vlax-true (vla-get-MTextAttribute attribute_object))
							(setq block_values_list (append block_values_list (list (cons "MTextAttribute" t)))
								  block_values_list (append block_values_list (list (cons "MTextAttributeContent" (vla-get-MTextAttributeContent attribute_object))))
							)
						)
					)
					(if (= :vlax-true (vla-get-isdynamicblock current_block_object))
						(progn
							(setq dynamic_properties_list (vlax-safearray->list (vlax-variant-value (vla-getdynamicblockproperties current_block_object))))
							(foreach dynamic_property dynamic_properties_list
								(if (/= "Origin" (vla-get-PropertyName dynamic_property))
							 		(setq block_values_list (append block_values_list (list (cons (vla-get-PropertyName dynamic_property) (vla-get-value dynamic_property)))))
								)
							)
						)
					)
					(if (or
							(null temp_blocks_written_list)
							(not (member (correct_attribute (cdr (assoc "Name" block_values_list))) temp_blocks_written_list))
						)
							(progn
								(setq temp_blocks_written_list (cons (correct_attribute (cdr (assoc "Name" block_values_list))) temp_blocks_written_list)
									  temp_block_name (strcat Temp_File_Path (correct_attribute (cdr (assoc "Name" block_values_list))))
								)
								(if (findfile (strcat temp_block_name ".dwg")) (vl-file-delete (strcat temp_block_name ".dwg")))
								(command "_-WBLOCK" temp_block_name (cdr (assoc "Name" block_values_list)))
							)
					)

					(if (or
							(null renamed_blocks_written_list)
							(not (member (correct_attribute (cdr (assoc "ИМЯ_001" block_values_list))) renamed_blocks_written_list))
						)
							(progn
								(if (findfile (strcat Temp_File_Path (correct_attribute (cdr (assoc "ИМЯ_001" block_values_list))) ".dwg")) (vl-file-delete (strcat Temp_File_Path (correct_attribute (cdr (assoc "ИМЯ_001" block_values_list))) ".dwg")))
								(vl-file-copy (strcat Temp_File_Path (cdr (assoc "Name" block_values_list)) ".dwg") (strcat Temp_File_Path (correct_attribute (cdr (assoc "ИМЯ_001" block_values_list))) ".dwg"))
								(setq renamed_blocks_written_list (cons (correct_attribute (cdr (assoc "ИМЯ_001" block_values_list))) renamed_blocks_written_list))
							)
					)
					(setq current_block_Reference_Object
															(if (/= 'VL-CATCH-ALL-APPLY-ERROR (type (vl-catch-all-apply 'vla-item (list dwg_blocks_collection (correct_attribute (cdr (assoc "ИМЯ_001" block_values_list)))))))
																(vla-InsertBlock modelSpace_object (cdr (assoc "Insertion_Point" block_values_list)) (correct_attribute (cdr (assoc "ИМЯ_001" block_values_list))) 1 1 1 0)
																(vla-InsertBlock modelSpace_object (cdr (assoc "Insertion_Point" block_values_list)) (strcat Temp_File_Path (correct_attribute (cdr (assoc "ИМЯ_001" block_values_list))) ".dwg") 1 1 1 0)
															)
						  attributes_objects_list (vlax-safearray->list (vlax-variant-value (vla-getattributes current_block_Reference_Object)))
					)
					(vla-put-layer current_block_Reference_Object (cdr (assoc "Layer" block_values_list)))

					(setq dynamic_properties_list (vlax-safearray->list (vlax-variant-value (vla-getdynamicblockproperties current_block_Reference_Object))))
					(foreach dynamic_property dynamic_properties_list
						(if (/= "Origin" (vla-get-PropertyName dynamic_property))
							(vla-put-value dynamic_property (cdr (assoc (vla-get-PropertyName dynamic_property) block_values_list)))
						)
					)

					(foreach attribute_object attributes_objects_list
						(if (assoc "MTextAttribute" block_values_list)
							(progn
								(vla-put-MTextAttribute attribute_object :vlax-true)
								(vla-put-MTextAttributeContent attribute_object (cdr (assoc "MTextAttributeContent" block_values_list)))
							)
						)
						(if (/= "ПОЛОЖЕНИЕ" (vla-get-tagstring attribute_object))
							(progn
								(vla-put-TextAlignmentPoint attribute_object (cdr (assoc "TextAlignmentPoint" block_values_list)))
								(vla-put-insertionpoint attribute_object (cdr (assoc "Attribute_Insertion_Point" block_values_list)))
								(vla-put-ScaleFactor attribute_object (cdr (assoc "Scale_Factor" block_values_list)))
								(vla-put-textstring attribute_object (cdr (assoc (vla-get-tagstring attribute_object) block_values_list)))
								(vla-put-Alignment attribute_object (cdr (assoc "Alignment" block_values_list)))
							)
						)
					)

					(vla-update current_block_Reference_Object)
					(vla-erase current_block_object)
					(setq blocks_processed (1+ blocks_processed))
				)
			)
		(setq blocks_pickset (ssdel (ssname blocks_pickset 0) blocks_pickset))
	)
	(mapcar '(lambda (file_name)
					(vl-file-delete (strcat Temp_File_Path file_name ".dwg"))
			)
			(append temp_blocks_written_list renamed_blocks_written_list)
	)
	(princ (strcat "\nНайдено блоков: " (itoa blocks_selected) ", переименовано блоков: " (itoa blocks_processed)))
	(setvar 'cmdecho 1)
	(princ)
)

[Сергей812]

Сообщение от koMon функцию на снятие форматируюших кодов написать по-правильнее

Вот это не подойдет? В .Net это встроенное уже.

[Монтажник 80lv )))]

Здесь программисты или проектировщики

[koMon]

Сообщение от Сергей812 Вот это не подойдет?

----- добавлено через ~2 ч. -----

Сообщение от koMon только вот маску на мтекст, по ходу ручками нужно делать.

теперь не нужно

Код:

[Выделить все]

 
;**************************************************************************************************************************************

(defun correct_attribute (in_attribute)

   (if (= 125 (car (reverse (vl-string->list in_attribute)))) (setq in_attribute (vl-list->string (reverse (cdr (reverse (vl-string->list in_attribute)))))))

   (if (member 59 (reverse (vl-string->list in_attribute)))
           (substr in_attribute (- (length (vl-string->list in_attribute)) (vl-position 59 (reverse (vl-string->list in_attribute))) -1))
           in_attribute
   )
)

;**************************************************************************************************************************************

(defun c:Block_to_NAME001 ()
	(setq acad_Object (vlax-get-acad-object)
		  acad_preferences (vla-get-Preferences acad_object)
		  Temp_File_Path (vla-get-TempFilePath (vla-get-Files acad_preferences))
		  document_object (vla-get-Activedocument acad_Object)
		  dwg_blocks_collection (vla-get-blocks document_object)
		  modelSpace_object (vla-get-modelSpace document_object)
		  blocks_collection (vla-get-blocks document_object)
		  blocks_pickset (ssget "_X" '((0 . "Insert")))
		  blocks_selected (sslength blocks_pickset)
		  blocks_processed 0
		  temp_blocks_written_list '()
		  renamed_blocks_written_list '()
		  var_set (setvar 'cmdecho 0)
	)
	(while (< 0 (sslength blocks_pickset))
		(setq current_block_object (vlax-ename->vla-object (ssname blocks_pickset 0)))
			(if (member (strcase (vla-get-effectivename current_block_object)) (mapcar 'strcase '("Стойка" "Ригель" "Кронштейн" "Заполнения" "Заполнение в балконку")))
				(progn
					(setq block_values_list '()
						  block_values_list (append block_values_list (list (cons "Layer" (vla-get-layer current_block_object))))
						  block_values_list (append block_values_list (list (cons "Name" (vla-get-effectivename current_block_object))))
						  block_values_list (append block_values_list (list (cons "Insertion_Point" (vla-get-insertionpoint current_block_object))))
						  attributes_objects_list (vlax-safearray->list (vlax-variant-value (vla-getattributes current_block_object)))
					)
					(foreach attribute_object attributes_objects_list
						(setq block_values_list (append block_values_list (list (cons (vla-get-tagstring attribute_object) (vla-get-textstring attribute_object))))
						  	  block_values_list (append block_values_list (list (cons "Attribute_Insertion_Point" (vla-get-insertionpoint attribute_object))))
						  	  block_values_list (append block_values_list (list (cons "Scale_Factor" (vla-get-scalefactor attribute_object))))
						  	  block_values_list (append block_values_list (list (cons "TextAlignmentPoint" (vla-get-TextAlignmentPoint attribute_object))))
						  	  block_values_list (append block_values_list (list (cons "Alignment" (vla-get-Alignment attribute_object))))
						)
						(if (assoc 90 (entget (vlax-vla-object->ename attribute_object))) (setq block_values_list (append block_values_list (list (assoc 90 (entget (vlax-vla-object->ename attribute_object)))))))
						(if (assoc 63 (entget (vlax-vla-object->ename attribute_object))) (setq block_values_list (append block_values_list (list (assoc 63 (entget (vlax-vla-object->ename attribute_object)))))))
						(if (assoc 421 (entget (vlax-vla-object->ename attribute_object))) (setq block_values_list (append block_values_list (list (assoc 421 (entget (vlax-vla-object->ename attribute_object)))))))
						(if (assoc 45 (entget (vlax-vla-object->ename attribute_object))) (setq block_values_list (append block_values_list (list (assoc 45 (entget (vlax-vla-object->ename attribute_object)))))))

						(if (= :vlax-true (vla-get-MTextAttribute attribute_object))
							(setq block_values_list (append block_values_list (list (cons "MTextAttribute" t)))
								  block_values_list (append block_values_list (list (cons "MTextAttributeContent" (vla-get-MTextAttributeContent attribute_object))))
							)
						)
					)
					(if (= :vlax-true (vla-get-isdynamicblock current_block_object))
						(progn
							(setq dynamic_properties_list (vlax-safearray->list (vlax-variant-value (vla-getdynamicblockproperties current_block_object))))
							(foreach dynamic_property dynamic_properties_list
								(if (/= "Origin" (vla-get-PropertyName dynamic_property))
							 		(setq block_values_list (append block_values_list (list (cons (vla-get-PropertyName dynamic_property) (vla-get-value dynamic_property)))))
								)
							)
						)
					)
					(if (or
							(null temp_blocks_written_list)
							(not (member (correct_attribute (cdr (assoc "Name" block_values_list))) temp_blocks_written_list))
						)
							(progn
								(setq temp_blocks_written_list (cons (correct_attribute (cdr (assoc "Name" block_values_list))) temp_blocks_written_list)
									  temp_block_name (strcat Temp_File_Path (correct_attribute (cdr (assoc "Name" block_values_list))))
								)
								(if (findfile (strcat temp_block_name ".dwg")) (vl-file-delete (strcat temp_block_name ".dwg")))
								(command "_-WBLOCK" temp_block_name (cdr (assoc "Name" block_values_list)))
							)
					)
					(if (or
							(null renamed_blocks_written_list)
							(not (member (correct_attribute (cdr (assoc "ИМЯ_001" block_values_list))) renamed_blocks_written_list))
						)
							(progn
								(if (findfile (strcat Temp_File_Path (correct_attribute (cdr (assoc "ИМЯ_001" block_values_list))) ".dwg")) (vl-file-delete (strcat Temp_File_Path (correct_attribute (cdr (assoc "ИМЯ_001" block_values_list))) ".dwg")))
								(vl-file-copy (strcat Temp_File_Path (cdr (assoc "Name" block_values_list)) ".dwg") (strcat Temp_File_Path (correct_attribute (cdr (assoc "ИМЯ_001" block_values_list))) ".dwg"))
								(setq renamed_blocks_written_list (cons (correct_attribute (cdr (assoc "ИМЯ_001" block_values_list))) renamed_blocks_written_list))
							)
					)
					(setq current_block_Reference_Object
															(if (/= 'VL-CATCH-ALL-APPLY-ERROR (type (vl-catch-all-apply 'vla-item (list dwg_blocks_collection (correct_attribute (cdr (assoc "ИМЯ_001" block_values_list)))))))
																(vla-InsertBlock modelSpace_object (cdr (assoc "Insertion_Point" block_values_list)) (correct_attribute (cdr (assoc "ИМЯ_001" block_values_list))) 1 1 1 0)
																(vla-InsertBlock modelSpace_object (cdr (assoc "Insertion_Point" block_values_list)) (strcat Temp_File_Path (correct_attribute (cdr (assoc "ИМЯ_001" block_values_list))) ".dwg") 1 1 1 0)
															)
						  attributes_objects_list (vlax-safearray->list (vlax-variant-value (vla-getattributes current_block_Reference_Object)))
					)
					(vla-put-layer current_block_Reference_Object (cdr (assoc "Layer" block_values_list)))

					(setq dynamic_properties_list (vlax-safearray->list (vlax-variant-value (vla-getdynamicblockproperties current_block_Reference_Object))))
					(foreach dynamic_property dynamic_properties_list
						(if (/= "Origin" (vla-get-PropertyName dynamic_property))
							(vla-put-value dynamic_property (cdr (assoc (vla-get-PropertyName dynamic_property) block_values_list)))
						)
					)
					(foreach attribute_object attributes_objects_list
						(if (assoc "MTextAttribute" block_values_list)
							(progn
								(vla-put-MTextAttribute attribute_object :vlax-true)
								(vla-put-MTextAttributeContent attribute_object (cdr (assoc "MTextAttributeContent" block_values_list)))
							)
						)
						(if (/= "ПОЛОЖЕНИЕ" (vla-get-tagstring attribute_object))
							(progn
								(vla-put-TextAlignmentPoint attribute_object (cdr (assoc "TextAlignmentPoint" block_values_list)))
								(vla-put-insertionpoint attribute_object (cdr (assoc "Attribute_Insertion_Point" block_values_list)))
								(vla-put-ScaleFactor attribute_object (cdr (assoc "Scale_Factor" block_values_list)))
								(vla-put-Alignment attribute_object (cdr (assoc "Alignment" block_values_list)))
								(vla-put-textstring attribute_object (cdr (assoc (vla-get-tagstring attribute_object) block_values_list)))

								(setq attribute_entity (entget (vlax-vla-object->ename attribute_object)))

								(if (assoc 90 block_values_list)
									(if (null (assoc 90 attribute_entity))
										(progn
											(setq attribute_entity (append attribute_entity (list (assoc 90 block_values_list))))
											(entmod attribute_entity)
										)
									)
								)
								(if (assoc 63 block_values_list)
									(if (null (assoc 63 attribute_entity))
										(progn
											(setq attribute_entity (append attribute_entity (list (assoc 63 block_values_list))))
											(entmod attribute_entity)
										)
									)
								)
								(if (assoc 421 block_values_list)
									(if (null (assoc 421 attribute_entity))
										(progn
											(setq attribute_entity (append attribute_entity (list (assoc 421 block_values_list))))
											(entmod attribute_entity)
										)
									)
								)
								(if (assoc 45 block_values_list)
									(if (null (assoc 45 attribute_entity))
										(progn
											(setq attribute_entity (append attribute_entity (list (assoc 45 block_values_list))))
											(entmod attribute_entity)
										)
									)
								)
							)
						)
					)
					(vla-update current_block_Reference_Object)
					(vla-erase current_block_object)
					(setq blocks_processed (1+ blocks_processed))
				)
			)
		(setq blocks_pickset (ssdel (ssname blocks_pickset 0) blocks_pickset))
	)
	(mapcar '(lambda (file_name)
					(vl-file-delete (strcat Temp_File_Path file_name ".dwg"))
			)
			(append temp_blocks_written_list renamed_blocks_written_list)
	)
	(alert (strcat "\nНайдено блоков: " (itoa blocks_selected) ", переименовано блоков: " (itoa blocks_processed)))
	(setvar 'cmdecho 1)
	(princ)
)