图块重命名（支持天正图块、动态块）

逍遥天下

G〆h 发表于 2019-1-3 15:09
只要是同一块，改的话一起变啊！你的意思是让当前块变成独立块，其它块名不变吗？

对，是的

oldnewlearn

有需要的就是好东西，先下载备着。

KO你

能把图层重命名像楼主的改块名一样编一个吗
获取图层原名，对话框模式，再改图层名


快捷键  de  图层重命名
(defun C:de ()
  (princ "\n功能：快速更改图层名。")
  (setvar "cmdecho" 0)
  (initget "D S")
  (if (not (setq kw
                  (getkword
                    "\n选择方式：[更改当前图层名(D)/更改所选图元所在图层的名称(S)]<S>"
                  )
           )
      )
    (setq kw "S")
  )
  (if (= kw "D")
    (setq laynam (getvar "CLAYER"))        ;获取当前图层
    (progn
      (setq ent           (entsel "\n请选择需要修改图层名的图元对象：")
            entnam (car ent)
            entdat (entget entnam)
      )
      (setq laynam (cdr (assoc 8 entdat))) ;获取所选图元的图层名
    )
  )
  (setq        newlaynam
         (getstring (strcat "\n请输入新的图层名："))
  )                                        ;输入新的图层名
  (if (and (not (tblsearch "LAYER" newlaynam)) (/= laynam "0"))
                                        ;若新图层名与图档中的图层名未重名，且对象图层不是0图层时；那么执行更改图层名
    (command "rename" "la" laynam newlaynam)
    (progn (princ "\n所选当前层可能为0图层或者图层名与已有的图层名相重复，程序无效。\n")
           (exit)
    )
  )
  (princ))

mokson

正好需要，谢谢。

G〆h

KO你 发表于 2019-1-18 00:14
能把图层重命名像楼主的改块名一样编一个吗
获取图层原名，对话框模式，再改图层名

改进些程序，更快捷点

G〆h

;;==============改名复制=================
(defun c:BC (/ E EL OBJ NAME BLOCKS DOC BLKDEFSRC OBJS BLKDEF orign)  (if (and (setq e (car (entsel "\n选择图块:")))
           (setq el (entget e))
           (= "INSERT" (cdr (assoc 0 el)))
           (setq obj (vlax-ename->vla-object e))
           (setq name (getstring "\n新块名称:"))
           (/= "" name)
      )
    (progn (setq blocks           (vla-get-blocks
                             (setq
                               doc (vla-get-ActiveDocument (vlax-get-acad-object))
                             )
                           )
                 blkdefSrc (vla-item blocks (cdr (assoc 2 el)))
                 orign (vla-get-Origin blkdefSrc)
           )
           (vlax-for o blkdefSrc (setq objs (cons o objs)))
           (if (VL-CATCH-ALL-ERROR-P
                 (setq
                   blkdef (VL-CATCH-ALL-APPLY 'vla-item (list blocks name))
                 )
               )
             (setq blkdef (vla-add blocks orign name))
             (vlax-for o blkdef (vla-delete o))
           )
           (vla-CopyObjects
             doc
             (vlax-safearray-fill
               (vlax-make-safearray
                 vlax-vbObject
                 (cons 0 (1- (length objs)))
               )
               objs
             )
             blkdef
           )
           (vla-InsertBlock
             (vla-get-ModelSpace doc)
             (vla-get-InsertionPoint obj)
             name
             (vla-get-XScaleFactor obj)
             (vla-get-YScaleFactor obj)
             (vla-get-ZScaleFactor obj)
             (vla-get-Rotation obj)
           )
           (vla-delete obj)
    )
  )
  (princ)
)

;先放上块的改名复制，等有时间再改成对话框的方式

talentzf

先收藏起来~~

KO你

G〆h 发表于 2019-2-4 13:58
改进些程序，更快捷点

谢谢楼主，正是我需要的效果

KO你

快捷键  cd  改图层颜色
(defun c:cd()
(setvar "cmdecho" 0)
(setq lay(cdr (assoc 8 (entget (car (entsel "\n 请选取要修改颜色的图层对象:"))))))
;(setq ss (ssget))
;(if ss (progn
(setq colour (getstring "\n请输入颜色号<1-255>:"))
(command "-layer" "c" colour lay ""))
(setvar "cmdecho" 1)
(princ)

请求大师修编一个像获取修改块名和图层名的对话框模式修改图层的颜色和替代颜色

示意图地址http://bbs.mjtd.com/thread-178999-1-1.html

zj20190405

可以增加选项，改单块或全部同名块吗