Le portail francophone de la géomatique

; str2lst
;; Transforme un chaine avec séparateur en liste de chaines
;;
;; Arguments
;; str : la chaine à transformer en liste
;; sep : le séparateur
;;
;; Exemples
;; (str2lst "a b c" " ") -> ("a" "b" "c")
;; (str2lst "1,2,3" ",") -> ("1" "2" "3")
(defun str2lst (str sep / pos)
    (if (setq pos (vl-string-search sep str))
        (cons
            (substr str 1 pos)
            (str2lst (substr str (+ (strlen sep) pos 1)) sep)
        )
        (list str)
    )
)
;; ListBox (gile)
;; Boite de dialogue permettant un ou plusieurs choix dans une liste
;;
;; Arguments
;; title : le titre de la boite de dialogue (chaîne)
;; msg ; message (chaîne), "" ou nil pour aucun
;; keylab : une liste d'association du type ((key1 . label1) (key2 . label2) ...)
;; flag : 0 = liste déroulante
;; 1 = liste choix unique
;; 2 = liste choix multipes
;;
;; Retour : la clé de l'option (flag = 0 ou 1) ou la liste des clés des options (flag = 2)
;;
;; Exemple d'utilisation
;; (listbox "Présentation" "Choisir une présentation" (mapcar 'cons (layoutlist) (layoutlist)) 1)
(defun ListBox (title msg keylab flag / tmp file dcl_id choice)
    (setq
        tmp (vl-filename-mktemp "tmp.dcl")
        file (open tmp "w")
    )
    (write-line
        (strcat "ListBox:dialog{label=\"" title "\";")
        file
    )
    (if (and msg (/= msg ""))
        (write-line (strcat ":text{label=\"" msg "\";}") file)
    )
    (write-line
        (cond
            ((= 0 flag) "spacer;:popup_list{key=\"lst\";")
            ((= 1 flag) "spacer;:list_box{key=\"lst\";")
            (T "spacer;:list_box{key=\"lst\";multiple_select=true;")
        )
        file
    )
    (write-line "}spacer;ok_cancel;}" file)
    (close file)
    (setq dcl_id (load_dialog tmp))
    (if (not (new_dialog "ListBox" dcl_id))
        (exit)
    )
    (start_list "lst")
    (mapcar 'add_list (mapcar 'cdr keylab))
    (end_list)
    (action_tile
        "accept"
        "(or (= (get_tile \"lst\") \"\")
            (if (= 2 flag)
                (progn
                    (foreach n (str2lst (get_tile \"lst\") \" \")
                        (setq choice (cons (nth (atoi n) (mapcar 'car keylab)) choice))
                    )
                    (setq choice (reverse choice))
                )
                (setq choice (nth (atoi (get_tile \"lst\")) (mapcar 'car keylab)))
            )
        )
        (done_dialog)"
    )
    (start_dialog)
    (unload_dialog dcl_id)
    (vl-file-delete tmp)
    choice
)
(defun c:operate_OD ( / sel_tbl def_tbl l_field sel1_field sel2_field op_field sel3_field js n ent)
    (setq sel_tbl (listbox "Donnée d'objet" "Choisir la table de données d'objet" (mapcar 'cons (ade_odtablelist) (ade_odtablelist)) 1))
    (cond
        (sel_tbl
            (setq
                def_tbl (ade_odtabledefn sel_tbl)
                l_field (mapcar 'cdr (mapcar '(lambda (x) (assoc "ColName" x)) (cdaddr def_tbl)))
                sel1_field (listbox "Champ de donnée" "Choisir le 1er champ de donnée" (mapcar 'cons l_field l_field) 1)
                sel2_field (listbox "Champ de donnée" "Choisir le 2ème champ de donnée" (mapcar 'cons l_field l_field) 1)
            )
            (cond
                ((and
                    sel1_field
                    sel2_field
                    (member (cdr (assoc "ColType" (assoc (cons "ColName" sel1_field) (cdaddr def_tbl)))) '("Real" "Integer"))
                 )
                    (setq
                        op_field (listbox "Opérateur arithmétique" "Choisir l'opérande" '(("+ " . "+ ") ("- " . "- ") ("* " . "* ") ("/ " . "/ ")) 1)
                        sel3_field (listbox "Champ de donnée RESULTAT" "Choisir le 3éme champ de donnée à inscrire" (mapcar 'cons l_field l_field) 1)
                    )
                    (cond
                        ((and
                            op_field
                            sel3_field
                            (member (cdr (assoc "ColType" (assoc (cons "ColName" sel3_field) (cdaddr def_tbl)))) '("Real" "Integer"))
                         )
                            (setq js (ssget "_X"))
                            (cond
                                (js
                                    (repeat (setq n (sslength js))
                                        (if (member sel_tbl (ade_odgettables (setq ent (ssname js (setq n (1- n))))))
                                            (ade_odsetfield ent sel_tbl sel3_field 0
                                                (eval
                                                    (list
                                                        (read op_field)
                                                        (ade_odgetfield ent sel_tbl sel1_field 0)
                                                        (ade_odgetfield ent sel_tbl sel2_field 0)
                                                    )
                                                )
                                            )
                                        )
                                    )
                                )
                            )
                        )
                        (T (princ "\nLe champs résultat ne conviennent pas; doit être un réel ou entier"))
                    )
                )
                (T (princ "\nLes champs sources ne conviennent pas; doivent être des réels ou entiers"))
            )
        )
    )
    (prin1)
)