请代写“点选图元更改图层名称”程序

冒个烟圈

平时处理外来dxf格式文件较多，因为图层较多且图层名称很乱，在图层管理器里改很费时，还得狂点击鼠标查看一个层包含的图元，本人lisp刚入门，所以请帮忙代写一段程序。小弟是新手，悬赏有点少，请勿见怪！！！谢谢
希望实现的功能：1，碰选任意图元，该图元所在层的全部图元亮显
                         2，屏幕显示（注意是屏显，不是命令行）原图层名称，并提示输入新图层名称
                         3，输入新图层名击右键后，该图层关闭，此时命令循环

xyp1964

2. ;; tt1: 点选任意图元，该图元所在层的全部图元亮显
   
3. (defun c:tt1 ()
   
4.   (if (setq s1 (car (entsel "\n选择: ")))
   
5.     (sssetfirst nil (ssget "x" (list (assoc 8 (cdr (entget s1))))))
   
6.   )
   
7.   (princ)
   
8. )

;; tt1: 点选任意图元，该图元所在层的全部图元亮显<br /> (defun c:tt1 ()<br />   (if (setq s1 (car (entsel "\n选择: ")))<br />     (sssetfirst nil (ssget "x" (list (assoc 8 (cdr (entget s1))))))<br />   )<br />   (princ)<br /> )

冒个烟圈

xyp1964 发表于 2015-6-5 19:17

老大，好人做到底高抬贵手写个完整的呗，这个程序对我很重要，忙活一下午了，光去改图层名称了。

冒个烟圈

冒个烟圈 发表于 2015-6-5 19:22
老大，好人做到底高抬贵手写个完整的呗，这个程序对我很重要，忙活一下午了，光去改图层名称了。

差一点就完成了，会弄的伙计们出手帮帮忙呀。。明天加班等着用呢。。

冒个烟圈

不能沉啊。。来个帮忙的啊。

冒个烟圈

高手们都去哪了。。这个程序是不是很麻烦？还是悬赏少的原因啊

荒野孤行

冒个烟圈 发表于 2015-6-6 21:05
高手们都去哪了。。这个程序是不是很麻烦？还是悬赏少的原因啊

一点都不麻烦，其实是我们希望你加班多挣点钱

冒个烟圈

荒野孤行 发表于 2015-6-7 01:25
一点都不麻烦，其实是我们希望你加班多挣点钱

加班不给钱。。只有少许的补助
请出手发招！！！

荒野孤行

如果输入的图层名与已有图层名重复，这种情况未排除，所以写的不是很完美，但可满足你的基本要求吧！

(defun c:t1 ()
  (setvar "cmdecho" 0)
  (vl-load-com)
  (princ "\n★功能：点选图元更改其所在图层的名字。")
  (command "undo" "be")
  (while
    (progn (setq sel
                  (entsel
                    "\n请点选直线、多段线、样条曲线、标注、圆弧、圆、椭圆（不支持选图块）\n"
                  )
           )
           (wcmatch (cdr (assoc 0 (entget (car sel))))
                    "*LINE,*TEXT,ARC,CIRCLE,ELLIPSE,DIMENSION"
           )
    )
    ;|    (setq atcad     (vlax-get-acad-object)
           doc             (vla-get-activedocument atcad)
           layers    (vla-get-layers doc)
           layerlist nil
     )
(vlax-for each layers
       (setq nam       (vla-get-name each)
             layerlist (cons (list nam) layerlist)
       )
     )|;
     (setq laynam (cdr (assoc 8 (entget (car sel)))))
     (princ (strcat "\n提示：您选中的图元所在图层为：" laynam))
     (if (setq newlaynam (getstring "\n请输入新的图层名："))
       (command "rename" "LA" laynam newlaynam)
       (princ "\n输入的图层名为空或与现已有图层名相同。\n")
     )
  )
  (command "undo" "e")
  (princ)
)

xiang19751218

回复瞧瞧。。。。