[编程交流] Change Xref Color, Linetype an

(defun C:COLORP    (/ doc col) (vl-load-com) (setq doc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark doc) (mip:layer-status-save) (initget 4) (if (setq col (getint "\nEnter color index: "))   (ChangeAllObjectsColor doc col) ;_ col — color number ) ;_ end of if (mip:layer-status-restore) (vla-endundomark doc) (princ)) ;_ end of defun(defun C:COLORXD    (/ doc col) (vl-load-com) (setq doc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark doc) (mip:layer-status-save) (initget 4) (if (setq col (getint "\nEnter color index: "))   (ChangeAllObjectsColor doc col) ;_ col — color number ) ;_ end of if (mip:layer-status-restore) (vla-endundomark doc) (princ)) ;_ end of defun(defun C:COLORX    (/ doc col) (vl-load-com) (setq doc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark doc) (mip:layer-status-save) (if (setq col (acad_colordlg 7 t))   (ChangeAllObjectsColor doc col) ;_ col — color number ) ;_ end of if (mip:layer-status-restore) (vla-endundomark doc) (princ)) ;_ end of defun(defun C:COLORXREF (/ doc col) (vl-load-com) (alert   "\This lisp change color xref\nONLY ON A CURRENT SESSION" ) ;_ end of alert (setq doc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark doc) (mip:layer-status-save) (if (setq col (acad_colordlg 7 t))   (ChangeXrefAllObjectsColor doc col) ;_ col — color number ) ;_ end of if (mip:layer-status-restore) (vla-endundomark doc) (princ)) ;_ end of defun(defun C:COLORXL (/ doc col) (vl-load-com) (setq doc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark doc) (if (setq col (acad_colordlg 7 t))   (ChangeAllObjectsColor doc col) ;_ col — color number ) ;_ end of if (vla-endundomark doc) (princ)) ;_ end of defun(defun C:COLORXREFL (/ doc col) (vl-load-com) (alert   "\This lisp change color xref\nONLY ON A CURRENT SESSION" ) ;_ end of alert (setq doc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark doc) (if (setq col (acad_colordlg 7 t))   (ChangeXrefAllObjectsColor doc col) ;_ col — color number ) ;_ end of if (vla-endundomark doc) (princ)) ;_ end of defun(defun mip:layer-status-restore    () (foreach item    *MIP_LAYER_LST*   (if    (not (vlax-erased-p (car item)))     (vl-catch-all-apply   '(lambda ()      (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))      (vla-put-freeze        (car item)        (cdr (assoc "freeze" (cdr item)))      ) ;_ end of vla-put-freeze    ) ;_ end of lambda     ) ;_ end of vl-catch-all-apply   ) ;_ end of if ) ;_ end of foreach (setq *MIP_LAYER_LST* nil)) ;_ end of defun(defun mip:layer-status-save () (setq *MIP_LAYER_LST* nil) (vlax-for item (vla-get-layers          (vla-get-activedocument (vlax-get-acad-object))        ) ;_ end of vla-get-layers   (setq *MIP_LAYER_LST*      (cons (list item              (cons "freeze" (vla-get-freeze item))              (cons "lock" (vla-get-lock item))        ) ;_ end of cons        *MIP_LAYER_LST*      ) ;_ end of cons   ) ;_ end of setq   (vla-put-lock item :vlax-false)   (if    (= (vla-get-freeze item) :vlax-true)     (vl-catch-all-apply   '(lambda () (vla-put-freeze item :vlax-false))     ) ;_ end of vl-catch-all-apply   ) ;_ end of if ) ;_ end of vlax-for) ;_ end of defun(defun ChangeXrefAllObjectsColor (Doc Color / tmp txtstr) (vlax-for Blk    (vla-get-Blocks Doc)   (cond     ((or (= (vla-get-IsXref Blk) :vlax-true)      (and    (= (vla-get-IsXref Blk) :vlax-false)       (wcmatch (vla-get-name Blk) "*|*")      ) ;_ end of and      ) ;_ end of or      (vlax-for Obj Blk    (if (and (vlax-write-enabled-p Obj)         (vlax-property-available-p Obj 'Color)        ) ;_ end of and      (vla-put-Color Obj Color)    ) ;_ end of if    (if (and (vlax-write-enabled-p Obj)        (vlax-property-available-p Obj 'TextString)       ) ;_ end of and     (progn       (setq txtstr          (if (vlax-method-applicable-p Obj 'FieldCode)              (vla-FieldCode Obj)              (vlax-get-property Obj 'TextString))         )       (setq tmp 0)        (while (setq tmp (VL-STRING-SEARCH "\\C" txtstr tmp))         (setq txtstr         (vl-string-subst       (strcat (substr txtstr (1+ tmp) 2)(itoa Color) ";")       (substr txtstr (1+ tmp) (- (1+ (VL-STRING-SEARCH ";" txtstr tmp)) tmp))       txtstr       tmp)           )         (setq tmp (+ tmp 3))         )       (vla-put-Textstring Obj txtstr)       )   ) ;_ end of if    (if (and (vlax-write-enabled-p Obj)         (= (vla-get-ObjectName obj) "AcDbBlockReference")         (= (vla-get-HasAttributes obj) :vlax-true)        ) ;_ end of and      (foreach att    (vlax-safearray->list             (vlax-variant-value (vla-GetAttributes obj))           ) ;_ end of vlax-safearray->list        (if (and (vlax-write-enabled-p att)             (vlax-property-available-p att 'Color)        ) ;_ end of and          (vla-put-Color att Color)        ) ;_ end of if      ) ;_ end of foreach    ) ;_ end of if    (if (and (vlax-write-enabled-p Obj)         (wcmatch (vla-get-Objectname Obj) "*Dimension*,AcDb*Leader")        ) ;_ end of and      (progn        (vl-catch-all-apply 'vla-put-ExtensionLineColor (list Obj Color))        (vl-catch-all-apply 'vla-put-TextColor (list Obj Color))        (vl-catch-all-apply 'vla-put-DimensionLineColor (list Obj Color))        (if (vlax-property-available-p Obj 'LeaderLineColor)          (progn        (setq tmp (vla-getinterfaceobject(vlax-get-acad-object)(strcat "AutoCAD.AcCmColor."       (substr (getvar "ACADVER") 1 2))))        (vla-put-colorindex  tmp  Color)        (vl-catch-all-apply 'vla-put-LeaderLineColor (list Obj tmp))        )          )      ) ;_ end of progn    ) ;_ end of if      ) ;_ end of vlax-for     )     ((= (vla-get-IsLayout Blk) :vlax-true)      (vlax-for Obj Blk    (if      (and    (vlax-write-enabled-p Obj)       (vlax-property-available-p Obj 'Color)       (vlax-property-available-p Obj 'Path)       (wcmatch (strcase (vla-get-ObjectName Obj)) "*BLOCK*")      ) ;_ end of and       (vla-put-Color Obj Color)    ) ;_ end of if      ) ;_ end of vlax-for     )     (t nil)   ) ;_cond ) ;_ end of vlax-for (vl-cmdf "_redrawall")) ;_ end of defun(defun ChangeAllObjectsColor (Doc Color / txtstr tmp txt count) (vlax-for Blk    (vla-get-Blocks Doc)   (if    (= (vla-get-IsXref Blk) :vlax-false)     (progn   (setq count 0 txt (strcat "Changed " (vla-get-name Blk)))   (grtext -1 txt)     (vlax-for    Obj Blk   (setq count (1+ count))   (if (zerop(rem count 10))(grtext -1 (strcat txt " : " (itoa count))))   (if (and (vlax-write-enabled-p Obj)        (vlax-property-available-p Obj 'Color)       ) ;_ end of and     (vla-put-Color Obj Color)   ) ;_ end of if   (if (and (vlax-write-enabled-p Obj)        (vlax-property-available-p Obj 'TextString)       ) ;_ end of and     (progn       (setq txtstr          (if (vlax-method-applicable-p Obj 'FieldCode)              (vla-FieldCode Obj)              (vlax-get-property Obj 'TextString))         )       (setq tmp 0)       (while (setq tmp (VL-STRING-SEARCH "\\C" txtstr tmp))         (setq txtstr         (vl-string-subst       (strcat (substr txtstr (1+ tmp) 2)(itoa Color) ";")       (substr txtstr (1+ tmp) (- (1+ (VL-STRING-SEARCH ";" txtstr tmp)) tmp))       txtstr       tmp)           )         (setq tmp (+ tmp 3))         )       (vla-put-Textstring Obj txtstr)       )   ) ;_ end of if   (if (and (vlax-write-enabled-p Obj)        (= (vla-get-ObjectName obj) "AcDbBlockReference")        (= (vla-get-HasAttributes obj) :vlax-true)       ) ;_ end of and     (foreach att (vlax-safearray->list            (vlax-variant-value (vla-GetAttributes obj))              ) ;_ end of vlax-safearray->list       (if    (and (vlax-write-enabled-p att)            (vlax-property-available-p att 'Color)       ) ;_ end of and         (vla-put-Color att Color)       ) ;_ end of if     ) ;_ end of foreach   ) ;_ end of if       (if (and (vlax-write-enabled-p Obj)         (wcmatch (vla-get-Objectname Obj)  "*Dimension*,AcDb*Leader")        ) ;_ end of and      (progn        (vl-catch-all-apply 'vla-put-ExtensionLineColor (list Obj Color))        (vl-catch-all-apply 'vla-put-TextColor (list Obj Color))        (vl-catch-all-apply 'vla-put-DimensionLineColor (list Obj Color))        (if (vlax-property-available-p Obj 'LeaderLineColor)          (progn        (setq tmp (vla-getinterfaceobject(vlax-get-acad-object)(strcat "AutoCAD.AcCmColor."       (substr (getvar "ACADVER") 1 2))))        (vla-put-colorindex  tmp  Color)        (vl-catch-all-apply 'vla-put-LeaderLineColor (list Obj tmp))        )          )      ) ;_ end of progn    ) ;_ end of if     ) ;_ end of vlax-for     )   ) ;_ end of if ) ;_ end of vlax-for(vl-cmdf "_redrawall")) ;_ end of defun