[求助]图块改层

liushengri

如何编一个程序，用一个命令而不用双击块来编辑就能把块中的图元改变到输入的图层中，并且线型颜色不变．例如：块Ａ是在层１中建立，而块中的图元分别在层2  3   4 .......中，现想用lsp 编一个程序，直接输入一个命令就能将块Ａ改变到你想输入的层（如：层８）中，且该块中的图元全改变到层8中，线型颜色为原来那样不会改变

KO你

块内的图层，颜色，线宽处理
快捷键  bb  块内实体处理
(vl-load-com)
(defun c:bb (/ obj blk)
  (defun confirm (msg default / rt)
    (initget "Y D ")
    (if        (null (setq rt (getkword (strcat msg " <" default ">:"))))
      (setq rt default)
    )
    (if        (= "Y" rt)
      t
      nil
    )
  )

  (defun walk (blk setlayer setcolor setlw /)
    (vlax-for x        blk
      (if (= "AcDbBlockReference" (vla-get-objectname x))
        (walk (vla-item        (vla-get-blocks
                          (vla-get-activedocument (vlax-get-acad-object))
                        )
                        (vla-get-name x)
              )
              setlayer
              setcolor
              setlw
        )
      )

      (if setlayer
        (vla-put-layer x "0")
      )

      (if setcolor
        (vla-put-color x acbyblock)
      )

      (if setlw
        (progn
          (vla-put-lineweight x -1)
          (if (= "AcDbPolyline" (vla-get-objectname x))
            (vla-put-constantwidth x 0.0)
          )
        )
      )
    )
  )

  (setq        obj (ace-entsel "\n选择块:" nil "INSERT")
        blk (vla-item (vla-get-blocks
                        (vla-get-activedocument (vlax-get-acad-object))
                      )
                      (vla-get-name (vlax-ename->vla-object (car obj)))
            )
  )
  (walk        blk
        (confirm "重置图元图层为\"0\" [是(Y)/否(D)]" "Y")
        (confirm "重置图元颜色为随块 [是(Y)/否(D)]" "Y")
        (confirm "重置图元线宽默认或零 [是(Y)/否(D)]" "Y")
  )
  (command ".regen")
  (princ)
)

(defun ace-entsel (msg kword filter / ent)
  (while (null ent)
    (if        kword
      ;; 处理自定义INITGET参数
      (initget kword)

      ;; return empty string ("") if enter key or right button down
      (initget " ")
    )

    (setq ent (entsel msg))

    (cond
      ((null ent)
       (princ "未选择对象。")
      )

      ((= (type ent) 'list)
       (if (and        filter
                (not (wcmatch (ace-getval 0 (car ent)) filter))
           )
         (progn
           (princ "选择对象已被过滤。")
           (setq ent nil)
         )
       )
      )
    )
  )
  ent
)

(defun ace-getval (key ename)
  (cdr (assoc key (entget ename)))
)

快捷键  bb`   改块选中对象颜色
快捷键  bb``  改块全部对象颜色
;修改实体和图块内的颜色
(defun c:bb`` () (pl:block-color) (princ))
(defun c:bb` () (pl:block-ent-color) (princ))
(vl-load-com)
(defun pl:block-ent-color (/ adoc blocks color ent lays)
    (setq adoc  (vla-get-activedocument (vlax-get-acad-object))
          lays  (vla-get-layers adoc)
          color (acad_colordlg 256)
    )
    (if color
        (progn (setvar "errno" 0)
               (vla-startundomark adoc)
               (while (and (not (vl-catch-all-error-p
                                    (setq ent (vl-catch-all-apply
                                                  (function nentsel)
                                                  '("\nSelect entity <Exit>:")
                                              )
                                    )
                                )
                           )
                           (/= 52 (getvar "errno"))
                      )
                   (if ent
                       (progn (setq ent (vlax-ename->vla-object (car ent))
                                    lay (vla-item lays (vla-get-layer ent))
                              )
                              (if (= (vla-get-lock lay) :vlax-true)
                                  (progn (setq layloc (cons lay layloc))
                                         (vla-put-lock lay :vlax-false)
                                  )
                              )
                              (vl-catch-all-apply (function vla-put-color) (list ent color))
                              (vla-regen adoc acallviewports)
                       )
                       (princ "\nNothing selection! Try again.")
                   )
               )
               (foreach i layloc (vla-put-lock i :vlax-true))
               (vla-endundomark adoc)
        )
    )
    (princ)
)

