AutoCAD顧問
還沒有註冊嗎...即日起免費註冊,所有最完整的AutoCAD討論、教學及資源都在論壇裡喔~

Join the forum, it's quick and easy

AutoCAD顧問
還沒有註冊嗎...即日起免費註冊,所有最完整的AutoCAD討論、教學及資源都在論壇裡喔~
AutoCAD顧問
Would you like to react to this message? Create an account in a few clicks or log in to continue.
[分享]改所有圖元為單一顏色 Io15011 [分享]改所有圖元為單一顏色 2020-310 [分享]改所有圖元為單一顏色 Oiu15010 [分享]改所有圖元為單一顏色 2020-211 [分享]改所有圖元為單一顏色 Oo-2-110 [分享]改所有圖元為單一顏色 BPl3tjj

[分享]改所有圖元為單一顏色

2 posters

向下

[分享]改所有圖元為單一顏色 Empty [分享]改所有圖元為單一顏色

發表 由 LUCAS_LAI 2021-08-06, 15:25

;;只改變圖元顏色,不改變圖層顏色
;;清楚了解AUTOCAD模型是由圖塊組成
;;即模型空間,圖紙空間皆為圖塊

[回覆可見]


代碼:


(vl-load-com)
(defun C:CH_COLOR_LAI (/      ATT    COL    COLOROBJ  COLUMNS
       DOC    ENT1   HOLDECHO   N  N1 NAME
       OBJ    ROWS   SS    X
      )

;;; 改MTEXT顏色                                
;;; by Luis Esquivel - http://www.draftteam.com
;;; function to scan a mtext and make the color uniform
;;; (put-uniform-mtext-color (vlax-ename->vla-object (car (entsel))) 2)
  (defun PUT-UNIFORM-MTEXT-COLOR (VLA_MTEXT    COLORNUM /
  CONT   ENAME    FLAG     I
  LET   TXT1    TXTSTR
 )

    ;;By LUCAS_LAI "ACAD_PROXY_ENTITY"
    (setq ENAME (vlax-vla-object->ename VLA_MTEXT))
    (setq TXTSTR "")
    (foreach X (entget ENAME)
      (if (or (= (car X) 3)
      (= (car X) 1)
      (= (car X) 304)
  )
 (setq TXTSTR (strcat TXTSTR (cdr X)))
      )
    )
    ;;====================================================
    (setq TXT1 "")
    (setq CONT 1)
    (if (/= TXTSTR "")
      (repeat (strlen TXTSTR)
 (setq LET (substr TXTSTR CONT 1))
 (if (= LET "\\")
  (progn
    (if (= (substr TXTSTR (+ CONT 1) 1) "C")
      (progn
 (setq I (+ CONT 2))
 (while (/= (substr TXTSTR I 1) ";")
  (setq I (1+ I))
 )
 (setq TXT1 (strcat TXT1
   "\\C"
   (itoa COLORNUM)
   ";"
   (substr TXTSTR (+ I 1) 1)
   )
 )
 (setq CONT (+ I 2))
      )
      (setq FLAG t)
    )
  )
  (progn
    (setq TXT1 (strcat TXT1 LET))
    (setq CONT (1+ CONT))
  )
 )
 (if FLAG
  (progn
    (setq TXT1 (strcat TXT1 LET))
    (setq CONT (1+ CONT))
    (setq FLAG NIL)
  )
 )
      )
    )
    (vla-put-textstring VLA_MTEXT TXT1)
    (vla-put-color VLA_MTEXT COLORNUM)
  )

  (defun DO_IT (BLK)
    (vla-put-color BLK COL)
  )

  (setq HOLDECHO (getvar "cmdecho"))
  (setvar "cmdecho" 0)
  (vl-cmdf "_.undo" "BE")
  (if (setq COL (acad_colordlg 7)) ;選顏色
    (progn
      (vl-cmdf "_.-LAYER" "U" "*" "")
      (setq COLOROBJ (vla-getinterfaceobject
       (vlax-get-acad-object)
       (strcat "AutoCAD.AcCmColor."
       (substr (getvar "acadver") 1 2)
       )
     )
      )
      (vla-put-colorindex COLOROBJ COL)
      (setq
 DOC (vla-get-activedocument (vlax-get-acad-object))
      )

      ;|改圖層顏色
  (vlax-for OBJ (vla-get-layers DOC)
    (DO_IT OBJ)
  )
  |;

      ;;把"ACAD_PROXY_ENTITY"炸開
      (setvar 'QAFLAGS 5)
      (if (setq
    SS (ssget "_X"
      (list '(0 . "ACAD_PROXY_ENTITY")
    (cons 410 (getvar "CTAB"))
      )
       )
  )
 (vl-cmdf "_.explode" SS "")
      )
      (setvar 'QAFLAGS 0)

      ;;遍壢圖塊
      (vlax-for BLK (vla-get-blocks DOC) ;圖塊定義
 (vlax-for OBJ BLK ;改圖塊參考顏色
  (if (and (= (vla-get-objectname OBJ) "AcDbBlockReference")
   (= (vla-get-hasattributes OBJ) :vlax-true)
      )
    (mapcar '(lambda (X) ;改圖塊參考屬性顏色
       (setq ATT (vlax-variant-value ((eval X) OBJ)))
       (if (safearray-value ATT)
 (foreach ENT1 (vlax-safearray->list ATT)
   (DO_IT ENT1)
 )
       )
     )
    '(vla-getattributes vla-getconstantattributes)
    )
  )
  (DO_IT OBJ)
  (setq NAME (vla-get-objectname OBJ))

  ;;處理MTEXT,MLEADER中文字
  (if (or (= NAME "AcDbMText")
  (and
    (= NAME "AcDbMLeader")
    (= (vla-get-stylename OBJ) "Standard")
  )
      )
    (PUT-UNIFORM-MTEXT-COLOR OBJ COL)
  )

  ;;處理MLEADER中leaderlinecolor
  (if (= NAME "AcDbMLeader")
    (vl-catch-all-error-p
      (vl-catch-all-apply
 'vla-put-leaderlinecolor
 (list OBJ COL)
      )
    )
  )

  ;;處理HATCH中SOLID--漸層色
  (if (and (= NAME "AcDbHatch")
   (not
     (vl-catch-all-error-p
       (vl-catch-all-apply
 'vla-get-gradientcolor1
 (list OBJ)
       )
     )
   )
      )
    (progn
      (vla-put-gradientcolor1 OBJ COLOROBJ)
      (vla-put-gradientcolor2 OBJ COLOROBJ) ;漸層底色
    )
  )

  ;;   處理表格顏色(只處理了2種)
  ;;   表格還有很多種顏色
  ;;   SetBackgroundColor (2)
  ;;   SetBackgroundColorNone (2)
  ;;   SetCellBackgroundColor (3)
  ;;   SetCellBackgroundColorNone (3)
  ;;   SetCellContentColor (3)
  ;;   SetCellGridColor (4)
  ;;   SetContentColor (2)
  ;;   SetContentColor2 (4)
  ;;   SetGridColor (3)
  ;;   SetGridColor2 (4)

  (if (= NAME "AcDbTable")
    (progn
      (vla-put-regeneratetablesuppressed OBJ :vlax-true)
      (setq COLUMNS (vla-get-columns OBJ))
      (setq ROWS (vla-get-rows OBJ)
    N 0
    N1 0
      )
      (repeat COLUMNS
 (repeat ROWS
  (vla-setcellcontentcolor OBJ N N1 COLOROBJ) ;改內容色
  (setq N (1+ N))
 )
 (setq N 0
      N1 (1+ N1)
 )
      )

      ;;改框色
      ;;使框色可見  
      (vla-setgridvisibility
 OBJ
 (+ achorzbottom    achorzinside     achorztop
   acvertinside    acvertleft     acvertright
  )
 (+ acdatarow acheaderrow actitlerow)
 :vlax-true
      )

      ;;再改框色
      (vla-setgridcolor
 OBJ
 (+ achorzbottom    achorzinside     achorztop
   acvertinside    acvertleft     acvertright
  )
 (+ acdatarow acheaderrow actitlerow)
 COLOROBJ
      )
      (vla-put-regeneratetablesuppressed OBJ :vlax-false)
    )
  )

  ;;處理尺寸顏色(可能有欠一些)
  (if (or (and (> (strlen NAME) 8)
       (= "Dimension"
  (substr NAME (- (strlen NAME) 8))
       )
  )
  (= NAME "AcDbLeader")
      )
    (progn
      (vl-catch-all-error-p
 (vl-catch-all-apply 'vla-put-textcolor (list OBJ COL))
      )
      (vl-catch-all-error-p
 (vl-catch-all-apply
  'vla-put-extensionlinecolor
  (list OBJ COL)
 )
      )
      (vl-catch-all-error-p
 (vl-catch-all-apply
  'vla-put-dimensionlinecolor
  (list OBJ COL)
 )
      )
      (vl-catch-all-error-p
 (vl-catch-all-apply
  'vla-put-textfillcolor
  (list OBJ COL)
 )
      )
    )
  )
 )
      )

      ;;移動一下表格框色才會改變
      (if (setq
    SS (ssget "_X"
      (list '(0 . "ACAD_TABLE")
    (cons 410 (getvar "CTAB"))
      )
       )
  )
 (progn
  (vl-cmdf "_.MOVE" SS "" "NON" "0,0" "NON" "@0.001,0")
  (vl-cmdf "_.MOVE" SS "" "NON" "0,0" "NON" "@-0.001,0")
 )
      )
      (vlax-release-object COLOROBJ)
      (vlax-release-object DOC)
      (vl-cmdf "_.REGENALL")
      (vl-cmdf "_.undo" "e")
      (setvar "cmdecho" HOLDECHO)
    )
  )
  (princ)
)
(princ
  "\nType CH_COLOR_LAI 改所有圖元為單一顏色,By LUCAS_LAI"
)
(princ)

LUCAS_LAI
LUCAS_LAI
一般會員
一般會員

文章總數 : 33
年齡 : 56
來自 : 桃園市
職業 : 工程師
愛好 : 看動漫
個性 : 內向
使用年資 : 25年以上,但最近10年少用
使用版本 : 2011
經驗值 : 381
威望值 : 79
注冊日期 : 2021-05-27
男 摩羯座 龍

http://lucas-lai.ys168.com/

回頂端 向下

[分享]改所有圖元為單一顏色 Empty 回復: [分享]改所有圖元為單一顏色

發表 由 shackle_2005 2021-08-06, 20:07

感謝, 測試
shackle_2005
shackle_2005
初級會員
初級會員

文章總數 : 217
年齡 : 50
來自 : 台中
職業 : 程式設計
愛好 : 音樂
個性 : 隨和
使用年資 : 10 年
使用版本 : 2013
積分 : 3
經驗值 : 5488
威望值 : 322
注冊日期 : 2010-09-20
男 獅子座 豬

回頂端 向下

回頂端


 
這個論壇的權限:
無法 在這個版面回復文章
[分享]改所有圖元為單一顏色 Uos15010 [分享]改所有圖元為單一顏色 BPl3tjj [分享]改所有圖元為單一顏色 Ziao1510 [分享]改所有圖元為單一顏色 Oo-2-110 [分享]改所有圖元為單一顏色 Oooo-110 [分享]改所有圖元為單一顏色 2020-211