[转帖][求助]急，急，急，哪位高手帮忙改一下，改图块颜色和层的。
 

[转帖][求助]急，急，急，哪位高手帮忙改一下，改图块颜色和层的。
www.dimcax.com
[转帖][求助]急，急，急，哪位高手帮忙改一下，改图块颜色和层的。
我只想要改图块层的功能，不想改其颜色。
(defun c:ch (/ col ss cnt idx blkname donelist)
(defun grp (gcc el) (cdr (assoc gcc el)))
(defun update (bname col / ename elist)
(setq ename (tblobjname "block" bname))
(if
(and ename
(zerop (logand 52 (grp 70 (entget ename '("*")))))
)
(progn
(while ename
(if (or (= "insert" (grp 0 (entget ename)))
(= "dimension" (grp 0 (entget ename)))
)
(update (grp 2 (entget ename)) col)
)
(setq elist (entget ename '("*"))
elist (subst '(8 . "0") (assoc 8 elist) elist)
elist (if (assoc 62 elist)
(subst (cons 62 col) (assoc 62 elist) elist)
(append elist (list (cons 62 col)))
)
)
(entmod elist)
(setq ename (entnext ename))
)
't
)
)
)
(if (> (logand (grp 70 (tblsearch "layer" "0")) 1) 0)
(princ "\nlayer 0 must be thawed before running fixblock!\n"
)
(progn
(if
(progn
(setq col (acad_colordlg 7))
(princ "\npress to fix all blocks new color\n")
(setq cnt 0
ss (ssget '((0 . "insert,dimension")))
)
)
(progn
(setq idx (sslength ss))
(while (>= (setq idx (1- idx)) 0)
(if
(not
(member (setq blkname (grp 2 (entget (ssname ss idx))))
donelist
)
)
(progn
(if (update blkname col)
(setq cnt (1+ cnt))
)
(setq donelist (cons blkname donelist))
)
)
)
)
(while (setq blkname (grp 2 (tblnext "block" (not blkname))))
(if (update blkname col)
(setq cnt (1+ cnt))
)
)
)
(princ (strcat "\n"
(itoa cnt)
" block"
(if (= cnt 1)
""
"s"
)
" redefined new color\n"
)
)
)
)
(command "_.regen")
(princ)
)
d
回复：（userzhl）[转帖][求助]急，急，急，哪位高手帮...
高手都到哪去了呢？
d
版主都到哪去了？
d
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
( c:cc ( *doc blocks ss)
()
( *doc (vla-get-activedocument ()))
( blocks (vla-get-blocks *doc)) ;得到文件的块集合
( "\n请选择块: ")
( ( ss ( '((0 . "insert"))));得到块的选择集
(change-block-layer ss) ;全部改层
)
;;(vla-regen *doc acactiveviewport)
()
)
;;;改层函数
( change-block-layer (ss / i l ename elist bname blist layer)
( i 0 l ( ss)) ;计数器清零
( ( i l)
( ename ( ss i)) ;得到插入块图元名
( elist ( ename)) ;得到插入块图元表
( layer ( ( 8 elist))) ;得到插入块图层
( bname ( ( 2 elist))) ;得到插入块块名
( blist (vla-item blocks bname));得到块内实体集合
( n blist
(vla-put-layer n layer) ;对块内每个实体改变图层
)
( ename) ;更新插入块图元数据
( i ( i)) ;计数器加一
)
)
不知道是不是你想要的？
/blog/user1/90/index.asp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
;我只想要改图块层的功能，不想改其颜色。
( c:ch ( col ss cnt idx blkname donelist)
( grp (gcc el) ( ( gcc el)))
( update (bname col / ename elist)
( ename ( "block" bname))
( ( ename ( ( 52 (grp 70 ( ename '("*")))))) (
( ename
( ( ( "insert" (grp 0 ( ename)))
( "dimension" (grp 0 ( ename)))
)
(update (grp 2 ( ename)) col)
)
( elist ( ename '("*"))
elist ( '(8 . "0") ( 8 elist) elist)
; elist ( ( 62 elist)
; ( ( 62 col) ( 62 elist) elist)
; ( elist ( ( 62 col)))
; )
)
( elist)
( ename ( ename))
)
't
)
)
)
( ( ( (grp 70 ( "layer" "0")) 1) 0)
( "\nlayer 0 must be thawed before running fixblock!\n")
(
( ( ( col 256); ( col ( 7))
( "\npress to fix all blocks new color\n")
( cnt 0 ss ( '((0 . "insert,dimension"))))
)
(
( idx ( ss))
( ( ( idx (1- idx)) 0)
( ( ( ( blkname (grp 2 ( ( ss idx)))) donelist)) (
( (update blkname col) ( cnt ( cnt)))
( donelist ( blkname donelist))
))
)
)
( ( blkname (grp 2 ( "block" ( blkname))))
( (update blkname col) ( cnt ( cnt)))
)
)
(
( "\n" ( cnt) " block" ( ( cnt 1) "" "s") " redefined new color\n")
)
)
)
( "_.regen")
()
)
踅摸
d
好程序，我也写了两个，改天传上来