(defun pl:block-color (/ adoc blocks color ins lays)
    (setq adoc   (vla-get-activedocument (vlax-get-acad-object))
          blocks (vla-get-blocks adoc)
          lays   (vla-get-layers adoc)
          color  (acad_colordlg 256)
    )
    (if color
        (progn (setvar "errno" 0)
               (vla-startundomark adoc)
               (while (and (not (vl-catch-all-error-p
                                    (setq ins (vl-catch-all-apply
                                                  (function entsel)
                                                  '("\nSelect block <Exit>:")
                                              )
                                    )
                                )
                           )
                           (/= 52 (getvar "errno"))
                      )
                   (if ins
                       (progn (setq ins (vlax-ename->vla-object (car ins)))
                              (if (= (vla-get-objectname ins) "AcDbBlockReference")
                                  (if (vlax-property-available-p ins 'path)
                                      (princ "\nThis is external reference! Try pick other.")
                                      (progn (_pl:block-color blocks ins color lays)
                                             (vla-regen adoc acallviewports)
                                      )
                                  )
                                  (princ "\nThis isn't block! Try pick other.")
                              )
                       )
                       (princ "\nNothing selection! Try again.")
                   )
               )
               (vla-endundomark adoc)
        )
    )
    (princ)
)

(defun _pl:block-color (blocks ins color lays / lay layfrz layloc)
    (vlax-for e (vla-item blocks (vla-get-name ins))
        (setq lay (vla-item lays (vla-get-layer e)))
        (if (= (vla-get-freeze lay) :vlax-true)
            (progn (setq layfrz (cons lay layfrz)) (vla-put-freeze lay :vlax-false))
        )
        (if (= (vla-get-lock lay) :vlax-true)
            (progn (setq layloc (cons lay layloc)) (vla-put-lock lay :vlax-false))
        )
        (vl-catch-all-apply (function vla-put-color) (list e color))
        (if (and (= (vla-get-objectname e) "AcDbBlockReference")
                 (not (vlax-property-available-p e 'path))
            )
            (_pl:block-color blocks e color lays)
        )
        (foreach i layfrz (vla-put-freeze i :vlax-true))
        (foreach i layloc (vla-put-lock i :vlax-true))
    )
)

(progn
(princ "\BLCC - Changes color of the chosen blocks")
(princ "\nENCC - Changes color of the chosen objects (may be  element of the block)")
(princ))

zazhz123

KO你 发表于 2019-12-12 18:59
块内的图层，颜色，线宽处理
快捷键  bb  块内实体处理
(vl-load-com)

挺好用的，但是能选择几个批量一起改吗

KO你

zazhz123 发表于 2022-3-31 16:21
挺好用的，但是能选择几个批量一起改吗

你可以把多个对象组成一个块来弄，再分解开就行了，技巧方法有时比工具实用哈

liushengri

怎么没有高手解答呀

liushengri

怎么没有高手解答呀

alin

(defun C:Test ()
  (setq blk (car (entsel "\nSelect a block: ")))
  (setq layname (getstring "\nLayer Name:"))
  (setq blkname (cdr (assoc 2 (entget blk))))
  (setq    blkdef
     (vla-item (vla-get-blocks
             (setq
               doc (vla-get-activedocument (vlax-get-acad-object))
             )
           )
           blkname
     )
  )
  (vlax-for obj    blkdef
    (vla-put-layer obj layname)
  )
  (vla-regen doc acActiveViewport)
  (princ)
)

liushengri

多谢老大,此程序很好用.向你致敬

egos

经过测试 很好用  
不能处理嵌套块哦  
不能处理块中的自定义对象 比如像天正画的图元对象  

鲜菠萝

谢谢版主分享。

無恒的地盘

只是将块里面的图元改换图层了，但块本身确没有跟着一起改图层
还有换图层要输入图层名，不太方便，是否改成点选目标图层换图层更方便

guankuiwu

这样是不是可以直接改到0层了