[编程申请]：一个能图块改色的程序等你来

my_autocad

实际设计中有许多图块更本无法改色,如果要改也只能炸开后,改色,再定义块,这样很麻烦,如果能一步就实现这个过程,就好了,有的LISP
只能改一些线的色,但这些软件更本没有用,CAD自己都可以改,一样方便

现在的软件,如HCAD,规划工具包等能实现,但我是用天正,要在软件之间切换也很麻烦,如果能这一个LISP程序,就太好了,大家来挑战吧,或许对自己编程也是个好处哦

所以:一个能图块改色的程序等你来

QQ:1407967

nuance

命令:chbp，选中块，回车

snoopychen

search
change color of block lisp
in google, 得到如下地址

http://www.cadresource.com/library/lisptz.html

UPDBLOCK.ZIP          4K          This routine allows the user to update the color of all entities within a block to a single color (eg: color=BYLAYER) without the user having to explode the symbol.

可以实现您的目的

一般google一些简单的lisp都能找到的

;****************************************************************************************
;        UPDATE BLOCK COLOR (updblkcl.lsp)
;        PRE-INSERTED BLOCK DEFINITION CLEAN-UP UTILITY
;
;        This routine is especially usefull to redefine pre-inserted blocks whose
;        entity colors need to be changed to BYLAYER.
;
;       This routine allows the user to update the color of
;        all entities within a block to a single color (exam: color=BYLAYER)
;        without the user having to explode the symbol.  By default the layer name of
;        all entities are NOT changed. The routine changes the original
;        definition of the block within the current drawing.
;       
;        To use this routine the user is asked to specify a single
;        color to place all entities of a selected block(s).
;
;        The user is next prompted to select one or more blocks to update. The routine
;        then redefines all entities of the block to the color specified.
;
;        When the user regenerates the drawing she/he will find that all
;        occurances of the block have been redefined.  This is because the
;        original definition of the block is changed!!!
;
;       by CAREN LINDSEY, July 1996
;****************************************************************************************
;

;INTERNAL ERROR HANDLER
(defun err-ubc (s)                                ; If an error (such as CTRL-C) occurs
                                                ; while this command is active...
        (if (/= s "Function cancelled")
                  (princ (strcat "\nError: " s))
        )
        (setq *error* olderr)                        ; Restore old *error* handler
        (princ)
);err-ubc

(DEFUN C:UPDBLKCL (/ BLK CBL CBL2 C ACL ALY NLY NCL)

        (setq olderr *error* *error* err-ubc)
        (initget "?")
        (while
                (or (eq (setq C (getint "\nEnter new color number/<?>: ")) "?")
                    (null C)
                    (> C 256)
                    (< C 0)
                );or
                (textscr)
                (princ "\n                                                     ")
                (princ "\n                 Color number   |   Standard meaning ")
                (princ "\n                ________________|____________________")
                (princ "\n                                |                    ")
                (princ "\n                       0        |      <BYBLOCK>     ")
                (princ "\n                       1        |      Red           ")
                (princ "\n                       2        |      Yellow        ")
                (princ "\n                       3        |      Green         ")
                (princ "\n                       4        |      Cyan          ")
                (princ "\n                       5        |      Blue          ")
                (princ "\n                       6        |      Magenta       ")
                (princ "\n                       7        |      White         ")
                (princ "\n                    8...255     |      -Varies-      ")
                (princ "\n                      256       |      <BYLAYER>     ")
                (princ "\n                                               \n\n\n")
                (initget "?")
        );while


        (PROMPT "\nPick blocks to update. ")

        (SETQ SS (SSGET '((0 . "INSERT"))))
        (SETQ K 0)
        (WHILE (< K (SSLENGTH SS))
                (setq CBL (tblsearch "BLOCK" (CDR (ASSOC 2 (ENTGET (SETQ BLK (SSNAME SS K)))))))
                (SETQ CBL2 (CDR (ASSOC -2 CBL)))
                (WHILE (BOUNDP 'CBL2)
                        (SETQ EE (ENTGET CBL2))

                        ;Update layer value
                        (SETQ NCL (CONS 62 C))
                        (SETQ ACL (ASSOC 62 EE))
                        (IF (= ACL nil)
                                (SETQ NEWE (APPEND EE (LIST NCL)))
                                (SETQ NEWE (SUBST NCL ACL EE))
                        );if
                        (ENTMOD NEWE)

                        (SETQ CBL2 (ENTNEXT CBL2))
                );end while
                (ENTUPD BLK)
                (SETQ K (1+ K))
        );end while
        (setq *error* olderr)
        (princ)
);end updblkcl

shuaier

有很多图块必须炸开后才能改色，这个程序不知道可不可以，下载试一试！

my_autocad

二楼的那个程序不理想,基本上不能改色,很多图块无法改到指定的色,但我还是要谢谢
建议去看HCAD,的图块改色功能,能做到那种地步,就算成功了,谢谢

武陵山人

最初由 my_autocad 发布
[B]二楼的那个程序不理想,基本上不能改色,很多图块无法改到指定的色,但我还是要谢谢
建议去看HCAD,的图块改色功能,能做到那种地步,就算成功了,谢谢 [/B]

3楼的程序很好用，没有问题你可以试试。

武陵山人

这是我电脑中的另一个改块颜色的程序

my_autocad

三楼的程序还是好用哈,如果能有七楼的程序那就更好了,谢谢大家,七楼的兄弟能不能把你的程序传上来呀

zxmmelly

生成块之前把要组成块的物体的颜色改为BYBLOCK，再生成块，可以随便改颜色的呀，不用编程序吧！

LMCC

能改变层更好,

zxdvip

2楼的，怎麽输入命令，选择图块后没反应

tgh56

将3楼的程序改成7楼的模式

(DEFUN C:UPDBLKCL (/ BLK CBL CBL2 C ACL ALY NLY NCL)
  (PROMPT "\n选择要改颜色的块:")
  (SETQ SS (SSGET '((0 . "INSERT"))))
  (if (/= ss nil)
    (progn
      (setq C (acad_colordlg 3))
      (if (/= c nil)
        (progn
          (SETQ K 0)
          (WHILE (< K (SSLENGTH SS))
            (setq
              CBL (tblsearch
                    "BLOCK"
                    (CDR (ASSOC 2 (ENTGET (SETQ BLK (SSNAME SS K)))))
                  )
            )
            (SETQ CBL2 (CDR (ASSOC -2 CBL)))
            (WHILE (BOUNDP 'CBL2)
              (SETQ EE (ENTGET CBL2))
              (SETQ NCL (CONS 62 C))
              (SETQ ACL (ASSOC 62 EE))
              (IF (= ACL nil)
                (SETQ NEWE (APPEND EE (LIST NCL)))
                (SETQ NEWE (SUBST NCL ACL EE))
              )
              (ENTMOD NEWE)
              (SETQ CBL2 (ENTNEXT CBL2))
            )
            (ENTUPD BLK)
            (SETQ K (1+ K))
          )
        )
      )
    )
  )
  (princ)
)