Quelques SUBs, en vrac

' SUB_Bib.bas collection de SUBs
' Si résultats en retour, ils sont rendus dans des variables déclarées localement
' ------------------------------------------------------------------------------
' FONCTIONS PANORAMIC
' - Objets() définition d'un objet Panoramic
' FONCTIONS CHAINES ET TEXTES
' - InstrX() recherche d'une chaîne à partir d'un index donné
' - Rinstr() recherche d'une chaîne à partir de la fin
' - Compchain() comparaison de deux chaînes (<, = ou >)
' - Extract() extraction des éléments d'une chaîne avec séparateurs
' - TriAsc() Tri d'un fichier selon l'ordre Ascii strict
' - Replace() remplacer un mot par un autre dans une chaîne
' - Reverse() inverser une chaîne tête-bêche
' - Misfoc() formatage fichier à un nombre donné de caractères par ligne
' - Misfop() formatage fichier à un nombre donné de pixels par ligne
' FONCTIONS DISQUES/FICHIERS
' - Volumes() Liste des volumes monés
' - Codeco() Crypter/décrypter un fichier avec une clé donnée
' - File2String() lire un fichier quelconque dans une chaîne
' - String2File() écrire une chaîne dans un fichier
' FONCTIONS DATES
' - Qpap() calcul des quantièmes de Pâques, Ascension, Pentecôte
' - Dateserial() conversion d'une date en date série
' - Joursem() calcul du jour de la semaine
' - Jmq() calcul du quantième de l'année en fonction du jour et du mois
' - Qjm() calcul du jour et du mois en fonction du quantième de l'année
' FONCTIONS IMAGES
' - CreBmp() création d'une image Bmp
' - DimBmp() dimensions d'une image Bmp
' - BmpInfos() infos d'un fichier image Bmp
' - ImgInfos() infos d'un fichier image: dimensions et date
' - Jpg2Bmp() conversion d'une image Jpg en Bmp
' - Posxy() calcul du pointeur d'un bmp correspondant aux coordonnées données
' - RGB2Val() conversion de données RGB en valeur
' - Val2RGB() conversion d'une valeur en données RGB
' FONCTIONS MATHÉMATIQUES
' - VMKL()
' - CVL
' - Est_Divisible()
' FONCTIONS DIVERSES
' - Nomcourt() conversion d'un path long en path court (sans espaces)
' - Exprog() exécution d'un programme externe sans la fenêtre noire ms-dos
' ------------------------------------------------------------------------------

RGB2Val(255,255,255)
message str$(rs_cl%)
Val2RGB(16777215)
message str$(rs_cr%)+","+str$(rs_cg%)+","+str$(rs_cb%)
end
' =========================== FONCTIONS PANORAMIC ==============================
SUB Objets(obj$,No%,V%,T%,L%,W%,H%,P%)
' Définition d'un objet Panoramic:
' obj$= nom de l'objet, No% son numéro, V%=0 objet caché
' T%,L%,W%,H% Top,Left,Width,Height, P% <> 0 numéro du parent
DIM_LOCAL indx%
IF VARIABLE("T_obj$") = 0
  DIM T_obj$
  T_obj$="01SCENE3D;02BUTTON;03EDIT;04MEMO;05COMBO;06ALPHA;07FORM;08LIST;09PICTURE;"
  T_obj$=T_obj$+"10CHECK;11OPTION;12MAIN_MENU;13SUB_MENU;14SOUND;15MOVIE;16TRACKBAR;"
  T_obj$=T_obj$+"17OPEN_DIALOG;18SAVE_DIALOG;198SCROLL_BAR;20PROGRESS_BAR;21SPIN;"
  T_obj$=T_obj$+"22GRID;23CONTAINER;24;25;26DLIST;27SCENE2D;28TIMER;29;30;31;"
  T_obj$=T_obj$+"32CONTAINER_OPTION;33;34;35;36;37;38;39;40;41IMAGE;"
END_IF
indx% = INSTR(T_obj$,UPPER$(obj$)+";"): indx% = VAL(MID$(T_obj$,indx%-2,2))
SELECT indx%
    CASE 1: SCENE3D No%
    CASE 2: BUTTON No%
    CASE 3: EDIT No%
    CASE 4: MEMO No%
    CASE 5: COMBO No%
    CASE 6: ALPHA No%
    CASE 7: FORM No%
    CASE 8: LIST No%
    CASE 9: PICTURE No%
    CASE 10: CHECK No%
    CASE 11: OPTION No%
    CASE 12: MAIN_MENU No%
    CASE 13: SUB_MENU No%
    CASE 14: SOUND No%
    CASE 15: MOVIE No%
    CASE 16: TRACK_BAR No%
    CASE 17: OPEN_DIALOG No%
    CASE 18: SAVE_DIALOG No%
    CASE 19: SCROLL_BAR No%
    CASE 20: PROGRESS_BAR No%
    CASE 21: SPIN No%
    CASE 22: GRID No%
    CASE 23: CONTAINER No%
    CASE 26: DLIST No%
    CASE 27: SCENE2D No%
    CASE 28: TIMER No%
    CASE 32: CONTAINER_OPTION No%
    CASE 41: IMAGE No%
END_SELECT
IF T% > 0 THEN TOP No%,T%
IF L% > 0 THEN LEFT No%,L%
IF W% > 0 THEN WIDTH No%,W%
IF H% > 0 THEN HEIGHT No%,H%
IF P% > 0 THEN PARENT No%,P%
IF V% = 0 THEN HIDE No%
END_SUB
' ------------------------------------------------------------------------------
' ====================== FONCTIONS CHAINES ET TEXTES ===========================
SUB InstrX(ch$,sq$,xd%)
' recherche de sq$ dans ch$ à partir de xd% (~Instr indexé) -> rs_k%
DIM_LOCAL a_instrx$
IF VARIABLE("rs_k%") = 0 THEN DIM rs_k%
a_instrx$ = MID$(ch$, xd%, LEN(ch$)-xd%+1)
rs_k%% = INSTR(a_instrx$, sq$)
IF rs_k%% > 0 THEN rs_k%% = rs_k%+xd%-1
END_SUB
' ------------------------------------------------------------------------------
SUB Rinstr(ch$,sq$)
' recherche de sq$ dans ch$ à partir de la fin (~Instr inversé) -> rs_k%
IF VARIABLE("rs_k%") = 0 THEN DIM rs_k%
FOR rs_k% = LEN(ch$)-LEN(sq$)+1 TO 1 STEP -1
    IF MID$(ch$, rs_k%, LEN(sq$)) = sq$ THEN EXIT_FOR
NEXT rs_k%
END_SUB
' ------------------------------------------------------------------------------
SUB Compchain(ch1$,ch2$)
' comparaison de deux chaînes ascii (Tri ascii strict)
' résultat: =-1 si ch1$<ch2$, =0 si ch1$=ch2$, =1 si ch1$>ch2$ -> rs_di%
DIM_LOCAL i_comp%, i_vl1%, i_vl2%
IF VARIABLE("rs_di%") = 0 THEN DIM rs_di%
rs_di% = 0
FOR i_comp% = 1 TO LEN(ch1$)
    i_vl1% = ASC(MID$(ch1$,i_comp%,1))
    i_vl2% = ASC(MID$(ch2$,i_comp%,1))
    IF i_vl1% < i_vl2% THEN rs_di% = -1: EXIT_FOR
    IF i_vl1% > i_vl2% THEN rs_di% = 1: EXIT_FOR
