[转贴]：Change Block Color---改变块的颜色

lsjjm · 发表于 2004-2-23 04:13:37

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

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

×

(defun C:TEST ()
(setvar "cmdecho" 0)
(prompt "\nSelect blocks that needs color changed: ")
(setq en (ssget '((0 . "INSERT"))))
(setq count (sslength en))
(setq index 0)
(setq clr (acad_colordlg 7))
(repeat count
(setq eg1 (entget (ssname en index)))
(setq en1 (ssname en index))
(redraw en1 3)
(setq en1 nil)
(setq nam (cdr (assoc 2 eg1)))
(setq en2 (cdr (assoc -2 (tblsearch "block" nam))))
(prblk en2 nam)
)
(setq index (+ index 1))
)
(defun prblk (en2 nam)
(setq cnt 0)
(while en2
(setq cnt (1+ cnt)
eg2 (entget en2)
en2 (entnext (cdr (assoc -1 eg2)))
)
(grtext -2 (strcat nam " block entity # " (itoa cnt)))
(if (= (cdr (assoc 0 eg2)) "insert")
(progn
(setq nm2 (cdr (assoc 2 eg2))
en3 (cdr (assoc -2 (tblsearch "block" nm2)))
)
(prblk en3 nm2)
)
(progn
(if (assoc 62 eg2)
(setq eg2 (subst (cons 62 clr) (assoc 62 eg2) eg2))
(setq eg2 (append eg2 (list (cons 62 clr))))
)
(entmod eg2)
)
)
)
(setq ss1 (ssget "x" (list (cons 2 nam)))
cnt 0
)
(while (setq en1 (ssname ss1 cnt))
(setq cnt (1+ cnt))
(entupd en1)
)
(setvar "cmdecho" 1)
(princ)
)

(defun C:TEST () 
    (setvar "cmdecho" 0) 
    (prompt "\nSelect blocks that needs color changed: ") 
    (setq en (ssget '((0 . "INSERT")))) 
    (setq count (sslength en)) 
    (setq index 0) 
    (setq clr (acad_colordlg 7)) 
    (repeat count 
      (setq eg1 (entget (ssname en index))) 
      (setq en1 (ssname en index)) 
      (redraw en1 3) 
      (setq en1 nil) 
      (setq nam (cdr (assoc 2 eg1))) 
      (setq en2 (cdr (assoc -2 (tblsearch "block" nam)))) 
      (prblk en2 nam) 
    ) 
    (setq index (+ index 1)) 
  ) 
  (defun prblk (en2 nam) 
    (setq cnt 0) 
    (while en2 
      (setq cnt        (1+ cnt) 
            eg2        (entget en2) 
            en2        (entnext (cdr (assoc -1 eg2))) 
      ) 
      (grtext -2 (strcat nam " block entity # " (itoa cnt))) 
      (if (= (cdr (assoc 0 eg2)) "insert") 
        (progn 
          (setq        nm2 (cdr (assoc 2 eg2)) 
                en3 (cdr (assoc -2 (tblsearch "block" nm2))) 
          ) 
          (prblk en3 nm2) 
        ) 
        (progn 
          (if (assoc 62 eg2) 
            (setq eg2 (subst (cons 62 clr) (assoc 62 eg2) eg2)) 
            (setq eg2 (append eg2 (list (cons 62 clr)))) 
          ) 
          (entmod eg2) 
        ) 
      ) 
    ) 
    (setq ss1 (ssget "x" (list (cons 2 nam))) 
          cnt 0 
    ) 
    (while (setq en1 (ssname ss1 cnt)) 
      (setq cnt (1+ cnt)) 
      (entupd en1) 
    ) 
    (setvar "cmdecho" 1) 
    (princ) 
  )

aeo · 发表于 2004-2-25 00:21:00

我把我的"改随层"改了几个字

;;;====================
;;;图块改颜色
;;;By Aeo
;;;---------------------
(defun c:tk( / blk blkref blocks doc ent name clo)
(vl-load-com)
(if(and (setq BLK (car (entsel "\n选要改色的块: ")))
(setq BLKREF (vlax-ename->vla-object BLK))
(not(and(/= (vla-get-objectname BLKREF) "AcDbBlockReference")
(princ"\n不是块:"))
)
(setq clo (acad_colordlg 7))
(setq name(vla-get-name BLKREF))
)
(progn
(command"undo""group")
(setq DOC (vla-get-activedocument (vlax-get-acad-object))
BLOCKS (vla-get-blocks doc)
blk (vla-item BLOCKS name)
)
(vlax-for ENT blk
(vla-put-color ent clo)
)
(vla-regen doc acActiveViewport)
(vlax-release-object blk)
(vlax-release-object BLOCKS)
(vlax-release-object DOC)
(command"undo""end")
(princ"\nUndo后请regen.")
)
)
(princ))

;;;==================== 
;;;图块改颜色 
;;;By Aeo 
;;;--------------------- 
(defun c:tk( / blk blkref blocks doc ent name clo) 
 (vl-load-com) 
  (if(and (setq BLK     (car (entsel "\n选要改色的块: "))) 
          (setq BLKREF  (vlax-ename->vla-object BLK)) 
          (not(and(/= (vla-get-objectname BLKREF) "AcDbBlockReference") 
              (princ"\n不是块:")) 
           ) 
          (setq clo (acad_colordlg 7)) 
          (setq name(vla-get-name BLKREF)) 
      ) 
    (progn 
          (command"undo""group") 
          (setq DOC     (vla-get-activedocument (vlax-get-acad-object)) 
                BLOCKS  (vla-get-blocks doc) 
                blk     (vla-item BLOCKS name) 
          ) 
           (vlax-for ENT blk 
             (vla-put-color ent clo) 
           ) 
        (vla-regen doc acActiveViewport) 
        (vlax-release-object blk) 
        (vlax-release-object BLOCKS) 
        (vlax-release-object DOC) 
        (command"undo""end") 
        (princ"\nUndo后请regen.") 
     ) 
  ) 
(princ))

陌生人 · 发表于 2004-2-25 02:23:06

要是改块中部分实体的颜色呢？

lsjjm · 发表于 2004-2-25 04:25:45

aeo斑竹: 这正是我要写的,  不过只是基本功能:

(defun c:test ()
  (vl-load-com)
  (setq ent (car (entsel)))
  (setq obj (vlax-ename->vla-object ent))
  (setq col (acad_colordlg 7))
  (vlax-for
item
(vla-item
   (vla-get-blocks
      (vla-get-activedocument
      (vlax-get-acad-object)))
   (vla-get-name obj)
)
(vla-put-color item col)
  )
)

最初由陌生人发布
[B]要是改块中部分实体的颜色呢？ [/B]

那就用nentsel 函数:

(defun c:test ()
  (vl-load-com)
  (setq ent (car (nentsel)))
  (setq obj (vlax-ename->vla-object ent))
  (setq col (getstring "\nNew Color Number: "))
  (vla-put-color obj col)
  (vl-cmdf "regen" "")
)

r8899 · 发表于 2004-3-5 08:08:40

看不明白

LUCAS · 发表于 2004-3-5 12:39:58

最初由 lsjjm 发布
[B]那就用nentsel 函数:
(defun c:test ()
(vl-load-com)
(setq ent (car (nentsel)))
(setq obj (vlax-ename->vla-object ent))
(setq col (getstring "\nNew Color Number: "))
(vla-put-color obj col)
(vl-cmdf "regen" "")
) ... [/B]

寫個一次點選圖塊多個物件的好嗎?

海豚 · 发表于 2004-3-6 23:04:55

好像已经有人写了一个该层的程序，可惜没有源代码。

lsjjm · 发表于 2004-3-7 06:31:40

最初由 LUCAS 发布
寫個一次點選圖塊多個物件的好嗎? [/B]

"点选"只能一次点一个呀。  这样行不行？：
(defun c:test ( / ss)
  (vl-load-com)
  (setq col (getstring "\nNew Color Number: "))
  (while (setq ent (car (nentsel)))
(setq obj (vlax-ename->vla-object ent))
(vla-put-color obj col)
(vl-cmdf "regen" "")
  )
)

LUCAS · 发表于 2004-3-7 18:15:44

;;By LUCAS(龙龙仔)
;;测试版,未完成
;;对"DIM"无效
(defun NENTSGET (/ HOLDPICKADD LIS SS N NAM)
(setq HOLDPICKADD (getvar "PICKADD"))
(setvar "pickadd" 1)
(prompt "\n点选要改颜色对象...(可多次点选图块内对象)")
(setq LIS (ssnamex (ssget ":N")))
(setq N 0)
(repeat (length LIS)
(if (= (type (setq NAM (cadr (nth N LIS)))) 'ENAME)
(setq SS (append SS (list NAM)))
)
(setq N (1+ N))
)
(setvar "pickadd" HOLDPICKADD)
SS
)
(defun tt (col / ss n)
(setq ss (NENTSGET))
(setq n 0)
(repeat (length ss)
(vla-put-color (vlax-ename->vla-object (nth n ss)) col)
(setq n (1+ n))
)
(vl-cmdf "regen")
(princ)
)
;;usage:(tt 1)
;;Sorry!现在没有autocad可供测试(人在香港)

lsjjm · 发表于 2004-3-8 05:07:00

不错, 增加了"框选". 可你问的是点选呀!------"寫個一次點選圖塊多個物件的好嗎?"
其实, 去除repeat还会更简单:
(defun c:test ( / ss n)
  (setq HOLDPICKADD (getvar "PICKADD"))
  (setvar "pickadd" 1)
  (prompt "\n点选要改颜色对象...(可多次点选图块内对象)")
  (setq LIS (ssnamex (ssget ":N")))
  (setq col (getstring "\nNew Color Number: "))
  (setvar "pickadd" HOLDPICKADD)
  (foreach i lis
(if (= (type (cadr i)) 'ENAME)
   (vla-put-color (vlax-ename->vla-object (cadr i)) col)
)
  )
  (vl-cmdf "regen")
  (princ)
)

zzxaaaaa · 发表于 2004-7-31 06:23:53

能提供文件吗？

wasee · 发表于 2004-8-1 06:44:41

看不懂，能提供文件吗？

穹心 · 发表于 2004-8-28 19:57:16

高手。

极度寒冷 · 发表于 2004-8-30 15:48:17

应该是好东西（版主奖励了好多爱心币！），厉害，高手！可这些代码要放在哪里呢？又怎么用呢？望指点。

心竹 · 发表于 2004-9-17 15:16:13

lsjjm，你好，工作中用到了你的不少好东东，
编程偶看不懂，但里面的两个中文字偶还好认识，看了一下好像没有我想要的情况，偶想选中块中的一种颜色如兰色，窗选我想改变颜色的块，将其中的全部兰色变成我想要的颜色。

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

[转贴]：Change Block Color---改变块的颜色

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

相关帖子

浏览过的版块