[求助]：选择图层加前缀！！！

yinzhun22 · 发表于 2008-1-3 08:28:50

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

要在选中物体的图层说直接加上前缀，不要有新的图层产生，直接把物体的图层改成需要的，希望可以支持一次选者多个不同图层的物体，在命令行提示输入要前缀的字母时，能有个默认的如E-，谢谢

zxq0220 · 发表于 2008-1-3 11:00:49

[php]
;选择图层加前缀晓东 zxq0220 2008.1.3
(defun c:tt ()
(setvar "CMDECHO" 0)
(if (and (princ "\n选择物体 :")
 (setq ss (ssget))
 (setq ap (getstring "\n前缀 <E->:") ap (if ap ap "E-"))) (progn
 (setq i -1)
 (repeat (sslength ss)
(setq ln (cdr (assoc 8 (entgt(ssname ss (setq i (1+ i)))))))
(command "rename" "LA" ln (strcat ap ln))
 )
))
(setvar "CMDECHO" 1)
(princ)
)
[/php]

yinzhun22 · 发表于 2008-1-3 11:55:19

试了下，提示no function definition: ENTGT

zxq0220 · 发表于 2008-1-3 12:34:07

[php]
;选择图层加前缀晓东 zxq0220 2008.1.3
(defun c:tt ()
(setvar "CMDECHO" 0)
(if (and (princ "\n选择物体 :")
 (setq ss (ssget))
 (setq ap (getstring "\n前缀 <E->:") ap (if ap ap "E-"))) (progn
 (setq i -1 lnl (list))
 (repeat (sslength ss)
(setq ln (cdr (assoc 8 (entget(ssname ss (setq i (1+ i)))))))
(if (not (member ln lnl)) (setq lnl (append lnl (list ln))))
 )
 (setq i -1)
 (repeat (length lnl)
(command "rename" "LA" (setq ln (nth (setq i (1+ i)) lnl)) (strcat ap ln))
 )
))
(setvar "CMDECHO" 1)
(princ)
)
[/php]

yinzhun22 · 发表于 2008-1-3 14:31:52

可以用了，谢谢！！！
就是默认的E-还是要输入，如果不输入程序就不运行？

taner · 发表于 2008-1-3 14:38:58

[FONT=courier new]
(defun c:test (/ actdoc activesset ap layers laylst layname ss)
(if (and
(princ "\n选择要改层名的物体 :")
(setq ss (ssget))
(setq ap (getstring "\n前缀 <E->:")
ap (if (= ap "")
"E-"
ap
)
)
)
(progn
(setq actdoc (vla-get-activedocument (vlax-get-acad-object)))
(setq activesset (vla-get-ActiveSelectionSet actdoc))
(setq layers (vla-get-layers actdoc))
(vlax-for each ActiveSset (setq layname (vla-get-layer each))
(if (not (member layname laylst))
(setq laylst (cons layname laylst))
)
)
(foreach each laylst
(vla-put-name (vla-item layers each) (strcat ap each))
)
)
)
(princ)
)
[/FONT]

[FONT=courier new] 
(defun c:test (/ actdoc activesset ap layers laylst layname ss) 
  (if (and 
        (princ "\n选择要改层名的物体 :") 
        (setq ss (ssget)) 
        (setq ap (getstring "\n前缀 <E->:") 
              ap (if (= ap "") 
                   "E-" 
                   ap 
                 ) 
        ) 
      ) 
    (progn 
      (setq actdoc (vla-get-activedocument (vlax-get-acad-object))) 
      (setq activesset (vla-get-ActiveSelectionSet actdoc)) 
      (setq layers (vla-get-layers actdoc)) 
      (vlax-for each ActiveSset (setq layname (vla-get-layer each)) 
                (if (not (member layname laylst)) 
                  (setq laylst (cons layname laylst)) 
                ) 
      ) 
      (foreach each laylst 
        (vla-put-name (vla-item layers each) (strcat ap each)) 
      ) 
    ) 
  ) 
  (princ) 
) 
 
  [/FONT]

yinzhun22 · 发表于 2008-1-3 15:03:03

谢谢，很好用！！

zxq0220 · 发表于 2008-1-3 15:17:49

[php]
;选择图层加前缀晓东 zxq0220 2008.1.3
(defun c:tt ()
(setvar "CMDECHO" 0)
(if (and (princ "\n选择物体 :")
 (setq ss (ssget))
 (setq ap (getstring "\n前缀 <E->:") ap (if (= ap "") "E-" ap))) (progn
 (setq i -1 lnl (list))
 (repeat (sslength ss)
(setq ln (cdr (assoc 8 (entget(ssname ss (setq i (1+ i)))))))
(if (not (member ln lnl)) (setq lnl (append lnl (list ln))))
 )
 (setq i -1)
 (repeat (length lnl)
(command "rename" "LA" (setq ln (nth (setq i (1+ i)) lnl)) (strcat ap ln))
 )
))
(setvar "CMDECHO" 1)
(princ)
)
[/php]

taner · 发表于 2008-1-4 13:46:51