NEXT i_comp%
IF rs_di% = 0 AND LEN(ch2$) > LEN(ch1$) THEN rs_di% = -1
END_SUB
' ------------------------------------------------------------------------------
SUB Extract(ch$, sep$)
' extraire les éléments d'une chaîne avec séparateurs sep$ (par exemple ;)
' résultats dans rs_el$(), nombre d'éléments dans rs_nx%
IF VARIABLE("rs_el$") = 0 THEN DIM rs_el$(50)
IF VARIABLE("rs_nx%") = 0 THEN DIM rs_nx%
DIM_LOCAL a_ex$, r_ex$, i_ex%
rs_nx% = 0
a_ex$ = ch$: r_ex$ = "": i_ex% = INSTR(a_ex$, sep$)
WHILE i_ex% > 0
    rs_nx% = rs_nx%+1: rs_el$(rs_nx%) = LEFT$(a_ex$, i_ex%-1)
    a_ex$ = MID$(a_ex$, i_ex%+LEN(sep$), LEN(a_ex$)-i_ex%)
    i_ex% = INSTR(a_ex$, sep$)
END_WHILE
rs_nx% = rs_nx%+1: rs_el$(rs_nx%) = a_ex$
END_SUB
' ------------------------------------------------------------------------------
SUB TriAsc(f1$,f2$)
' Tri de f1$ dans f2$ en respectant la stricte valeur Ascii des caractères
' (NB: f2$ peut être égal à f1$)
DIM_LOCAL Tr_ob%, Tr_a$, Tr_h$, Tr_i%, Tr_j%
Tr_ob% = 10000
WHILE OBJECT_EXISTS(Tr_ob%) = 1: Tr_ob% = Tr_ob% + 1: END_WHILE
DLIST Tr_ob%: DLIST Tr_ob%+1
FILE_LOAD Tr_ob%, f1$
FOR Tr_i% = 1 TO COUNT(Tr_ob%)
    Tr_a$ = ITEM_READ$(Tr_ob%, Tr_i%): Tr_h$ = ""
    FOR Tr_j% = 1 TO LEN(Tr_a$)
        Tr_h$ = Tr_h$ + RIGHT$("0"+HEX$(ASC(MID$(Tr_a$, Tr_j%, 1))), 2)
    NEXT Tr_j%
    ITEM_ADD Tr_ob%+1, Tr_h$
NEXT Tr_i%
SORT Tr_ob%+1: CLEAR Tr_ob%
FOR Tr_i% = 1 TO COUNT(Tr_ob%+1)
    Tr_h$ = ITEM_READ$(Tr_ob%+1, Tr_i%): Tr_a$ = ""
    FOR Tr_j% = 1 TO LEN(Tr_h$) STEP 2
        Tr_a$ = Tr_a$ + CHR$(HEX(MID$(Tr_h$, Tr_j%, 2)))
    NEXT Tr_j%
    ITEM_ADD Tr_ob%, Tr_a$
NEXT Tr_i%
FILE_SAVE Tr_ob%, f2$
DELETE Tr_ob%: DELETE Tr_ob%+1
END_SUB
' ------------------------------------------------------------------------------
SUB Replace(a$,b$,c$)
' Remplace dans a$ les occurences de b$ par c$ (tailles différentes éventuelles)
' chaîne résultante dans rs_ch$
DIM_LOCAL rm_k%, rm_u%, ff_a$
IF VARIABLE("rs_ch$") = 0 THEN DIM rs_ch$
rs_ch$ = a$: rm_k% = INSTR(rs_ch$, b$)
WHILE rm_k% > 0
    rs_ch$ = LEFT$(rs_ch$, rm_k%-1) + c$ + MID$(rs_ch$, rm_k%+LEN(b$), 500): ' nouvelle chaîne
    rm_u% = rm_k%+LEN(c$): ff_a$ = MID$(rs_ch$, rm_u%, 500)
    rm_k% = INSTR(ff_a$, b$)
    IF rm_k% = 0 THEN EXIT_WHILE
    rm_k% = rm_k%+rm_u%-1
END_WHILE
END_SUB
' ______________________________________________________________________________
SUB Reverse(a$)
' Inverse une chaîne de caractère, résultat dans rs_rv$
DIM_LOCAL rv_i%
IF VARIABLE("rs_rv$") = 0 THEN DIM rs_rv$
rs_rv$ = ""
FOR rv_i% = LEN(a$) TO 1 STEP -1
    rs_rv$ = rs_rv$ + MID$(a$, rv_i%, 1)
NEXT rv_i%
END_SUB
' ------------------------------------------------------------------------------
SUB Misfoc(f1$,f2$,ll%)
' Mise en forme d'un fichier texte en ajustant la longueur des lignes à une
' valeur ll% caractères donnée (coupure à l'espace le plus proche)
DIM_LOCAL m_a$, m_ra$, m_i%, m_k%
FILE_OPEN_READ 8, f1$: FILE_OPEN_WRITE 9, f2$
m_ra$ = ""
WHILE FILE_EOF(8) = 0
    FILE_READLN 8,  m_a$
    IF LEFT$(m_a$, 1) = " " OR LEFT$(m_a$, 1) = CHR$(9): ' début de pararaphe
        IF m_ra$ <> "" THEN FILE_WRITELN 9, m_ra$: m_ra$ = ""
        WHILE LEN(m_a$) > ll%
            FOR m_i% = ll%+1 TO 1 STEP -1
                IF MID$(m_a$, m_i%, 1) = " " THEN EXIT_FOR
            NEXT m_i%
            FILE_WRITELN 9, RTRIM$(LEFT$(m_a$,m_i%-1)): m_a$ = MID$(m_a$,m_i%+1,500)
        END_WHILE
    END_IF
    IF m_ra$ <> "" THEN m_a$ = m_ra$ + " " + m_a$ : m_ra$ = ""
    WHILE LEN(m_a$) > ll%
        FOR m_i% = ll%+1 TO 1 STEP -1
            IF MID$(m_a$, m_i%, 1) = " " THEN EXIT_FOR
        NEXT m_i%
        FILE_WRITELN 9, RTRIM$(LEFT$(m_a$,m_i%-1)): m_a$ = MID$(m_a$,m_i%+1,500)
    END_WHILE
    m_ra$ = RTRIM$(m_a$)
END_WHILE
IF m_ra$ <> "" THEN FILE_WRITELN 9, m_ra$
FILE_CLOSE 8: FILE_CLOSE 9
END_SUB
' ------------------------------------------------------------------------------
SUB Misfop(f1$,f2$,lp%,ob%)
' Mise en forme d'un fichier texte en ajustant la longueur des lignes à une
' valeur lp% pixels donnée (coupure à l'espace le plus proche), pour affichage
' dans l'objet ob%
PRINT_TARGET_IS ob%
DIM_LOCAL m_a$, m_ra$, m_i%, m_k%, m_ll%
FILE_OPEN_READ 8, f1$: FILE_OPEN_WRITE 9, f2$
m_ra$ = ""
WHILE FILE_EOF(8) = 0
    FILE_READLN 8,  m_a$
    IF LEFT$(m_a$, 1) = " " OR LEFT$(m_a$, 1) = CHR$(9): ' début de pararaphe
        IF m_ra$ <> "" THEN FILE_WRITELN 9, m_ra$: m_ra$ = ""
        WHILE TEXT_WIDTH(m_a$,ob%) > lp%
            FOR m_i% = LEN(m_a$) TO 1 STEP -1
                IF MID$(m_a$, m_i%, 1) = " " THEN EXIT_FOR
            NEXT m_i%
            m_ra$ = MID$(m_a$, i%+1, 500): m_a$ = RTRIM$(LEFT$(m_a$, m_i%-1))
        END_WHILE
    END_IF
    IF m_ra$ <> "" THEN m_a$ = rtrim$(m_ra$) + " " + ltrim$(m_a$): m_ra$ = ""
    IF TEXT_WIDTH(m_a$,ob%) < lp%
        m_ra$ = m_a$
    ELSE
        m_i% = LEN(m_a$)
        WHILE TEXT_WIDTH(LEFT$(m_a$, m_i%),ob%) > lp%
            FOR m_k% = m_i%-1 TO 1 STEP -1
                IF MID$(m_a$, m_k%, 1) = " " THEN EXIT_FOR
            NEXT m_k%
            m_i% = m_k%-1
        END_WHILE
        FILE_WRITELN 9, LEFT$(m_a$, m_i%)
        m_ra$ = LTRIM$(MID$(m_a$, m_i%+1, 500))
    END_IF
