[求助]修改所有图元颜色

sf117

我需要将 一个地区的地形图全部变为白色，由于图形比较大，要是全部选中然后再选择白色的话电脑肯定会死机，所以我写了一个小程序，就是修改所以图元的组码（62 .  ？）变为（62 .  7），这样运行不会死机，而且还挺快的，但是运行结束后我发现有些图元没有变为白色，我检查看了一下，其中 外部参照 的块是改不了颜色的，但是还有一种情况就是某一个图层中的所以图元颜色都还是随层，并没有变为白色，然后我用 entget 得到其这个层中的图元的组码来检查，发现这些图元的组码里竟然没有 （62 . ？）这一项，我用 （assoc  图元 62 ）去查找也没有！

请问各位大侠是啥原因呀？

图形还在单位，下次我过来再把图形上传上来呀！希望各位指点指点！！！

 

Andyhon

图元颜色若随层则没有 (62 . x)
所以得用 Append 添加,而非 Subst

sf117

谢谢 Andyhon 的指点，确实增加上去就可以拉！那我现在对于有颜色的图元，要把它们颜色都改为 随层 那应该用什么函数把（62 . X）删除呢？我找不到删除的函数，技术太差了，麻烦再指点一下！多谢

Andyhon

;; bylayer
((0 . "CIRCLE") (330 . <Entity name: 7ef9ecb8>) (5 . "B3")
(100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0")
(100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 10.0) (210 0.0 0.0 1.0))

;; append 后
((0 . "CIRCLE") (330 . <Entity name: 7ef9ecb8>) (5 . "B3")
 (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (62 . 150)       ; <==== 62 . x
 (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 10.0) (210 0.0 0.0 1.0))

;; 62 . x   ===>  62 . 256    { 256 = Bylayer}
((-1 . <Entity name: 7ef9ef98>) (0 . "CIRCLE") (330 . <Entity name: 7ef9ecb8>)
(5 . "B3") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (62 . 256)
(100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 10.0) (210 0.0 0.0 1.0))
;; Subst 后传回

;; 下次 entget 传回
((0 . "CIRCLE") (330 . <Entity name: 7ef9ecb8>) (5 . "B3")
(100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0")
(100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 10.0) (210 0.0 0.0 1.0))

Andyhon

;; bylayer
((0 . "CIRCLE") (330 . <Entity name: 7ef9ecb8>) (5 . "B3")
(100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0")
(100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 10.0) (210 0.0 0.0 1.0))

;; append 后
((0 . "CIRCLE") (330 . <Entity name: 7ef9ecb8>) (5 . "B3")
 (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (62 . 150)       ; <==== 62 . x
 (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 10.0) (210 0.0 0.0 1.0))

;; 62 . x   ===>  62 . 256    { 256 = Bylayer}
((-1 . <Entity name: 7ef9ef98>) (0 . "CIRCLE") (330 . <Entity name: 7ef9ecb8>)
(5 . "B3") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (62 . 256)
(100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 10.0) (210 0.0 0.0 1.0))
;; Subst 后传回

;; 下次 entget 传回
((0 . "CIRCLE") (330 . <Entity name: 7ef9ecb8>) (5 . "B3")
(100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0")
(100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 10.0) (210 0.0 0.0 1.0))

sf117

Andyhon 回复的精确而又及时，真是太让人感动拉！

my_autocad

这个程序还需要解决以下问题

1、合并所有图层指某一个层上去

2、修改块及外部参照的颜色

哦，有没有源码呢？大家也用用啊

alin

;;; Change all entities to colour white and layer "0" and purge all
;;; Note: Bind all Xrefs and Unlock and thaw all layers if you want it do a better job
;;; By Alvin Lin 28/09/2007
;;;
(defun C:GoWhite (/ doc blks txtstr atts)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (setq blks (vla-get-blocks doc))
  (setvar "CLAYER" "0")
  (vlax-for blk blks
    (vlax-for obj blk
      (vla-put-color obj acWhite)
      (vla-put-layer obj "0")
      (if (= (vla-get-objectName obj) "AcDbMText")
 (progn
   (setq txtstr (vla-get-textstring obj))
   (if (wcmatch txtstr "*\\C#*")
     (vla-put-textstring obj (UnFormat txtstr "C"))
   )
 )
      ) ; if
      (if (= (vla-get-objectName obj) "AcDbBlockReference")
 (if (= (vla-get-hasattributes obj) :vlax-true)
   (progn
     (setq atts (vlax-safearray->list
    (vlax-variant-value (vla-getattributes obj))
         )
     )
     (foreach att atts
       (vla-put-color att acWhite)
       (vla-put-layer att "0")
     )
   )
 ) ;if
      ) ; if

      (if (= (vla-get-objectName obj) "AcDbLeader")
 (vla-put-DimensionLineColor obj acWhite)
      ) ; if
    )
  )
  (vla-purgeall doc)
  (princ)
)

 ; Unformat function written by John Uhden
 ; This version of Unformat has been modified for this application.
 ;
 ; Thank you John.
 ;
 ; -------------------------------------------------
 ;
 ; Primary function to perform the format stripping:
 ; Arguments:
 ;   Mtext   - the text string to be Unformatted
 ;   Formats - a string containing some or all of
 ;             the following characters:
 ;
 ;     A - Alignment
 ;     C - Color
 ;     F - Font
 ;     H - Height
 ;     L - Underscore
 ;     O - Overscore
 ;     P - Linefeed (Paragraph)
 ;     Q - Obliquing
 ;     S - Spacing (Stacking)
 ;     T - Tracking
 ;     W - Width
 ;     ~ - Non-breaking Space
 ;   Optional Formats -
 ;     * - All formats
 ; Returns:
 ;   nil  - if not a valid Mtext object
 ;   Text - the Mtext textstring with none, some, or all
 ;          of the formatting removed, depending on what
 ;          formats were present and what formats were
 ;          specified for removal.
 ;

(defun UnFormat (Mtext Formats / All Format1 Format2 Text Str)
  (and
    Mtext
    Formats
    (= (type Mtext) 'STR)
    (= (type Formats) 'STR)
    (setq Formats (strcase Formats))
    (setq Text "")
    (setq All T)
    (if (= Formats "*")
      (setq Formats "S"
     Format1 "\\[LO`~]"
     Format2 "\\[ACFHQTW]"
     Format3 "\\P"
      )
      (progn
 (setq Format1 ""
       Format2 ""
       Format3 ""
 )
 (foreach item '("L" "O" "~")
   (if (vl-string-search item Formats)
     (setq Format1 (strcat Format1 "`" item))
     (setq All nil)
   )
 )
 (if (= Format1 "")
   (setq Format1 nil)
   (setq Format1 (strcat "\\[" Format1 "]"))
 )
 (foreach item '("A" "C" "F" "H" "Q" "T" "W")
   (if (vl-string-search item Formats)
     (setq Format2 (strcat Format2 item))
     (setq All nil)
   )
 )
 (if (= Format2 "")
   (setq Format2 nil)
   (setq Format2 (strcat "\\[" Format2 "]"))
 )
 (if (vl-string-search "P" Formats)
   (setq Format3 "\\P")
   (setq Format3 nil
  All nil
   )
 )
 T
      )
    )
    (while (/= Mtext "")
      (cond
 ((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[\\{}]")
  (setq Mtext (substr Mtext 3)
        Text  (strcat Text Str)
  )
 )
 ((and All (wcmatch (substr Mtext 1 1) "[{}]"))
  (setq Mtext (substr Mtext 2))
 )
 ((and Format1 (wcmatch (strcase (substr Mtext 1 2)) Format1))
  (setq Mtext (substr Mtext 3))
 )
 ((and Format2 (wcmatch (strcase (substr Mtext 1 2)) Format2))
  (setq Mtext (substr Mtext (+ 2 (vl-string-search ";" Mtext))))
 )
 ((and Format3 (wcmatch (strcase (substr Mtext 1 2)) Format3))
  (if
    (or
      (= " " (substr Text (strlen Text)))
      (= " " (substr Mtext 3 1))
    )
     (setq Mtext (substr Mtext 3))
     (setq Mtext (substr Mtext 3)
    Text (strcat Text " ")
     )
  )
 )
 ((and (vl-string-search "S" Formats)
       (wcmatch (strcase (substr Mtext 1 2)) "\\S")
  )
  (setq Str   (substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
        Text  (strcat Text (vl-string-translate "#^\\" "/^\\" Str))
        Mtext (substr Mtext (+ 4 (strlen Str)))
  )
 )
 (1
  (setq Text  (strcat Text (substr Mtext 1 1))
        Mtext (substr Mtext 2)
  )
 )
      )
    )
  )

  Text

)

my_autocad

恩，程序挺不错的，但在一些文件里有“此类型的 LISP 值不能强制转换成 VARIANT:  7”的提示，不能成功转换

alin

介意把有问题的图传上来吗？也可以发到alin2220@gmail.com