[LISP程序]：编辑图块的程序

zhjy · 发表于 2002-5-3 09:58:17

最初由 ll_j 发布
[B]我改了一下，请试试：
[code]
(defun c:CB(/ cn oldb newb len se1 e0 e1 bn b0)
  (command "color" "")
  (setvar "unitmode" 0)
  (princ "\n选择块实体：")
  (setq se1 (ssget '((0 . "INSERT"))))
  (i... [/B]

我试了觉得不错,谢谢.

ll_j · 发表于 2002-5-4 06:37:11

昨天匆忙修改的程序有错（*选项无效），今天又改了一下。

[FONT=courier new]
(defun c:CB (/ cn oldb newb len se1 e0 e1 bn b0)
(command "color" "")
(setvar "unitmode" 0)
(princ "\n选择块实体：")
(setq se1 (ssget '((0 . "INSERT")))
oldb nil
newb nil
)
(if se1
(progn
(setq bn (getstring "\n批量替换*/<新块名>（回车选取样块）："))
(cond
((= bn "*")
(setq oldb (strcase (getstring "\n旧块名："))
newb (strcase (getstring "\n新块名："))
)
)
((= bn "")
(setq b0 nil)
(while (not b0)
(initget " ")
(setq b0 (entsel "\n选取样块："))
(cond
((= (type b0) 'STR) (setq b0 t))
((and
(= (type b0) 'LIST)
(/= (cdr (assoc 0 (setq b0 (entget (car b0))))) "INSERT")
)
(setq b0 nil)
)
(t (setq bn (cdr (assoc 2 b0))))
)
)
)
(t nil)
)
(setq len (sslength se1))
(while (> len 0)
(setq e0 (ssname se1 0)
e1 (entget e0)
)
(if (and oldb newb)
(if (= (strcase (cdr (assoc 2 e1))) oldb)
(setq e1 (subst (cons 2 newb) (assoc 2 e1) e1))
)
(setq e1 (subst (cons 2 bn) (assoc 2 e1) e1))
)
(entmod e1)
(entupd e0)
(ssdel e0 se1)
(if se1
(setq len (sslength se1))
)
)
)
)
(princ)
)
[/FONT]

[FONT=courier new] 
(defun c:CB (/ cn oldb newb len se1 e0 e1 bn b0) 
  (command "color" "") 
  (setvar "unitmode" 0) 
  (princ "\n选择块实体：") 
  (setq        se1  (ssget '((0 . "INSERT"))) 
        oldb nil 
        newb nil 
  ) 
  (if se1 
    (progn 
      (setq bn (getstring "\n批量替换*/<新块名>（回车选取样块）：")) 
      (cond 
        ((= bn "*") 
         (setq oldb (strcase (getstring "\n旧块名：")) 
               newb (strcase (getstring "\n新块名：")) 
         ) 
        ) 
        ((= bn "") 
         (setq b0 nil) 
         (while        (not b0) 
           (initget " ") 
           (setq b0 (entsel "\n选取样块：")) 
           (cond 
             ((= (type b0) 'STR) (setq b0 t)) 
             ((and 
                (= (type b0) 'LIST) 
                (/= (cdr (assoc 0 (setq b0 (entget (car b0))))) "INSERT") 
              ) 
              (setq b0 nil) 
             ) 
             (t (setq bn (cdr (assoc 2 b0)))) 
           ) 
         ) 
        ) 
        (t nil) 
      ) 
      (setq len (sslength se1)) 
      (while (> len 0) 
        (setq e0 (ssname se1 0) 
              e1 (entget e0) 
        ) 
        (if (and oldb newb) 
          (if (= (strcase (cdr (assoc 2 e1))) oldb) 
            (setq e1 (subst (cons 2 newb) (assoc 2 e1) e1)) 
          ) 
          (setq e1 (subst (cons 2 bn) (assoc 2 e1) e1)) 
        ) 
        (entmod e1) 
        (entupd e0) 
        (ssdel e0 se1) 
        (if se1 
          (setq len (sslength se1)) 
        ) 
      ) 
    ) 
  ) 
  (princ) 
) 
[/FONT]

zhjy · 发表于 2002-5-4 11:13:27

我的工程搞好了，虽然没有找到我想要的图块编辑程序，但得到图块替换程序，工作效率当会提高很多，多谢大家了。特别是晓东老弟。望你的网站越办越好！另你的工具箱在我的机上无法安装成功，加载了你的函数，工具箱菜单仍不能用。是有点遗憾。

XDSoft · 发表于 2002-5-4 11:19:16

最初由 zhjy 发布
[B]我的工程搞好了，虽然没有找到我想要的图块编辑程序，但得到图块替换程序，工作效率当会提高很多，多谢大家了。特别是晓东老弟。望你的网站越办越好！另你的工具箱在我的机上无法安装成功，加载了你的函数，工具箱菜... [/B]

常来：）

你的ACAD是什么版本？ R14和2002是肯定没有问题的。若是2000，你升级2002吧。

caibaobao · 发表于 2002-5-4 21:39:52

晓东，我的问题和zhjy一样。昨天下载了beta0.1版，结果在天正3。52中加载了函数（菜单没有自动加载—是我写入acad.mnu中），结果仍无法使用。使用强行连接后，在r14中可以，在天正中不行！
结果只能在纯r14下绘制一个邮戳样板图贴了上来；）

梦断江南 · 发表于 2002-5-5 03:21:36

能不能这样写：
;;;; 图块刷子;;;;;
(defun c:cblk ( / el blkname ss en ent)
(princ "\n cblk=图块刷子------------------------lxx.xdapi.2002.5 ")
(setq el (xdrx_entsel "\n请点选参考块<回车－输入块名>:" 0 '((0 . "INSERT")) ))
(if el (setq blkname (cdr(assoc 2 (entget (car el)))))
(setq blkname (getstring "\n块名为："))
)
(princ "\n 选择要转变的块")
(setq nss (ssget '((0 . "INSERT"))) i 0)
(while (setq en (ssname nss i) ent (entget en))
(setq ent (subst (cons 2 blkname)(assoc 2 ent) ent) i (+ 1 i))
(entmod ent)(entupd en)
)
(princ)
)

XDSoft · 发表于 2002-5-5 05:55:36

最初由梦断江南发布
[B]能不能这样写：
;;;; 图块刷子;;;;;
(defun c:cblk ( / el blkname ss en ent)
(princ "\n cblk=图块刷子------------------------lxx.xdapi.2002.5 ")
(setq el (xdrx_entsel "\n请点选参考块<回车－输入块?.. [/B]

我给你修改成API的写法，你体会体会API的结构化编程。

[FONT=courier new]
(defun c:cblk () ; / el blkname ss en ent)
(princ "\n cb=图块刷子------------------------lxx.xdapi.2002.5 ")
(if (setq el (xdrx_entsel "\n请点选参考块<回车－输入块名>:" 0 '(
(0 . "INSERT")
)
)
)
(setq blkname (xdrx_getentdxf 2))
(setq blkname (getstring "\n块名为："))
)
(prompt "\n 选择要转变的块")
(if (setq nss (ssget '((0 . "INSERT"))))
(progn
(xdrx_setsstodb nss 0)
(while (xdrx_getentdata 0)
(xdrx_entmod 2 blkname)
)
)
)
(princ)
)[/FONT]

梦断江南 · 发表于 2002-5-5 05:58:01

程序没有考虑参考块是外部文件的情况，呵呵。那个来补充补充？应该不难的。

梦断江南 · 发表于 2002-5-5 07:51:56

;;再来

[FONT=century gothic]
(defun c:cblk ( / el blkname ss en ent)
(princ "\n cblk=图块刷子------------------------lxx.xdapi.2002.5 ")
(intget " eXit")
(setq el (xdrx_entsel "\n请点选参考块/eXit/回车输入块名:" 0 '( (0 . "INSERT"))))
(cond
((eq el "eXit")(exit))
((= (type el) 'LIST) (setq blkname (xdrx_getentdxf 2)))
((or(eq el " ")(= nil eq))(setq blkname (getstring "\n块名为：")))
)
(prompt "\n 选择要转变的块")
(if (setq nss (ssget '((0 . "INSERT"))))
(progn
(xdrx_setsstodb nss 0)
(while (xdrx_getentdata 0)
(xdrx_entmod 2 blkname)
)
)
)
(princ)
)[/FONT]

eachy · 发表于 2002-5-5 07:57:07

能改匿名块吗？:1 :1 :1

ll_j · 发表于 2002-5-6 19:42:23

最初由 eachy 发布
能改匿名块吗？:1 :1 :1

我的程序是可以得，只要不是真的无名（名字为""）或名字为"*"。

yousuika · 发表于 2002-6-19 17:20:56

请问晓东：在中文操作系统和CAD2000下，不能安装您的工具，在日文操作和CAD2000也不能用，为什么我老解决不了这个安装问题呀？？

li809 · 发表于 2005-4-1 22:07:39

谢谢了,很好用的东西

独钓蓑翁 · 发表于 2005-4-26 07:45:22

不错!
仔细研究一下!

kfd216 · 发表于 2005-5-8 11:16:32

楼主，你写的程序很好啊，建议多发点这样的程序。以后我也努力发点这样的程序。

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

[LISP程序]：编辑图块的程序

我试了觉得不错

望你的网站越办越好

Re: 望你的网站越办越好

我也有麻烦