修改实体（包括块内实体）的颜色

Lispboy · 发表于 2016-9-5 09:53:55

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

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

×

修改实体或块内实体的颜色

[it618postdisplay>0]

;修改实体和图块内的颜色
(defun c:blcc () (pl:block-color) (princ))
(defun c:encc () (pl:block-ent-color) (princ))

[/it618postdisplay]

(vl-load-com)
(defun pl:block-ent-color (/ adoc blocks color ent lays)
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
lays (vla-get-layers adoc)
color (acad_colordlg 256)
)
(if color
(progn (setvar "errno" 0)
(vla-startundomark adoc)
(while (and (not (vl-catch-all-error-p
(setq ent (vl-catch-all-apply
(function nentsel)
'("\nSelect entity <Exit>:")
)
)
)
)
(/= 52 (getvar "errno"))
)
(if ent
(progn (setq ent (vlax-ename->vla-object (car ent))
lay (vla-item lays (vla-get-layer ent))
)
(if (= (vla-get-lock lay) :vlax-true)
(progn (setq layloc (cons lay layloc))
(vla-put-lock lay :vlax-false)
)
)
(vl-catch-all-apply (function vla-put-color) (list ent color))
(vla-regen adoc acallviewports)
)
(princ "\nNothing selection! Try again.")
)
)
(foreach i layloc (vla-put-lock i :vlax-true))
(vla-endundomark adoc)
)
)
(princ)
)
(defun pl:block-color (/ adoc blocks color ins lays)
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
blocks (vla-get-blocks adoc)
lays (vla-get-layers adoc)
color (acad_colordlg 256)
)
(if color
(progn (setvar "errno" 0)
(vla-startundomark adoc)
(while (and (not (vl-catch-all-error-p
(setq ins (vl-catch-all-apply
(function entsel)
'("\nSelect block <Exit>:")
)
)
)
)
(/= 52 (getvar "errno"))
)
(if ins
(progn (setq ins (vlax-ename->vla-object (car ins)))
(if (= (vla-get-objectname ins) "AcDbBlockReference")
(if (vlax-property-available-p ins 'path)
(princ "\nThis is external reference! Try pick other.")
(progn (_pl:block-color blocks ins color lays)
(vla-regen adoc acallviewports)
)
)
(princ "\nThis isn't block! Try pick other.")
)
)
(princ "\nNothing selection! Try again.")
)
)
(vla-endundomark adoc)
)
)
(princ)
)
(defun _pl:block-color (blocks ins color lays / lay layfrz layloc)
(vlax-for e (vla-item blocks (vla-get-name ins))
(setq lay (vla-item lays (vla-get-layer e)))
(if (= (vla-get-freeze lay) :vlax-true)
(progn (setq layfrz (cons lay layfrz)) (vla-put-freeze lay :vlax-false))
)
(if (= (vla-get-lock lay) :vlax-true)
(progn (setq layloc (cons lay layloc)) (vla-put-lock lay :vlax-false))
)
(vl-catch-all-apply (function vla-put-color) (list e color))
(if (and (= (vla-get-objectname e) "AcDbBlockReference")
(not (vlax-property-available-p e 'path))
)
(_pl:block-color blocks e color lays)
)
(foreach i layfrz (vla-put-freeze i :vlax-true))
(foreach i layloc (vla-put-lock i :vlax-true))
)
)
(progn
(princ "\BLCC - Changes color of the chosen blocks")
(princ "\nENCC - Changes color of the chosen objects (may be element of the block)")
(princ))

(vl-load-com) 
(defun pl:block-ent-color (/ adoc blocks color ent lays) 
    (setq adoc  (vla-get-activedocument (vlax-get-acad-object)) 
          lays  (vla-get-layers adoc) 
          color (acad_colordlg 256) 
    ) 
    (if color 
        (progn (setvar "errno" 0) 
               (vla-startundomark adoc) 
               (while (and (not (vl-catch-all-error-p 
                                    (setq ent (vl-catch-all-apply 
                                                  (function nentsel) 
                                                  '("\nSelect entity <Exit>:") 
                                              ) 
                                    ) 
                                ) 
                           ) 
                           (/= 52 (getvar "errno")) 
                      ) 
                   (if ent 
                       (progn (setq ent (vlax-ename->vla-object (car ent)) 
                                    lay (vla-item lays (vla-get-layer ent)) 
                              ) 
                              (if (= (vla-get-lock lay) :vlax-true) 
                                  (progn (setq layloc (cons lay layloc)) 
                                         (vla-put-lock lay :vlax-false) 
                                  ) 
                              ) 
                              (vl-catch-all-apply (function vla-put-color) (list ent color)) 
                              (vla-regen adoc acallviewports) 
                       ) 
                       (princ "\nNothing selection! Try again.") 
                   ) 
               ) 
               (foreach i layloc (vla-put-lock i :vlax-true)) 
               (vla-endundomark adoc) 
        ) 
    ) 
    (princ) 
) 
 
(defun pl:block-color (/ adoc blocks color ins lays) 
    (setq adoc   (vla-get-activedocument (vlax-get-acad-object)) 
          blocks (vla-get-blocks adoc) 
          lays   (vla-get-layers adoc) 
          color  (acad_colordlg 256) 
    ) 
    (if color 
        (progn (setvar "errno" 0) 
               (vla-startundomark adoc) 
               (while (and (not (vl-catch-all-error-p 
                                    (setq ins (vl-catch-all-apply 
                                                  (function entsel) 
                                                  '("\nSelect block <Exit>:") 
                                              ) 
                                    ) 
                                ) 
                           ) 
                           (/= 52 (getvar "errno")) 
                      ) 
                   (if ins 
                       (progn (setq ins (vlax-ename->vla-object (car ins))) 
                              (if (= (vla-get-objectname ins) "AcDbBlockReference") 
                                  (if (vlax-property-available-p ins 'path) 
                                      (princ "\nThis is external reference! Try pick other.") 
                                      (progn (_pl:block-color blocks ins color lays) 
                                             (vla-regen adoc acallviewports) 
                                      ) 
                                  ) 
                                  (princ "\nThis isn't block! Try pick other.") 
                              ) 
                       ) 
                       (princ "\nNothing selection! Try again.") 
                   ) 
               ) 
               (vla-endundomark adoc) 
        ) 
    ) 
    (princ) 
) 
 
(defun _pl:block-color (blocks ins color lays / lay layfrz layloc) 
    (vlax-for e (vla-item blocks (vla-get-name ins)) 
        (setq lay (vla-item lays (vla-get-layer e))) 
        (if (= (vla-get-freeze lay) :vlax-true) 
            (progn (setq layfrz (cons lay layfrz)) (vla-put-freeze lay :vlax-false)) 
        ) 
        (if (= (vla-get-lock lay) :vlax-true) 
            (progn (setq layloc (cons lay layloc)) (vla-put-lock lay :vlax-false)) 
        ) 
        (vl-catch-all-apply (function vla-put-color) (list e color)) 
        (if (and (= (vla-get-objectname e) "AcDbBlockReference") 
                 (not (vlax-property-available-p e 'path)) 
            ) 
            (_pl:block-color blocks e color lays) 
        ) 
        (foreach i layfrz (vla-put-freeze i :vlax-true)) 
        (foreach i layloc (vla-put-lock i :vlax-true)) 
    ) 
) 
 
(progn 
(princ "\BLCC - Changes color of the chosen blocks") 
(princ "\nENCC - Changes color of the chosen objects (may be  element of the block)") 
(princ))

lucas3 · 发表于 2016-9-5 09:57:33

看看，向大师学习

HLCAD · 发表于 2016-9-5 09:58:44

感谢版主！向版主学习！

lisp_beginner · 发表于 2016-9-5 10:08:07

向大师学习。

lisp_beginner · 发表于 2016-9-5 10:18:37

谢了大师，程序很好用，但是发现不能修改属性的颜色，能不能提供个代码修改下属性的颜色呢？

clinber · 发表于 2016-9-5 10:46:29

这个给力啊

newer · 发表于 2016-9-5 11:10:38

用XDRX API写这个，如下，而且修改完颜色后不会重新生成图形。

(defun c:tt()
(if (and (setq clr (xdrx_color_select))
(setq e (xdrx_entsel "\n拾取块实体<退出>:" '((0 . "INSERT"))))
)
(progn
(xdrx_entity_setproperty (xdrx_block_getentities t (car e)) "color" clr)
(xdrx_block_update (car e))
)
)
(princ)
)

dnbcgrass · 发表于 2016-9-5 13:42:10

回复学习学习！

819534890 · 发表于 2016-9-5 14:20:12

回复学习，快乐学习

hodnes · 发表于 2016-9-5 15:39:30

学习学习~~~~~~~~~~~~~~~~~~~~~~~~~~~~

newer · 发表于 2016-9-5 16:29:50

lisp_beginner 发表于 2016-9-5 10:18
谢了大师，程序很好用，但是发现不能修改属性的颜色，能不能提供个代码修改下属性的颜色呢？

http://bbs.xdcad.net/thread-705328-1-1.html

yoyoho · 发表于 2016-9-5 17:49:16

跟Lispboy学习。

shuaier · 发表于 2016-9-11 10:49:58

测试下功能

pedromax · 发表于 2016-9-17 11:41:33

向兩位大師致敬!
感謝分享!學習了~~

杜流浪人 · 发表于 2016-9-24 15:59:56

楼主真是高产

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

[每日一码] 修改实体（包括块内实体）的颜色

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

点评