END_WHILE
IF m_ra$ <> "" THEN FILE_WRITELN 9, m_ra$
FILE_CLOSE 8: FILE_CLOSE 9
END_SUB
' ______________________________________________________________________________
' ======================== FONCTIONS DISQUES/FICHIERS ==========================
SUB Volumes()
' Liste des volumes montés, avec leur nom, séparés par ';' -> volu$
DIM_LOCAL vol_scr$, vol_fv$, vol_a$, v_q$
IF VARIABLE("volu$") = 0 THEN DIM volu$
vol_scr$ = "C:\Temp\Vol.vbs": ' script exécutable créé
vol_fv$ = "C:\Temp\Volumes.txt"
v_q$ = CHR$(34)
DATA "VOLUMES"
DATA "Dim net, shell, computer, fso, WMISet,oWinnt"
DATA "Dim fst, fichier"
DATA "Set fst    = CreateObject("+v_q$+"Scripting.FileSystemObject"+v_q$+")"
DATA "Set fichier = fst.CreateTextFile("+v_q$+"C:\Temp\Volumes.txt"+v_q$+")"
DATA "Set net    = Wscript.CreateObject("+v_q$+"WScript.Network"+v_q$+")"
DATA "Set shell  = WScript.CreateObject("+v_q$+"WScript.Shell"+v_q$+")"
DATA "Set fso    = WScript.CreateObject("+v_q$+"Scripting.FileSystemObject"+v_q$+")"
DATA "computer = net.ComputerName"
DATA "set WMISet = GetObject("+v_q$+"winmgmts:{impersonationLevel=impersonate}!//"+v_q$+" & Computer).ExecQuery _"
DATA "("+v_q$+"SELECT * FROM Win32_LogicalDisk"+v_q$+")"
DATA "Message = "+v_q$+""+v_q$+" "
DATA "For each Disk in WMISet"
DATA "    Capa = Disk.Size"
DATA "    If Capa <> "+v_q$+""+v_q$+" Then"
DATA "        Name = Disk.VolumeName"
DATA "        If Message <> "+v_q$+""+v_q$+" Then Message = Message & VBCRLF"
DATA "        Message = Message & Disk.Name & "+v_q$+" "+v_q$+" & Name"
DATA "    End if"
DATA "Next"
DATA "fichier.WriteLine (Message)"
DATA "fichier.Close"
DATA "wscript.quit"
DATA "f"
FILE_OPEN_WRITE 1, vol_scr$
RESTORE: READ vol_a$: WHILE vol_a$ <> "VOLUMES": READ vol_a$: END_WHILE
READ vol_a$: WHILE vol_a$ <> "f": FILE_WRITELN 1, vol_a$: READ vol_a$: END_WHILE
FILE_CLOSE 1
EXECUTE_WAIT "Wscript.exe " + vol_scr$
FILE_OPEN_READ 9,vol_fv$: volu$ = ""
WHILE FILE_EOF(9) = 0: FILE_READLN 9, vol_a$: volu$=volu$+vol_a$+";": END_WHILE
FILE_CLOSE 9: FILE_DELETE vol_fv$
volu$ = LEFT$(volu$,LEN(volu$)-1)
END_SUB
' ______________________________________________________________________________
SUB Codeco(fi$,fo$,cle$)
' Cryptage/Décryptage d'un fichier quelconque fi$ dans fo$, avec la clé cle$
DIM_LOCAL cd_i%, cd_x%, cd_va%, cd_vc%
FILEBIN_OPEN_READ 8, fi$: FILEBIN_OPEN_WRITE 9, fo$
cd_x% = 1
FOR cd_i% = 1 TO FILEBIN_SIZE(8)
    FILEBIN_READ 8, cd_va%
    cd_vc% = BIN_XOR(cd_va%,  ASC(MID$(cle$, cd_x%, 1)))
    FILEBIN_WRITE 9, cd_vc%
    cd_x% = cd_x% + 1: IF cd_x% > LEN(cle$) THEN cd_x% = 1
NEXT cd_i%
FILEBIN_CLOSE 8: FILEBIN_CLOSE 9
END_SUB
' ______________________________________________________________________________
SUB File2String(f$)
' Copie d'un fichier entier quelconque f$ dans une chaîne -> f_ch$
DIM_LOCAL f_sz%, f_ix%, f_va%
IF VARIABLE("f_ch$") = 0 THEN DIM f_ch$
f_ch$ = ""
FILEBIN_OPEN_READ 9, f$: f_sz% = FILEBIN_SIZE(9)
DIM_LOCAL f_v%(f_sz%)
FOR f_ix% = 1 TO f_sz%
    FILEBIN_READ 9, f_va%: f_ch$ = f_ch$ + CHR$(f_va%)