[FONT=courier new]
(defun c:test (/ ap laylst layname ss sslst)
(if (null (setq ap (vlax-ldata-get "mydict" "ap")))
(setq ap "E-"
ap (ustr 1 "\n\t前缀" ap nil)
)
(setq ap (ustr 1 "\n\t前缀" ap nil))
)
(vlax-ldata-put "mydict" "ap" ap)
(if (and
(princ "\n选择物体 :")
(setq ss (ssget))
ap
)
(progn
(setq sslst (vl-remove-if 'listp (mapcar
'cadr
(ssnamex ss)
)
)
)
(foreach each sslst
(if (not (member (setq layname (cdr (assoc 8 (entget each))))
laylst
)
)
(setq laylst (cons layname laylst))
)
)
(foreach each laylst
(if (/= each "0")(command "_.rename" "la" each (strcat ap each)))
)
)
)
(princ)
)
(defun ustr (bit msg def spflag / inp nval)
(if (and
def
(/= def "")
)
(setq msg (strcat "\n" msg "<" def ">:")
inp (getstring msg spflag)
inp (if (= inp "")
def
inp
)
)
(progn
(setq msg (strcat "\n" msg ": "))
(if (= bit 1)
(while (= "" (setq inp (getstring msg spflag))))
(setq inp (getstring msg spflag))
)
)
)
(if inp
inp
def
)
)
[/FONT]

[FONT=courier new] 
(defun c:test (/ ap laylst layname ss sslst) 
  (if (null (setq ap (vlax-ldata-get "mydict" "ap"))) 
    (setq ap "E-" 
          ap (ustr 1  "\n\t前缀" ap nil) 
    ) 
    (setq ap (ustr 1  "\n\t前缀" ap nil)) 
  ) 
  (vlax-ldata-put "mydict" "ap" ap) 
  (if (and 
        (princ "\n选择物体 :") 
        (setq ss (ssget)) 
        ap 
      ) 
    (progn 
      (setq sslst (vl-remove-if 'listp (mapcar 
                                         'cadr 
                                         (ssnamex ss) 
                                       ) 
                  ) 
      ) 
      (foreach each sslst 
        (if (not (member (setq layname (cdr (assoc 8 (entget each)))) 
                         laylst 
                 ) 
            ) 
          (setq laylst (cons layname laylst)) 
        ) 
      ) 
      (foreach each laylst 
        (if (/= each "0")(command "_.rename" "la" each (strcat ap each))) 
      ) 
    ) 
  ) 
  (princ) 
) 
(defun ustr (bit msg def spflag / inp nval) 
  (if (and 
        def 
        (/= def "") 
      ) 
    (setq msg (strcat "\n" msg "<" def ">:") 
          inp (getstring msg spflag) 
          inp (if (= inp "") 
                def 
                inp 
              ) 
    ) 
    (progn 
      (setq msg (strcat "\n" msg ": ")) 
      (if (= bit 1) 
        (while (= "" (setq inp (getstring msg spflag)))) 
        (setq inp (getstring msg spflag)) 
      ) 
    ) 
  ) 
  (if inp 
    inp 
    def 
  ) 
) 
 
  [/FONT]

或

[FONT=courier new]
(defun c:tst (/ ap laylst layname ss sslst)
(if (null (setq ap (vlax-ldata-get "mydict" "ap")))
(setq ap "E-"
ap (ustr 1 "\n\t前缀" ap nil)
)
(setq ap (ustr 1 "\n\t前缀" ap nil))
)
(vlax-ldata-put "mydict" "ap" ap)
(if (and
(princ "\n选择物体 :")
(setq ss (ssget))
ap
)
(progn
(setq sslst (th-ss2lst ss))
(foreach each sslst
(if (not (member (setq layname (cdr (assoc 8 (entget each))))
laylst
)
)
(setq laylst (cons layname laylst))
)
)
(foreach each laylst
(if (/= each "0")
(txt-sub-upd (tblobjname "LAYER" each) 2 (strcat ap each))
)
)
)
)
(princ)
)
(defun txt-sub-upd (ename code newvalue)
(entmod (subst
(cons code newvalue)
(assoc code (entget ename))
(entget ename)
)
)
(entupd ename)
) [/FONT]

[FONT=courier new] 
(defun c:tst (/ ap laylst layname ss sslst) 
  (if (null (setq ap (vlax-ldata-get "mydict" "ap"))) 
    (setq ap "E-" 
          ap (ustr 1 "\n\t前缀" ap nil) 
    ) 
    (setq ap (ustr 1 "\n\t前缀" ap nil)) 
  ) 
  (vlax-ldata-put "mydict" "ap" ap) 
  (if (and 
        (princ "\n选择物体 :") 
        (setq ss (ssget)) 
        ap 
      ) 
    (progn 
      (setq sslst (th-ss2lst ss)) 
      (foreach each sslst 
        (if (not (member (setq layname (cdr (assoc 8 (entget each)))) 
                         laylst 
                 ) 
            ) 
          (setq laylst (cons layname laylst)) 
        ) 
      ) 
      (foreach each laylst 
        (if (/= each "0") 
          (txt-sub-upd (tblobjname "LAYER" each) 2 (strcat ap each)) 
        ) 
      ) 
    ) 
  ) 
  (princ) 
) 
(defun txt-sub-upd (ename code newvalue) 
  (entmod (subst 
            (cons code newvalue) 
            (assoc code (entget ename)) 
            (entget ename) 
          ) 
  ) 
  (entupd ename) 
)  [/FONT]

账号		自动登录	找回密码
密码			立即注册

[求助]：选择图层加前缀！！！

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子