Lunch time fun : RLX Multi-Tokkie

[rlx]

; RLX 20 may 2019 - Multi-tokkie dialog
; reason for writing is upcoming server change and have to scan server for drawings with xref and remove xref path.
; Each plant area has folder (like '0000' '0100' etc.) Each plant folder has a few dozen subfolders. Some subfolders
; will contain drawings with xrefs for certain and some will certainly not (like loops)
;
; Ultimate goal was to be able to put as much of (selectable) information in one dialog as possible.
; To be able to do this dialog can be resized. Either with the buttons or with mnemonic keys.
; You can use L & M for Less or More rows (min 5 rows , max 25) and N for next page or P for previous page if all
; the information is too big to fit in one screen.
; I have set width for dialog to 120 (max-dialog-width) but adjust as you see fit.
;
; hope examples c:t1 & c:t2 are self explaining
;

; max-num-of-rows / start-column / result-list -> global vars needed because dialog will be recreated if resized
(defun create_multi_tokkie_dialog ( %lst %dflt $msg / max-dialog-width dialog-fn dialog-fp dialog-id action-list chop-list
                                                      max-str-len number-of-columns max-num-of-colums-per-dialog)
  ; limit of the maximum size of dialog and maximum rows per column
  (setq max-dialog-width 120)
  (or max-num-of-rows (setq max-num-of-rows 10))
  ; start column will be reset when number or rows is changed
  (or start-column (setq start-column 0))
  (or result-list (setq result-list (mapcar ''((x)(cons x "0")) %lst)))
  ; chop up list in columns where each column has max-num-of-rows
  (setq chop-list (chop %lst max-num-of-rows) max-str-len (apply 'max (mapcar 'strlen %lst))
        number-of-columns (length chop-list)
        max-num-of-colums-per-dialog (fix (/ max-dialog-width (+ max-str-len 5))));5 = togglewidth (guess)
  ; open dialog for writing
  (setq dialog-fp (open (setq dialog-fn (vl-filename-mktemp ".dcl")) "w"))
  ; write header
  (write-line (strcat "chop:dialog {label=\"" $msg "\";") dialog-fp)
  ; write body start
  (write-line ":row {" dialog-fp)
  (setq column-index start-column)
  (if (> (setq n (+ start-column number-of-columns)) max-num-of-colums-per-dialog)
    (setq n max-num-of-colums-per-dialog))
  (repeat n
    (setq collie (nth column-index chop-list) l (length collie) )
    (write-line ":column {alignment=top;" dialog-fp)
    (foreach item collie
      (write-line (strcat ":toggle {label=\"" item "\";key=\"tg_" item "\";}") dialog-fp)
      (setq action-list (cons item action-list)); used later by action_tile's
    )
    (repeat (- max-num-of-rows l)(write-line ":row {height=1.5;}" dialog-fp))
    (write-line "}" dialog-fp)
    (setq column-index (1+ column-index))
  )

  ; write body end
  (write-line "}" dialog-fp)

  ; write footer
  (write-line
    (strcat "spacer;:concatenation {alignment=centered;children_fixed_width=true;"
            ":button{label=\"&Less Rows\";key=\"bt_less_rows\";mnemonic=\"L\";}"
            ":button{label=\"&More Rows\";key=\"bt_more_rows\";mnemonic=\"M\";}"
            ":button{label=\"&Prev.Page\";key=\"bt_prev_page\";mnemonic=\"P\";}"
            ":button{label=\"&Next Page\";key=\"bt_next_page\";mnemonic=\"N\";}}") dialog-fp)
  (write-line
    (strcat "spacer;:concatenation {alignment=centered;:button{label=\"Select All\";key=\"bt_select_all\";}"
            ":button{label=\"Clear All\";key=\"bt_clear_all\";}:button{label=\"Default\";key=\"bt_default\";}"
            "spacer;spacer;ok_cancel;}}") dialog-fp)

  (and (not (setq dialog-fp (close dialog-fp)))
       (< 0 (setq dialog-id (load_dialog dialog-fn)))
       (new_dialog "chop" dialog-id)
       (progn
         (mapcar ''((x)(set_tile (strcat "tg_" (car x)) (cdr x))) result-list)
         (mapcar ''((x)(action_tile (strcat "tg_" (car x)) "(update_tile $key $value)")) result-list)
         (action_tile "accept" "(done_dialog 1)")
         (action_tile "cancel" "(done_dialog 0)")
         (action_tile "bt_clear_all" "(set_all_toggles 0)")
         (action_tile "bt_select_all" "(set_all_toggles 1)")
         (action_tile "bt_less_rows" "(if (change_rows -1)(done_dialog 2))")
         (action_tile "bt_more_rows" "(if (change_rows +1)(done_dialog 2))")
         (action_tile "bt_prev_page" "(if (change_page -1)(done_dialog 3))")
         (action_tile "bt_next_page" "(if (change_page +1)(done_dialog 3))")
         (action_tile "bt_default" "(apply_defaults)")
         (setq drv (start_dialog))(unload_dialog dialog-id)(vl-file-delete dialog-fn)
       )
  )
  (cond ((or (= drv 2)(= drv 3))(create_multi_tokkie_dialog %lst %dflt $msg)))
  (princ)
)
(defun release_me (l) (mapcar '(lambda (x)
  (if (and (= 'vla-object (type x))(not (vlax-object-released-p x)))(vlax-release-object x))(set (quote x) nil)) l))

(defun set_all_toggles (i) (foreach tg action-list (set_tile (strcat "tg_" tg) (itoa i)))
  (setq result-list (mapcar ''((x)(cons x (itoa i))) %lst)))

(defun change_rows (i)
  (if (< 4 (+ max-num-of-rows i) 25)
    (progn (setq max-num-of-rows (+ max-num-of-rows i))(setq start-column 0)) nil))

(defun change_page (i)
  (if (and (<= 0 (+ start-column i))(<= (+ start-column i) (- number-of-columns max-num-of-colums-per-dialog )))
    (setq start-column (+ start-column i)) nil))

(defun update_tile ($k $v)
  (setq result-list (subst (cons (substr $k 4) $v) (assoc (substr $k 4) result-list) result-list)))

(defun apply_defaults ()
  (if (and (vl-consp result-list) (vl-consp %dflt))
    (foreach item %dflt
      (if (assoc item result-list)
        (progn (setq result-list (subst (cons item "1") (assoc item result-list) result-list))
          (set_tile (strcat "tg_" item) "1")))))
)

; (lst-strcat '("A" "B" "C") "+") -> "A+B+C"
(defun lst-strcat (%l $s)
  (apply 'strcat (cdr (apply 'append (mapcar (function (lambda (x) (list $s x))) %l)))))

(defun string-p (s)(if (= (type s) 'str) t nil))


; (chop '(1 2 3 4 5 6 7 8 9) 4) -> '((1 2 3 4) (5 6 7  (9))
(defun chop (l n / tl fl) (cond ((or (null l) (null n) (not (vl-consp l)) (not (numberp n)))) ((< (length l) n) l)
  (t (while (vl-consp l) (setq tl (cons (car l) tl))(if (= n (length tl))(setq fl (cons tl fl) tl nil))
       (if (and (not (vl-consp (setq l (cdr l))))(vl-consp tl))(setq fl (cons tl fl)))))) (reverse (mapcar 'reverse fl)))

; this just a test function to be able to see the output. Actual output is saved in 'result-list' (list of strings)
(defun show-result (%l / tmp s)
  (cond
    ((or (not (vl-consp %l)) (vl-every ''((x)(= (cdr x) "0")) %l)) "None")
    ((vl-every ''((x)(= (cdr x) "1")) %l) "All")
    (t (foreach x %l (if (= (cdr x) "1")(setq tmp (cons (car x) tmp))))
     (if (vl-consp tmp)(setq s (lst-strcat (reverse tmp) "+")))
     (cond ((not (string-p s)) "Nothing selected")
           ; use this if you need to check length of output
           ; ((> (strlen s) 100) "List too long to show")
           (t s)))
  )
)

(defun GetFolder ( msg / fl sh)
  (if (and (setq sh (vlax-create-object "Shell.Application")) (setq fl (vlax-invoke sh 'browseforfolder 0 msg 0 "")))
    (setq fl (vlax-get-property (vlax-get-property fl 'self) 'path))(setq fl nil))(release_me (list sh)) fl)


; example for subfolder selection
(defun c:t1 ( / fol lst dflt max-num-of-rows start-column result-list)
  (setq dflt '("E" "FGA" "G" "GE" "GX" "HV" "S" "TC" "U"))
  (if (and (setq fol (getfolder "Targetfolder"))
           (vl-consp (setq lst (vl-remove-if '(lambda (x)(member x '("." ".."))) (vl-directory-files fol nil -1)))))
    (progn (create_multi_tokkie_dialog lst dflt "Select subfolders") (alert (show-result result-list))))
  (princ)
)


(defun c:t2 ( / lst dflt max-num-of-rows start-column result-list)
  ; just some test data
  (setq lst '("A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
              "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "AA" "AB" "AC" "AD" "AE" "AF" "AG" "AH" "AI" "AJ" "AK" "AL" "AM"
              "AN" "AO" "AP" "AQ" "AR" "AS" "AT" "AU" "AV" "AW" "AX" "AY" "AZ"))
  (setq dflt '("A" "B" "AA" "AB" "5" "6"))
  (create_multi_tokkie_dialog lst dflt "Make your selection")
  (alert (show-result result-list))
  (princ)
)

 

Edited May 20, 2019 by rlx
oops forgot one sub 'release_me' - added