;; Alternating Table Background Colour - Lee Mac
(defun c:altback ( / *error* acc col fnc idx obj row sel tmp )
(defun *error* ( msg )
(if (and (= 'vla-object (type acc)) (not (vlax-object-released-p acc)))
(vlax-release-object acc)
)
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(setq col '(215 215 215)) ;; True Colour (r g b) for cell background
(if (setq sel (ssget "_:L" '((0 . "ACAD_TABLE"))))
(if (setq acc (vla-getinterfaceobject (vlax-get-acad-object) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(progn
(apply 'vla-setrgb (cons acc col))
(repeat (setq idx (sslength sel))
(setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
col (vla-get-columns obj)
)
(repeat (setq row (vla-get-rows obj))
(if (zerop (rem (setq row (1- row)) 2))
(setq fnc (lambda ( a b ) (vla-setcellbackgroundcolor obj a b acc)))
(setq fnc (lambda ( a b ) (vla-setcellbackgroundcolornone obj a b :vlax-true)))
)
(repeat (setq tmp col) (fnc row (setq tmp (1- tmp))))
)
)
(vlax-release-object acc)
)
(princ "\nUnable to interface with AcCmColor object.")
)
)
(princ)
)
(vl-load-com) (princ)
;; Alternating Table Background Colour - Lee Mac
;; Modified by Chris Wade 07/11/2018 to ignore Title and Header rows
(defun c:altback ( / *error* acc col fnc idx obj row sel tmp RowType CellStyle1)
(defun *error* ( msg )
(if (and (= 'vla-object (type acc)) (not (vlax-object-released-p acc)))
(vlax-release-object acc)
)
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(setq col '(215 215 215)) ;; True Colour (r g b) for cell background
(if (setq sel (ssget "_:L" '((0 . "ACAD_TABLE"))))
(if (setq acc (vla-getinterfaceobject (vlax-get-acad-object) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(progn
(apply 'vla-setrgb (cons acc col))
(repeat (setq idx (sslength sel))
(setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
col (vla-get-columns obj)
)
(vla-put-regeneratetablesuppressed obj :vlax-true)
(repeat (setq row (vla-get-rows obj))
(setq RowType (vla-getrowtype obj row))
(if (and (zerop (rem (setq row (1- row)) 2)) (/= RowType acHeaderRow) (/= RowType acTitleRow))
(setq fnc (lambda ( a b ) (vla-setcellbackgroundcolor obj a b acc)))
(setq fnc (lambda ( a b ) (vla-setcellbackgroundcolornone obj a b :vlax-true)))
)
(repeat (setq tmp col) (fnc row (setq tmp (1- tmp))))
)
(vla-put-regeneratetablesuppressed obj :vlax-false)
)
(vlax-release-object acc)
)
(princ "\nUnable to interface with AcCmColor object.")
)
)
(princ)
)
(vl-load-com) (princ)
;; Alternating Table Background Colour - Lee Mac
;; Modified by Chris Wade 07/11/2018 to ignore Title and Header rows
(defun c:altback ( / *error* acc col fnc idx obj row sel tmp RowType)
(defun *error* ( msg )
(if (and (= 'vla-object (type acc)) (not (vlax-object-released-p acc)))
(vlax-release-object acc)
)
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(setq col '(215 215 215)) ;; True Colour (r g b) for cell background
(if (setq sel (ssget "_:L" '((0 . "ACAD_TABLE"))))
(if (setq acc (vla-getinterfaceobject (vlax-get-acad-object) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(progn
(apply 'vla-setrgb (cons acc col))
(repeat (setq idx (sslength sel))
(setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
col (vla-get-columns obj)
Rows (vla-get-rows Obj)
RowCt 1
ColCt 1
)
(vla-put-regeneratetablesuppressed obj :vlax-true)
(repeat (setq row (vla-get-rows obj))
(setq RowType (vla-getrowtype obj row))
(if (and (zerop (rem (setq row (1- row)) 2)) (/= RowType acHeaderRow) (/= RowType acTitleRow))
(setq fnc (lambda ( a b ) (if (and (/= (vla-getcellstyle obj a b) "_HEADER") (/= (vla-getcellstyle obj a b) "_TITLE")) (vla-setcellbackgroundcolor obj a b acc) (vla-setcellbackgroundcolornone obj a b :vlax-true))))
(setq fnc (lambda ( a b ) (vla-setcellbackgroundcolornone obj a b :vlax-true)))
)
(repeat (setq tmp col) (fnc row (setq tmp (1- tmp))))
)
(vla-put-regeneratetablesuppressed obj :vlax-false)
)
(vlax-release-object acc)
)
(princ "\nUnable to interface with AcCmColor object.")
)
)
(princ)
)
(vl-load-com) (princ)
so hopefully someone has a simpler way.
My code above account for header rows as well as title rows, but any chance you can share the code for sorting rows? That is something that I kept getting asked for and while I could eventually write my own, why reinvent the wheel?
; Modified by Chris Wade on 07/11/2018 to be able to specify a number of "Total" rows at the bottom of a table to not include in the sorting.
; ACAD_Table Sort by Column
; 1. Use GetCell and collect the rows below (to skip the title and headers)
; 2. Sort by Nth (sort the rows by nth element (column)) using custom sorting function
; Grread not required
; 1. Pick Column To Sort By (only the rows below the picked cell gonna be sorted)
; 2. ACAD_TABLE->Matrix_List
; 3. SortByNth using custom sorting function
; 4. RePopulate ACAD_TABLE using the new Matrix List
(defun C:SortTable ( / SortByNth GetCellVals GetAllTableCells Lst->PopulateAcad_Table *error* osm cell acDoc AllCells FirstHalf SecondHalf FirstHalfVals SecondHalfVals SecondSortedVals TotalRows)
; This could be used to map into the table's cells
; Lee Mac ; https://www.theswamp.org/index.php?topic=52935.msg577618#msg577618
(defun mapncar ( n f l ) (if (< 0 n) (mapcar '(lambda ( x ) (mapncar (1- n) f x)) l) (mapcar 'f l) ) )
; (SortByNth 0 (lambda (L) (SortStringWithNumberAsNumber L)) L)
; This one combines (SortByNth_vl-sort) and (SortByNth_SortingFoo)
; Sort Matrix Assoc List By Nth - by applying list-sorting function as a foo
(defun SortByNth ( n foo L / nL snL )
(setq nL (mapcar '(lambda (x) (nth n x)) L)) ; List of nth atoms to be sorted
(setq snL (apply (function foo) (list nL))) ; List of sorted nth atoms
(vl-sort L '(lambda (a b) (< (vl-position (nth n a) snL) (vl-position (nth n b) snL))))
); SortByNth
(defun GetCellVals (L) (mapcar (function (lambda (x) (apply 'vla-GetText x))) L))
(defun GetAllTableCells ( obj TotalRows / col lst row tmp ) ; Based on Lee Mac's Example
(repeat (setq row (- (vla-get-rows obj) TotalRows)) (repeat (setq row (1- row) col (vla-get-columns obj)) (setq tmp (cons (list obj row (setq col (1- col))) tmp)) )
(setq lst (cons tmp lst) tmp nil)
)
lst
); defun GetAllTableCells
(defun Lst->PopulateAcad_Table ( o L / r c ) ; Based on Lee Mac's Example
(cond
( (and (eq (type o) 'VLA-OBJECT) (eq (vla-get-ObjectName o) "AcDbTable"))
(vla-put-RegenerateTableSuppressed o :vlax-true)
(setq r 0) (foreach itm L (setq c 0) (foreach x itm (vla-SetCellValue o r c x) (setq c (1+ c)) ) (setq r (1+ r)) )
(vla-put-RegenerateTableSuppressed o :vlax-false)
)
); cond
); defun Lst->PopulateAcad_Table
(defun *error* ( m )
(and osm (setvar 'osmode osm))
(and m (princ m)) (princ)
); defun *error*
(and
(setq osm (getvar 'osmode))
(setvar 'osmode 0)
); and
(cond
( (not (setq cell (GetTableCell "Specify Table Cell to Start Sorting From By its Column"))) (princ "\nTable Cell not specified.") ) ; (o r c)
(T
(setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object))) (or (vla-EndundoMark acDoc) (vla-StartUndoMark acDoc))
(setq TotalRows (getint "\nEnter number of 'Total Rows' at bottom of table that should not be sorted (0 for none):"))
(setq AllCells (GetAllTableCells (car cell) TotalRows))
(setq FirstHalf (vl-remove-if-not (function (lambda (x) (> (cadr cell) (cadar x)))) AllCells))
(setq SecondHalf (vl-remove-if-not (function (lambda (x) (<= (cadr cell) (cadar x)))) AllCells)) ; To be sorted
(setq FirstHalfVals (mapcar 'GetCellVals FirstHalf))
(setq SecondHalfVals (mapcar 'GetCellVals SecondHalf))
(setq SecondSortedVals (SortByNth (caddr cell) (lambda (L) (SortStringWithNumberAsNumber L)) SecondHalfvals))
(and (progn (initget "Yes No") (= "Yes" (cond ((getkword "\nReverse sorting? [Yes/No] <No>: ")) ("No")))) (setq SecondSortedVals (reverse SecondSortedVals)))
(vla-put-RegenerateTableSuppressed (car cell) :vlax-true)
(Lst->PopulateAcad_Table (car cell) (append FirstHalfVals SecondSortedVals))
(vla-put-RegenerateTableSuppressed (car cell) :vlax-false)
(vla-EndundoMark acDoc)
); T
); cond
(*error* nil)
(princ)
); defun
; http://www.theswamp.org/index.php?topic=16564.msg207439#msg207439
;; Usage (SortStringWithNumberAsNumber '("A9" "A1" "A10" "B11" "B2" "B05"))
;; Return ("A1" "A9" "A10" "B2" "B05" "B11")
(defun SortStringWithNumberAsNumber (ListOfString)
;;; Function Normalize (add 0 befor number) number in string
;;; Count normalize symbols set in variable count
(defun NormalizeNumberInString (str / ch i pat ret count buf)
(setq i 0
pat '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
ret ""
count 4 ;_Count normalize symbols
) ;_ end of setq
(while (/= (setq ch (substr str (setq i (1+ i)) 1)) "")
(if (vl-position ch pat)
(progn
(setq buf ch) ;_ end of setq
(while
(vl-position (setq ch (substr str (setq i (1+ i)) 1)) pat)
(setq buf (strcat buf ch))
) ;_ end of while
(while (< (strlen buf) count) (setq buf (strcat "0" buf)))
(setq ret (strcat ret buf))
) ;_ end of progn
) ;_ end of if
(setq ret (strcat ret ch))
) ;_ end of while
ret
) ;_ end of defun
(mapcar '(lambda (x) (nth x ListOfString)) (vl-sort-i (mapcar 'NormalizeNumberInString ListOfString) '<))
) ;_ end of defun
; (if (setq cell (GetTableCell nil)) (apply '(lambda (o r c) (vlax-invoke o 'GetCellValue r c)) cell)) ; will return the vlax-variant-value
; (if (setq cell (GetTableCell nil)) (apply 'vla-GetCellValue cell)) ; will return variant
; _$ (GetTableCell nil) -> (#<VLA-OBJECT IAcadTable 0000010540176cd8> 2 2) ; Example, returns a list of (o r c)
(defun GetTableCell ( msg / HitTest GetAcadTableObjects atL Stop p r )
(defun HitTest ( pt lst ) ; Lee Mac
(if (and (vl-consp pt) (vl-every 'numberp pt))
(vl-some
(function
(lambda ( o / r c )
(if (eq :vlax-true (vla-HitTest o (vlax-3D-point (trans pt 1 0)) (vlax-3D-point (trans (getvar 'VIEWDIR) 1 0)) 'r 'c)) (list o r c) )
)
)
lst
); vl-some
); if
); defun HitTest
(defun GetAcadTableObjects ( / SS i L )
(if (setq SS (ssget "X" (list '(0 . "ACAD_TABLE") (if (= 1 (getvar 'cvport)) (cons 410 (getvar 'ctab)) '(410 . "Model")))))
(repeat (setq i (sslength SS)) (setq L (cons (vlax-ename->vla-object (ssname SS (setq i (1- i)))) L)) )
); if
); defun GetAcadTableObjects
(if (setq atL (GetAcadTableObjects))
(while (not Stop)
(initget "eXit") (setq p (getpoint (strcat "\n" (if (eq 'STR (type msg)) msg "Specify Table Cell") " or [eXit]: ")))
(cond
( (eq 'STR (type p)) (setq Stop T) )
( (not (setq r (HitTest p atL))) (princ "\nInvalid point.") )
(T (setq Stop T))
); cond
); while
(princ "\nNo ACAD_TABLEs found in this drwaing.")
); if
r
); defun GetTableCell
This is Better :Code - Auto/Visual Lisp: [Select]