NEXT f_ix%
FILEBIN_CLOSE 9
END_SUB
' ______________________________________________________________________________
SUB String2File(a$,f$)
' Ecriture d'une chaîne complète a$ dans un fichier binaire f$
DIM_LOCAL f_sz%, f_ix%, f_va%
FILEBIN_OPEN_WRITE 9, f$
FOR f_ix% = 1 TO LEN(a$)
    FILEBIN_WRITE 9, ASC(MID$(a$, f_ix%, 1)
NEXT f_ix%
FILEBIN_CLOSE 9
END_SUB
' ______________________________________________________________________________
' ========================== FONCTIONS DATES ===================================
SUB QPaques(Annee)
' Quantièmes de Pâques, Ascension, Pentecôte en fonction de Annee
' Résultats dans rs_qpa, rs_qas, rs_qpe
DIM_LOCAL qp_a,qp_b,qp_c,qp_d,qp_e,qp_f,qp_g,qp_h,qp_i,qp_k,qp_l,qp_m
DIM_LOCAL qp_bi,qp_ci,qp_cj
IF VARIABLE("rs_qpa") = 0 THEN DIM rs_qpa
IF VARIABLE("rs_qas") = 0 THEN DIM rs_qas
IF VARIABLE("rs_qpe") = 0 THEN DIM rs_qpe
qp_a = 19*FRAC(Annee/19)
qp_b = INT(Annee/100)
qp_c = 100*FRAC(Annee/100)
qp_ci = 4*FRAC(Annee/4)
qp_cj = 400*FRAC(Annee/400)
qp_bi = 0: IF qp_ci = 0 AND (qp_c <> 0 OR qp_cj = 0) THEN qp_bi = 1
qp_d = INT(qp_b/4)
qp_e = 4*FRAC(qp_b/4)
qp_f = INT((qp_b + 8) / 25)
qp_g = INT((qp_b - qp_f + 1) / 3)
qp_h = 30*FRAC((19 * qp_a + qp_b - qp_d - qp_g + 15)/30)
qp_i = INT(qp_c/4)
qp_k = 4*FRAC(qp_c/4)
qp_l = 7*FRAC((32 + 2 * qp_e + 2 * qp_i - qp_h - qp_k)/7)
qp_m = INT((qp_a + 11 * qp_h + 22 * qp_l) / 451)
rs_qpa = qp_h + qp_l - 7 * qp_m + 81 + qp_bi
rs_qpa = INT(rs_qpa + .1)
rs_qas = rs_qpa + 39: rs_qpe = rs_qpa + 49
END_SUB
' ------------------------------------------------------------------------------
SUB DateSerial(Annee,Mois,Jour)
' Date série en fonction de Annee, Mois, Jour -> rs_ds%
' (pour calculer par exemple le nombre de jours entre deux dates)
DIM_LOCAL ds_res,ds_bi
IF VARIABLE("rs_ds%") = 0 THEN DIM rs_ds%
SELECT Mois
    CASE 1: ds_res = 0
    CASE 2: ds_res = 31
    CASE 3: ds_res = 59
    CASE 4: ds_res = 90
    CASE 5: ds_res = 120
    CASE 6: ds_res = 151
    CASE 7: ds_res = 181
    CASE 8: ds_res = 212
    CASE 9: ds_res = 243
    CASE 10: ds_res = 273
    CASE 11: ds_res = 304
    CASE 12: ds_res = 334
END_SELECT
ds_res = ds_res + Jour - 1: ds_bi = 0
IF (FRAC(Annee/4)=0 AND FRAC(Annee/100)>0) OR FRAC(Annee/400)=0 THEN ds_bi=1
IF ds_bi = 1 THEN IF Mois > 2 THEN ds_res = ds_res + 1
REPEAT
    Annee = Annee-1: ds_bi = 0
    IF (FRAC(Annee/4)=0 AND FRAC(Annee/100)>0) OR FRAC(Annee/400)=0 THEN ds_bi=1
    ds_res = ds_res + 365 + ds_bi
UNTIL Annee <= 1753
rs_ds% = ds_res-53688: ' date serial
END_SUB
' ------------------------------------------------------------------------------
SUB JourSem(Annee,Mois,Jour)
' Jour de la semaine d'une date donnée (0= Dimanche à 6= Samedi) -> rs_js%
DIM_LOCAL js_d
IF VARIABLE("rs_js%") = 0 THEN DIM rs_js%
js_d = Annee
IF Mois<3 THEN js_d = js_d-1
js_d=INT(23*Mois/9)+Jour+4+Annee+INT(js_d/4)-INT(js_d/100)+INT(js_d/400)
IF Mois>=3 THEN js_d = js_d-2
rs_js% = js_d-7*INT(js_d/7)
END_SUB
' ------------------------------------------------------------------------------
SUB Jmq(Annee,Mois,Jour)
' Quantième de l'année en fonction de Annee, Mois, Jour -> rs_qa%
DIM_LOCAL Jm_Q, Jm_m
IF VARIABLE("rs_qa%") = 0 THEN DIM rs_qa%
Jm_Q = 0
IF Mois > 1
    FOR Jm_m = 1 TO Mois - 1
        SELECT CASE Jm_m
            CASE 1: Jm_Q = Jm_Q+31
            CASE 2: Jm_Q = Jm_Q+28
IF (FRAC(Annee/4)=0 AND FRAC(Annee/100)>0) OR FRAC(Annee/400)=0 THEN Jm_Q=Jm_Q+1
            CASE 3: Jm_Q = Jm_Q+31
            CASE 4: Jm_Q = Jm_Q+30
            CASE 5: Jm_Q = Jm_Q+31
            CASE 6: Jm_Q = Jm_Q+30
            CASE 7: Jm_Q = Jm_Q+31
            CASE 8: Jm_Q = Jm_Q+31
            CASE 9: Jm_Q = Jm_Q+30
            CASE 10: Jm_Q = Jm_Q+31
            CASE 11: Jm_Q = Jm_Q+30
        END_SELECT
    NEXT m
END_IF
rs_qa% = Jm_Q+Jour
END_SUB
' ------------------------------------------------------------------------------
SUB Qjm(Annee,Q)
' Mois et jour en fonction du quantième -> Mois, Jour
DIM_LOCAL qj_bi%, qj_qt%, qj_lm%
qj_bi% = 0: qj_qt% = 0
IF (FRAC(Annee/4)=0 AND FRAC(Annee/100)>0) OR FRAC(Annee/400)=0 THEN qj_bi%=1
Mois = 1: qj_qt% = 31
IF Q<32
    Jour = Q
ELSE
    WHILE Q > qj_qt%
        Mois = Mois + 1
        IF Mois = 4 OR Mois = 6 OR Mois = 9 OR Mois = 11
            qj_lm% = 30
        ELSE
            IF Mois = 2
                qj_lm% = 28 + qj_bi%
            ELSE
                qj_lm% = 31
            END_IF
        END_IF
        qj_qt% = qj_qt% + qj_lm%
    END_WHILE
    Jour = Q - qj_qt% + qj_lm%
END_IF
END_SUB
' ------------------------------------------------------------------------------
' ============================== FONCTIONS IMAGES ==============================
SUB CreBmp(f$,w%,h%,r%,g%,b%)
' Création d'une image Bmp f$, dimensions w% x h%, de couleur r%,g%,b%
DIM_LOCAL bm_nbo%
bm_nbo% = NUMBER_OBJECTS + 1: PICTURE bm_nbo%: HIDE bm_nbo%
WIDTH bm_nbo%, w%: HEIGHT bm_nbo%, h%
2D_TARGET_IS bm_nbo%: 2D_FILL_COLOR r%, g%, b%
2D_PEN_COLOR r%, g%, b%: 2D_RECTANGLE 0, 0, w%-1, h%-1
FILE_SAVE bm_nbo%, f$
DELETE bm_nbo%
END_SUB
' ------------------------------------------------------------------------------
SUB DimBmp(f$)
' Dimensions d'une image bmp -> rs_wi%, rs_hi% (largeur, hauteur en pixels)
DIM_LOCAL bm_w%, bm_h%, bm_vdi%
IF VARIABLE("rs_wi%") = 0 THEN DIM rs_wi%
IF VARIABLE("rs_hi%") = 0 THEN DIM rs_hi%
FILEBIN_OPEN_READ 9, f$
FILEBIN_POSITION 9, 19
FILEBIN_READ 9, rs_wi%%: FILEBIN_READ 9, bm_vdi%: rs_wi% = rs_wi% + 256*bm_vdi%
FILEBIN_READ 9, bm_vdi%: rs_wi% = rs_wi% + 256*256*bm_vdi%
FILEBIN_READ 9, bm_vdi%: rs_wi% = rs_wi% + 256*256*256*bm_vdi%
FILEBIN_READ 9, rs_hi%: FILEBIN_READ 9, bm_vdi%: rs_hi% = rs_hi% + 256*bm_vdi%
FILEBIN_READ 9, bm_vdi%: rs_hi% = rs_hi% + 256*256*bm_vdi%
FILEBIN_READ 9, bm_vdi%: rs_hi% = rs_hi% + 256*256*256*bm_vdi%
FILEBIN_CLOSE 9
END_SUB
' ------------------------------------------------------------------------------
SUB BmpInfos(f$, w_img%, h_img%, tf_img%, bpp_img%, th_img%, ll_img%)
' Lecture des données du fichier bmp f$
' -> rs_wi%=largeur, rs_hi%=hauteur, rs_tf%=taille fichier, rs_bp%=bits/pixel,
' -> rs_th%=taille header, rs_ll%=taille ligne d'image
DIM_LOCAL tf%, v%(54), inf_res$
IF VARIABLE("rs_wi%") = 0 THEN DIM rs_wi%
IF VARIABLE("rs_hi%") = 0 THEN DIM rs_hi%
IF VARIABLE("rs_tf%") = 0 THEN DIM rs_tf%
IF VARIABLE("rs_bp%") = 0 THEN DIM rs_bp%
IF VARIABLE("rs_th%") = 0 THEN DIM rs_th%
IF VARIABLE("rs_ll%") = 0 THEN DIM rs_ll%
FILEBIN_OPEN_READ 9, f$: FILEBIN_BLOCK_READ 9, 54, v%(1): FILEBIN_CLOSE 9
rs_tf% = v%(3)+256*v%(4)+256*256*v%(5)+256*256*256*v%(6): ' taille totale du fichier
rs_th% = v%(11)+256*v%(12)+256*256*v%(13)+256*256*256*v%(14): ' taille du header
rs_wi% = v%(19)+256*v%(20)+256*256*v%(21)+256*256*256*v%(22): ' largeur image, en pixels
rs_hi% = v%(23)+256*v%(24)+256*256*v%(25)+256*256*256*v%(26): ' hauteur image, en pixels
rs_bp% = v%(29)+256*v%(30): ' bits par pixel image
rs_ll% = (rs_tf%-rs_th%)/rs_hi%: ' longueur d'une ligne image, en octets
END_SUB
' ------------------------------------------------------------------------------
SUB Img_infos(f$)
' Image f$ -> rs_wi%, rs_hi%, rs_dat$ (dimensions, date/heure de prise de vue)
DIM_LOCAL a_img$, f_img$, i_img$, w_img%, h_img%, d_img$: ' variables locales
IF VARIABLE("rs_wi%") = 0 THEN DIM rs_wi%
IF VARIABLE("rs_hi%") = 0 THEN DIM rs_hi%
IF VARIABLE("rs_dat$") = 0 THEN DIM rs_dat$
f_img$ = "C:\TEMP\Ifxwz.txt"
i_img$ = "C:\Progra~2\Irfanv~1\i_view32.exe ": ' <=========== chemin de IrfanView
EXECUTE_WAIT i_img$ + f$ + " /info=" + f_img$ + " /fullinfo"
FILE_OPEN_READ 9, f_img$: w_img% = 0: h_img% = 0: d_img$ = ""
WHILE FILE_EOF(9) = 0: FILE_READLN 9, a_img$
    IF LEFT$(a_img$, 16) = "Image dimensions"
        a_img$ = MID$(a_img$, 20, 50)
        rs_wi% = VAL(LEFT$(a_img$, INSTR(a_img$, " ") - 1))
        a_img$ = MID$(a_img$, INSTR(a_img$, " ") + 3, 50)
        rs_hi% = VAL(LEFT$(a_img$, INSTR(a_img$, " ") - 1))
    ELSE
        IF LEFT$(a_img$, 16) = "DateTimeOriginal"
            a_img$ = MID$(a_img$, 20, 50)
            rs_dat$ = MID$(a_img$,9,2)+"/"+MID$(a_img$,6,2)+"/"+LEFT$(a_img$,4)+MID$(a_img$,11,6)
            EXIT_WHILE
        END_IF
    END_IF
END_WHILE
FILE_CLOSE 9: FILE_DELETE f_img$
END_SUB
' ------------------------------------------------------------------------------
SUB Jpg2Bmp(fi$,fo$)
' Conversion d'une image Jpg (fi$) en Bmp (fo$)
DIM_LOCAL j_nbo%
j_nbo% = NUMBER_OBJECTS + 1: PICTURE j_nbo%: HIDE j_nbo%
FILE_LOAD j_nbo%, fi$: FILE_SAVE j_nbo%, fo$: DELETE j_nbo%
END_SUB
' ------------------------------------------------------------------------------
SUB Posxy(f$,x%,y%)
' Position dans le fichier bmp et couleur du pixel aux coordonnées x et y pixels
' -> rs_pos% position dans le fichier, rs_cr%, rs_cg%, rs_cb% couleur du pixel
DIM_LOCAL v%(54), bm_tf%, bm_lh%, bm_wi%, bm_hi%, bm_bpp%, bm_ll%
IF VARIABLE("rs_pos%") = 0 THEN DIM rs_pos%
IF VARIABLE("rs_cr%") = 0 THEN DIM rs_cr%
IF VARIABLE("rs_cg%") = 0 THEN DIM rs_cg%
IF VARIABLE("rs_cb%") = 0 THEN DIM rs_cb%
FILEBIN_OPEN_READ 9, f$: FILEBIN_BLOCK_READ 9, 54, v%(1)
bm_tf% = v%(3)+256*v%(4)+256*256*v%(5)+256*256*256*v%(6): ' taille totale du fichier
bm_lh% = v%(11)+256*v%(12)+256*256*v%(13)+256*256*256*v%(14): ' taille du header
bm_wi% = v%(19)+256*v%(20)+256*256*v%(21)+256*256*256*v%(22): ' largeur image, en pixels
bm_hi% = v%(23)+256*v%(24)+256*256*v%(25)+256*256*256*v%(26): ' hauteur image, en pixels
bm_bpp% = v%(29)+256*v%(30): ' bits par pixel image
bm_ll% = (bm_tf%-bm_lh%)/h%: ' longueur d'une ligne image, en octets
rs_pos% = bm_tf% - (y%+1) * bm_ll% + x% * bm_bpp%/8
FILEBIN_POSITION 9, rs_pos%
FILEBIN_READ 9, rs_cb%: FILEBIN_READ 9, rs_cg%: FILEBIN_READ 9, rs_cr%: ' couleur
FILEBIN_CLOSE 9
END_SUB
' ------------------------------------------------------------------------------
SUB RGB2Val(r%,g%,b%)
' Conversion des couleurs R,G,B en valeur entière
IF VARIABLE("rs_cl%") = 0 THEN DIM rs_cl%
rs_cl% = b%+256*g%+256*256*r%
END_SUB
' ------------------------------------------------------------------------------
SUB Val2RGB(couleur)
' Décomposition d'une valeur de couleur en composantes R,G,B: rs_cr%, rs_cg%, rs_cb%
IF VARIABLE("rs_cr%") = 0 THEN DIM rs_cr%
IF VARIABLE("rs_cg%") = 0 THEN DIM rs_cg%
IF VARIABLE("rs_cb%") = 0 THEN DIM rs_cb%
rs_cr% = BIN_AND(couleur,16711680)/65536
rs_cg% = BIN_AND(couleur,65280)/256
rs_cb% = BIN_AND(couleur,255)
END_SUB
' ------------------------------------------------------------------------------
' ============================ FONCTIONS MATHÉMATIQUES =========================
SUB VMKL(v%)
' Conversion d'un entier en chaîne de 4 octets, poids faibles en tête -> rs_mkl$
DIM_LOCAL mk_v
IF VARIABLE("rs_mkl$") = 0 THEN DIM rs_mkl$
mk_v = v%: rs_mkl$ = ""
WHILE LEN(rs_mkl$) < 4
    rs_mkl$ = rs_mkl$ + CHR$(256*FRAC(mk_v/256))
    mk_v = INT(mk_v/256)
END_WHILE
END_SUB
' ------------------------------------------------------------------------------
SUB CVL(v$)
' conversion chaîne de 4 octets (poids faibles en tête) en entier -> rs_cv%
DIM_LOCAL cv_i%
IF VARIABLE("rs_cv%") = 0 THEN DIM rs_cv%
rs_cv% = 0
FOR cv_i% = 4 TO 1 STEP -1
    rs_cv% = 256*rs_cv% + ASC(MID$(vl$, cv_i%, 1))
NEXT cv_i%
END_SUB
' ------------------------------------------------------------------------------
SUB Est_Divisible_par(nombre,diviseur)
' teste si nombre est divisible par diviseur (papydall) -> rs_div$
IF VARIABLE("rs_div$") = 0 THEN DIM rs_div$
dim_local rep$
if mod(nombre,diviseur) = 0
    rs_div$ = "OUI " + str$(nombre) + " est divisible par " + str$(diviseur)
else
    rs_div$ = "NON " + str$(nombre) + " n'est pas divisible par " + str$(diviseur)
end_if
END_SUB
' ------------------------------------------------------------------------------
' ==================================== DIVERS ==================================
SUB Nomcourt(Path$)
' Conversion de Path long en Path court (sans espace) - rs_nc$
DIM_LOCAL nc_fbat$,nc_tmp$,nc_court$
nc_fbat$ = "C:\Temp\Nomcourt.bat": nc_tmp$ = "C:\Temp\temp"
FILE_OPEN_WRITE 9, nc_fbat$
FILE_WRITELN 9, "@echo off"
FILE_WRITELN 9, "for %%A in ("+CHR$(34)+Path$+CHR$(34)+") do echo.%%~sfA >"+nc_tmp$
FILE_CLOSE 9
EXECUTE_WAIT nc_fbat$
FILE_OPEN_READ 9, nc_tmp$
FILE_READLN 9, rs_nc$
FILE_CLOSE 9: FILE_DELETE nc_tmp$: FILE_DELETE nc_fbat$
END_SUB
' ------------------------------------------------------------------------------
SUB Exprog(prog$)
    ' Exécution d'un programme externe sans la fenêtre noire Ms-DOS
    ' - exemple: Exprog("Cmd.exe /c DIR C:\UTIL >C:\TEMP\Dir.txt")
    DIM_LOCAL scr$, bat$, qu$
    scr$ = "C:\TEMP\Vbscript.vbs"
    bat$ = "C:\TEMP\Bat.bat"
    qu$ = CHR$(34)
    ' ===== Création du fichier .bat
    FILE_OPEN_WRITE 9, bat$: FILE_WRITELN 9, prog$: FILE_CLOSE 9
    ' ===== Création du script .vbs
    FILE_OPEN_WRITE 9, scr$
    FILE_WRITELN 9, "CreateObject("+qu$+"Wscript.Shell"+qu$+").Run "+qu$+bat$+qu$+",0,True"
    FILE_CLOSE 9
    ' ===== Exécution du script
    EXECUTE_WAIT "WSCRIPT.exe "+scr$
    FILE_DELETE bat$: FILE_DELETE scr$
END_SUB
' ------------------------------------------------------------------------------

est_divisible_par(21,4)
est_divisible_par(34,2)
print
RoundUp(2.4) : RoundUp(3.5)
end
' ******************************************************************************
' teste si nombre est divisible par diviseur
SUB est_divisible_par(nombre,diviseur)
    dim_local rep$
    if mod(nombre,diviseur) = 0
      rep$ = "OUI " + str$(nombre) + " est divisible par " + str$(diviseur)
    else
      rep$ = "NON " + str$(nombre) + " n'est pas divisible par " + str$(diviseur)
    end_if
    print rep$
end_sub
' ******************************************************************************
' Arrondit un réel en un entier le plus proche
SUB RoundUp(x)
  dim_local result%
  result% = int(x) + int(frac(x)*2)
  print "RoundUp("+str$(x)+") = ";result%
end_sub
' ******************************************************************************

Formulaire(N%,V%,H%,W%,T%,L%)

Sub Formulaire(N%,V%,H%,W%,T%,L%)
  Form N%
  If V%=0 then Hide N%
  Height N%,H% : Width N%,W%
  If T%>0 : Top N%,T% : Else : Top% N%, (screen_y-H%)/2 : End_If
  If L%>0 : Top N%,L% : Else : Left% N%,(screen_x-W%)/2 : End_If
End_Sub

....
Objet N% : Parent N%,P%
....

result% = x

result% = int(x) + int(frac(x)*2)

DIM Rsub%: Rsub% = 1999: DLIST Rsub%

Masub(p1,p2,...,Rsub%)
retour$ = ITEM_READ$(Rsub%,1) ou bien retour = VAL(ITEM_READ$(Rsub%,1))

...
CLEAR Rsub%: ITEM_ADD Rsub%, valeur$, ou STR$(valeur)
END_SUB

sub MaProcedure(...liste de paramètres...)
' définition des variables pour les valeurz retournées
  if variable("MaProcedure")=0 then dim MaProcedure
  if variable("MaProcedure$")=0 then dim MaProcedure$
  if variable("MaProcedure_tableau")=0 then dim MaProcedure_tableau(10)
  dim_local i%
' juste à titre d'exemple
  ... ici, traitement de la procédure

' chargement des variables pour les valeurs retournées
  MaProcedure = ...valeur...  : ' valeur principale de retour - même nom que la procédure !
  MaProcedure$ = "...chaîne..." : ' chaîne de caractères à retourner
  for i%=0 to 10
    MaProcedure_tableau(i%) = ...valeur flottante...
  next i%
end_sub

...
MaProcedure(...)
message "Résultat: "+str$(MaProcedure)
message "Chaîne retournée: "+MaProcedure$
message "Valeur flottante 3 = "+str$(MaProcedure_tableau(3)

DLIST 125
MaProcedure(Param1,Param2,125)
...

DLIST 123
' appel à la SUB Toto avec 2 paramètres
ITEM_ADD 123, Param1 : ITEM_ADD 123, Param2
Toto(123)
Print "Nombre de valeur en retour:";COUNT(123)
' appel à la SUB Toto avec 3 paramètres
CLEAR 123
ITEM_ADD 123, Param1 : ITEM_ADD 123, Param2: ITEM_ADD 123, Param3
Toto(123)
Print "Nombre de valeur en retour:";COUNT(123)
....

' Accent_Off(chaine$) est une procédure qui transforme les voyelles accentuées,
' le c cedille ainsi que le ñ en lettres non accentuées, le æ et le œ en ae et oe
' Elle pourra très bien faire l'objet d'une fonction
' ******************************************************************************

Accent_Off("éèàçôæûÿöýãåñ")
end

Sub Accent_Off(tex$)
    dim_local i%,c$,c1$,t$,asc%
    if len(tex$) = 0 then exit_sub
    for i% = 1 to len(tex$)
        c$ = mid$(tex$,i%,1) : c1$ = c$
        asc% = asc(c$)
        select asc%
            case 156 : c1$ = chr$(111) +chr$(101) : ' œ ---> oe
            case 224 : c1$ = chr$(097) : ' à ---> a
            case 225 : c1$ = chr$(097) : ' á ---> a
            case 226 : c1$ = chr$(097) : ' â ---> a
            case 227 : c1$ = chr$(097) : ' ã ---> a
            case 228 : c1$ = chr$(097) : ' ä ---> a
            case 229 : c1$ = chr$(097) : ' å ---> a
            case 230 : c1$ = chr$(097) + chr$(101) : ' æ ---> ae
            ' ---------------------------------------------------
            case 231 : c1$ = chr$(099) : ' ç ---> c
            case 232 : c1$ = chr$(101) : ' è ---> e
            case 233 : c1$ = chr$(101) : ' é ---> e
            case 234 : c1$ = chr$(101) : ' ê ---> e
            case 235 : c1$ = chr$(101) : ' ë ---> e
            ' -------------------------------------
            case 236 : c1$ = chr$(105) : ' ì ---> i
            case 237 : c1$ = chr$(105) : ' í ---> i
            case 238 : c1$ = chr$(105) : ' î ---> i
            case 239 : c1$ = chr$(105) : ' ï ---> i
            ' -------------------------------------
            case 240 : c1$ = chr$(111) : ' ð ---> o
            case 241 : c1$ = chr$(110) : ' ñ ---> n
            case 242 : c1$ = chr$(111) : ' ò ---> o
            case 243 : c1$ = chr$(111) : ' ó ---> o
            case 244 : c1$ = chr$(111) : ' ô ---> o
            case 245 : c1$ = chr$(111) : ' õ ---> o
            case 246 : c1$ = chr$(111) : ' ö ---> o
            ' -------------------------------------
            case 249 : c1$ = chr$(117) : ' ù ---> u
            case 250 : c1$ = chr$(117) : ' ú ---> u
            case 251 : c1$ = chr$(117) : ' ú ---> u
            case 252 : c1$ = chr$(117) : ' ü ---> u
            ' -------------------------------------
            case 253 : c1$ = chr$(121) : ' ý ---> y
            case 255 : c1$ = chr$(121) : ' ÿ ---> y
            ' -------------------------------------
        end_select
        t$ = t$ + c1$
    next i%
    message upper$(t$)
end_sub
' ******************************************************************************

' Le Triangle de Pascal
' Le triangle arithmétique de Pascal est le triangle dont la ligne d'indice n
' (n = 0, 1, 2...) donne les nombres qui apparaissent dans le développement de
' (a + b)^n et dans des nombreux domaines en mathématiques comme l'analyse combinatoire.

' EXEMPLE : Pour calculer (a + b)^5
' La ligne 5 donne : 1 ; 5 ; 10 ; 10 ; 5 ; 1
' soit les coefficients de :
' (a + b)^5 = 1×a^5 + 5×a^4b + 10×a^3b² + 10×a²b^3 + 5×ab^4 + 1×b^5.

' ATTENTION : les coefficients croissent très rapidement et il y a risque de
' dépassement de la plage des nombres entiers. Par exemple, si vous appelez la
' procédure avec la valeur 35, certains coefficients deviennent négatifs : c'est
' une conséquence du dépassement.
' Pour aller plus loin, vous pouvez changer les variables entières en flottantes
' Mais à quoi ça pourrait servir ?



height 0,600 : width 0,1200

Triangle_Pascal(25)
end
' ******************************************************************************
SUB Triangle_Pascal(n%)
    dim_local i%,j%,tab%(n%+1,n%+1)
    For i% = 1 to n%+1 : For j% =1 to n%+1 : Tab%(i%,j%) = 0 : next j% : next i%
    For i% = 1 to n%+1
      For j%=1 to n%+1
        If j% = 1
          tab%(i%,j%)=1
        else
          if i%<>1 then tab%(i%,j%)= tab%(i%-1,j%)+tab%(i%-1,j%-1)
        end_if
        if tab%(i%,j%)<>0 then print tab%(i%,j%); " " ;
      next j%
      print
    next i%
END_SUB
' ******************************************************************************

sub reverse_string(param1$)

  ' En paramètre, la chaîne que l'on désire écrire à l'envers.
  ' En retour dans rs$ la chaîne inversée.

    rs$=""
   
    for kk%=len(param1$) to 1 step -1
        rs$=rs$+mid$(param1$,kk%,1)
    next kk%

end_sub

sub lastIndexof(param1$, param2$, position%)

    ' En entrée, on donne chaine$, sous_chaine$ et position%.
    ' En sortie, on fournit dans 'res%' la dernière occurence de sous_chaine$ dans chaine$.
    ' Si sous_chaine$ n'existe pas, on fournit -1.

    reverse_string(param1$)
    res%=instr(rs$,param2$)-1
    if res%<position% then res%=-1

end_sub

' Accent_On_Lower_To_Upper (chaine$) est une procédure qui transforme les
' voyelles accentuées d'une chaine en minuscule en voyelle accentuées majuscules
' ******************************************************************************

Accent_On_Lower_To_Upper("œ,à,á,â,ä,å,æ,ç,è,é,ê,ë, etc... ")
end

Sub Accent_On_Lower_To_Upper(tex$)
    dim_local i%,c$,c1$,t$,asc%
    if len(tex$) = 0 then exit_sub
    for i% = 1 to len(tex$)
        c$ = mid$(tex$,i%,1) : c1$ = c$
        asc% = asc(c$)
        select asc%
            case 156 : c1$ = chr$(140) : ' œ ---> Œ
            case 224 : c1$ = chr$(192) : ' à ---> À
            case 225 : c1$ = chr$(193) : ' á ---> Á
            case 226 : c1$ = chr$(194) : ' â ---> Â
            case 227 : c1$ = chr$(195) : ' ã ---> Ã
            case 228 : c1$ = chr$(196) : ' ä ---> Ä
            case 229 : c1$ = chr$(197) : ' å ---> Å
            case 230 : c1$ = chr$(198) : ' æ ---> Æ
            ' -------------------------------------
            case 231 : c1$ = chr$(199) : ' ç ---> Ç
            case 232 : c1$ = chr$(200) : ' è ---> È
            case 233 : c1$ = chr$(201) : ' é ---> É
            case 234 : c1$ = chr$(202) : ' ê ---> Ê
            case 235 : c1$ = chr$(203) : ' ë ---> Ë
            ' -------------------------------------
            case 236 : c1$ = chr$(204) : ' ì ---> Ì
            case 237 : c1$ = chr$(205) : ' í ---> Í
            case 238 : c1$ = chr$(206) : ' î ---> Î
            case 239 : c1$ = chr$(207) : ' ï ---> Ï
            ' -------------------------------------
            case 240 : c1$ = chr$(213) : ' ð ---> Ð
            case 241 : c1$ = chr$(209) : ' ñ ---> Ñ
            case 242 : c1$ = chr$(210) : ' ò ---> Ò
            case 243 : c1$ = chr$(211) : ' ó ---> Ó
            case 244 : c1$ = chr$(212) : ' ô ---> Ô
            case 245 : c1$ = chr$(213) : ' õ ---> Õ
            case 246 : c1$ = chr$(214) : ' ö ---> Ö
            ' -------------------------------------
            case 249 : c1$ = chr$(217) : ' ù ---> Ù
            case 250 : c1$ = chr$(218) : ' ú ---> Ú
            case 251 : c1$ = chr$(219) : ' û ---> Û
            case 252 : c1$ = chr$(220) : ' ü ---> Ü
            ' -------------------------------------
            case 253 : c1$ = chr$(221) : ' ý ---> Ý
            case 255 : c1$ = chr$(159) : ' ÿ ---> Ÿ
            ' -------------------------------------
        end_select
        t$ = t$ + c1$
    next i%
    message t$
end_sub
' ******************************************************************************

' Sub Saisie_Date par Jean claude 01/2013
' le controle du jour par rapport au mois et à l'année est automatique (ex: essayez de taper 31/02/2011)
' retourne a$=année,b$=mois,c$=jour

' Sub Ouvre_Boite(numéro du container,Width du container,Height du container,Top du container,
'                Left du container,Texte du caption du container,NbChr%,Num_Chr%)
' Permet d'ouvrir un container contenant des objets de taille voulue, position voulue et caption cap$

' les objet sont créer automatiquement (pas besion de les numéroter)

dim a$,b$,c$,cap$,Provenance$
dim no%,n%
label jour,J2,mois,M2,annee,A1,A2,valide_date

Boite_Date():' création des objets nécessaires à la saisie dans un container (Boite)

cap$=" Jour "+string$(6,chr$(126))+" Mois "+string$(6,chr$(126))+" Année "+string$(6,chr$(126))
' ou
' cap$=""
' ou
' cap$=" Saisie date ":' dans ce cas il faut mettre la valeur 12 à la variable NbChr%

Ouvre_Boite(Boite_date%,225,45,140,102,cap$,0,126)

a$=right$(date$,4):b$=mid$(date$,4,2):c$=left$(date$,2):' ou une autre date
Saisie_Date(a$,b$,c$,edit_annee%,BT_annee_modif%,combo_mois%,BT_mois_modif%,combo_jour%,BT_jour_modif%,BT_Valid_date%)

caption 0,c$+"/"+b$+"/"+a$:' retour

END
' -------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub Saisie_Date(annee$,moi$,jour$,num_edit_annee%,num_BT_annee_modif%,num_combo_mois%,num_BT_mois_modif%,num_combo_jour%,num_BT_jour_modif%,num_BT_Valid_date%):' retourne a$=année,b$=mois,c$=jour
inactive num_edit_annee%:text num_edit_annee%,annee$:active num_BT_annee_modif%:on_click num_BT_annee_modif%,annee
inactive num_combo_mois%:text num_combo_mois%,moi$:active num_BT_mois_modif%:on_click num_BT_mois_modif%,mois
inactive num_combo_jour%:text num_combo_jour%,jour$:active num_BT_jour_modif%:on_click num_BT_jour_modif%,jour
active num_BT_Valid_date%:on_click num_BT_Valid_date%,valide_date
if annee$="" or moi$="" or jour$=""
MESSAGE "ERREUR: une ou plusieurs variables annee$,moi$,jour$, non renseignée(s) au SUB Saisie_Date":terminate
end_if
if len(annee$)<>4 or len(moi$)<>2 or len(jour$)<>2
MESSAGE "ERREUR: une ou plusieurs variables annee$,moi$,jour$, incorrecte(s) (longueur string$) au SUB Saisie_Date":terminate
end_if
if val(text$(num_edit_annee%))=0 or val(text$(num_combo_mois%))=0 or val(text$(num_combo_jour%))=0
MESSAGE "ERREUR: une ou plusieurs variables annee$,moi$,jour$, incorrecte(s) au SUB Saisie_Date":terminate
end_if
end
jour:
inactive num_BT_mois_modif%:inactive num_BT_annee_modif%:inactive num_BT_jour_modif%:inactive num_BT_Valid_date%
Charge_Combo_Jour(text$(num_edit_annee%),text$(num_combo_mois%),text$(num_combo_jour%),num_combo_jour%)
active num_combo_jour%:on_click num_combo_jour%,J2
return
J2:
jour$=text$(num_combo_jour%):inactive num_combo_jour%
active num_BT_mois_modif%:active num_BT_annee_modif%:active num_BT_jour_modif%:active num_BT_Valid_date%
return
mois:
inactive num_BT_mois_modif%:inactive num_BT_annee_modif%:inactive num_BT_jour_modif%:inactive num_BT_Valid_date%
active num_combo_mois%:on_click num_combo_mois%,M2
return
M2:
moi$=text$(num_combo_mois%):inactive num_combo_mois%
active num_BT_mois_modif%:active num_BT_annee_modif%:active num_BT_jour_modif%:active num_BT_Valid_date%
Provenance$="M2":Charge_Combo_Jour(text$(num_edit_annee%),text$(num_combo_mois%),text$(num_combo_jour%),num_combo_jour%)
Provenance$=""
return
annee:
inactive num_BT_mois_modif%:inactive num_BT_annee_modif%:inactive num_BT_jour_modif%:inactive num_BT_Valid_date%
active num_edit_annee%:set_focus num_edit_annee%:on_key_up num_edit_annee%,A1
return
A1:
if key_up_code=13 then goto A2
return
A2:
annee$=text$(num_edit_annee%):inactive num_edit_annee%
if len(annee$)<>4 then message "Saisie incorrecte (format JJ/MM/AAAA)":text num_edit_annee%,"":goto annee
active num_BT_mois_modif%:active num_BT_annee_modif%:active num_BT_jour_modif%:active num_BT_Valid_date%
return
valide_date:
a$=text$(num_edit_annee%):b$=text$(num_combo_mois%):c$=text$(num_combo_jour%)
inactive num_BT_mois_modif%:inactive BT_annee_modif%:inactive num_BT_jour_modif%:inactive num_BT_Valid_date%
Exit_Sub
return
End_Sub
' ----------------------------------
Sub Charge_Combo_Jour(aaaa$,mm$,jj$,num_combo_jour%)
dim_local i%,aaaa%,mm%,jj%,bissextile%,maxj%
if Provenance$<>"M2" then clear num_combo_jour%
text num_combo_jour%,jj$:aaaa%=val(aaaa$):bissextile%=0:mm%=val(mm$)
IF (FRAC(aaaa%/4)=0 AND FRAC(aaaa%/100)>0) OR FRAC(aaaa%/400)=0 THEN bissextile%=1:' JL35
if mm%=2
  if bissextile%=1
    maxj%=29:if Provenance$="M2" and val(jj$)>maxj% then jj$=str$(maxj%)
  else
    maxj%=28:if Provenance$="M2" and val(jj$)>maxj% then jj$=str$(maxj%)
  end_if
else
  if mm%=4 or mm%=6 or mm%=9 or mm%=11
  maxj%=30:if Provenance$="M2" and val(jj$)>maxj% then jj$=str$(maxj%)
  else
  maxj%=31
  end_if
end_if
if Provenance$="M2" then text num_combo_jour%,jj$:Exit_Sub
for i%=1 to 9:item_add num_combo_jour%,"0"+str$(i%):next i%
for i%=10 to maxj%:item_add num_combo_jour%,str$(i%):next i%
End_Sub
' --------------
Sub Boite_Date()
dim Boite_date%,edit_annee%,BT_annee_modif%,combo_mois%,BT_mois_modif%,combo_jour%,BT_jour_modif%,BT_Valid_date%
no%=no%+1:Boite_date%=no%:Container no%:width no%,225:top no%,10:left no%,6:hide no%
          font_color no%,0,0,150:font_name no%,"Arial":height no%,45
no%=no%+1:edit_annee%=no%:edit no%:parent no%,Boite_date%:font_color no%,0,0,255
        width no%,40:top no%,17:left no%,135:color no%,240,240,255
no%=no%+1:BT_annee_modif%=no%:alpha no%:parent no%,Boite_date%
        font_name no%,"wingdings":font_size no%,14:caption no%,chr$(63):font_color no%,0,0,255
        top no%,16:left no%,175:hint no%," Modifier l'Année "
no%=no%+1:combo_mois%=no%:combo no%:parent no%,Boite_date%:color no%,240,240,255:font_color no%,0,0,255
        width no%,40:top no%,17:left no%,72
        for n%=1 to 12
          if n%<10 then item_add no%,"0"+str$(n%)
          if n%>9 then item_add no%,str$(n%)
        next n%
no%=no%+1:BT_mois_modif%=no%:alpha no%:parent no%,Boite_date%:hint no%," Modifier le Mois "
        font_name no%,"wingdings":font_size no%,14:caption no%,chr$(63):font_color no%,0,0,255
        top no%,16:left no%,110
no%=no%+1:combo_jour%=no%:combo no%:parent no%,Boite_date%:color no%,240,240,255:font_color no%,0,0,255
        width no%,40:top no%,17:left no%,5
no%=no%+1:BT_jour_modif%=no%:alpha no%:parent no%,Boite_date%:hint no%," Modifier le Jour "
        font_name no%,"wingdings":font_size no%,16:caption no%,chr$(63):font_color no%,0,0,255
        top no%,14:left no%,43
no%=no%+1:BT_Valid_date%=no%:alpha no%:parent no%,Boite_date%:' font_color no%,0,0,255
        font_name no%,"wingdings":font_size no%,19:caption no%,chr$(67):font_color no%,0,0,255
        top no%,15:left no%,200
End_Sub
' ---------------------------------------------------
Sub Ouvre_Boite(nobj%,W%,H%,T%,L%,T$,NbChr%,Num_Chr%)
width nobj%,W%:height nobj%,H%:top nobj%,T%:left nobj%,L%:cap$=T$:Align_Caption(nobj%,NbChr%,Num_Chr%,cap$):show nobj%
End_Sub
Sub Align_Caption(no%,nb%,numC%,cap$)
if nb%=0 then caption no%," "+cap$+" ":End_sub
cap$=string$(nb%,chr$(numC%))+cap$+string$(nb%,chr$(numC%))
caption no%," "+cap$+" "
End_Sub
' ------------------------------------------------------------------------------