LISP. Помогите с лиспом по переименованию нескольких вхождений динамического блока в значение его атрибута.

kirillwu · 04.06.2018, 09:14

В файле имеются множество вхождений динамического блока. У динамического блока есть атрибут с тэгом "ИМЯ_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 · 04.06.2018, 14:27

Код:

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

  
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 · 04.06.2018, 15:08

Цитата:

Сообщение от 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 · 04.06.2018, 18:31

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

Код:

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

 (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 · 04.06.2018, 20:36

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

kirillwu · 04.06.2018, 21:11

Цитата:

Сообщение от engngr

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

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

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

Кулик Алексей aka kpblc · 04.06.2018, 22:26

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

kirillwu · 05.06.2018, 08:33

Цитата:

Сообщение от Кулик Алексей 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 · 05.06.2018, 11:21

Цитата:

Сообщение от 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 · 05.06.2018, 12:48

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

Цитата:

Сообщение от Nike

исправил

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

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

engngr · 05.06.2018, 12:57

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

Сергей812 · 05.06.2018, 13:17

Цитата:

Сообщение от engngr

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

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

Nike · 05.06.2018, 15:30

Цитата:

Сообщение от 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 · 06.06.2018, 09:10

Мой вариант

kirillwu · 08.06.2018, 16:43

Цитата:

Сообщение от VVA

Мой вариант

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

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

VVA · 09.06.2018, 17:02

Цитата:

Сообщение от kirillwu

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

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

kirillwu · 10.06.2018, 08:32

Цитата:

Сообщение от VVA

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

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

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

VVA · 10.06.2018, 11:18

Цитата:

Сообщение от kirillwu

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

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

kirillwu · 10.06.2018, 11:54

Цитата:

Сообщение от VVA

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

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

kirillwu · 26.06.2018, 14:33

Цитата:

Сообщение от VVA

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

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

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Значение атрибута в текстовое поле динамического блока	zekatyumen	Динамические блоки	19	28.01.2023 09:26
Мои динамические блоки [2]	Кулик Алексей aka kpblc	Динамические блоки	4334	22.04.2019 09:16
C# .net переопределение динамического блока из внешнего файла	bargool	.NET	35	18.10.2011 16:03
Редактирование вхождения динамического блока из командной строки.	Alexey_BH	Динамические блоки	2	26.09.2010 13:13
При растягивании/поворачивании грисп динамического блока перестало показывать значение параметра	Red Nova	Динамические блоки	2	02.10.2008 14:57

Опции темы	Поиск в этой теме
	Поиск в этой теме: Расширенный поиск