Un petit éphéméride

LABEL Majdat,Clk,Afmail,Sendmail,Aftel
DIM pg%,x%,y%,nc%,nr%,wc%,hr%,c%,r%,i%,js$,a$,b$,c$,aa%,mm%,jj%,m%,j%,lm%(12),mo$(12)
DIM mo%,ao%,fmel$,ftel$,wm$,w100%,ct%,cf%
fmel$ = "C:\TEXTES\Admail.txt": ' liste des adresses email
ftel$ = "C:\TEXTES\Annucompact.txt": ' annuaire téléphonique compact
wm$ = "C:\PROGRA~2\WINDOW~1\WinMail.exe": ' Windows Mail

js$ = "LuMaMeJeVeSaDI"
DATA 31,28,31,30,31,30,31,31,30,31,30,31
FOR i% = 1 TO 12: READ lm%(i%): NEXT i%
DATA "JANVIER","FÉVRIER","MARS","AVRIL","MAI","JUIN","JUILLET","AOÙT","SEPTEMBRE"
DATA "OCTOBRE","NOVEMBRE","DÉCEMBRE"
FOR i% = 1 TO 12: READ mo$(i%): NEXT i%

nc% = 7: nr% = 7: ' nb de colonnes et rangées
wc% = 25: hr% = 20: ' dimensions des cases

WIDTH 0,nc%*wc%+8: HEIGHT 0,185: COLOR 0,0,180,180: BORDER_HIDE 0
    TOP 0,(SCREEN_Y-HEIGHT(0))/2: LEFT 0,(SCREEN_X-WIDTH(0))/2
    FONT_NAME 0,"Arial"
ALPHA 1: TOP 1,2: LEFT 1,20: FONT_SIZE 1,12: FONT_BOLD 1: FONT_COLOR 1,255,255,128

a$ = DATE$
jj% = VAL(LEFT$(a$,2)): mm% = VAL(MID$(a$,4,2)): aa% = VAL(RIGHT$(a$,4))
mo% = mm%: ao% = aa%
pg% = 2
x% = 4: y% = 20: GOSUB Majdat

FONT_BOLD_OFF pg%
BUTTON 10: TOP 10,TOP(pg%)+HEIGHT(pg%)+2: LEFT 10,4: WIDTH 10,20: CAPTION 10,"<<"
BUTTON 11: TOP 11,TOP(10): LEFT 11,WIDTH(10)+5: WIDTH 11,WIDTH(10): CAPTION 11,"<"
BUTTON 12: TOP 12,TOP(11): LEFT 12,LEFT(11)+WIDTH(11)+1: WIDTH 12,WIDTH(11): CAPTION 12,">"
BUTTON 13: TOP 13,TOP(12): LEFT 13,LEFT(12)+WIDTH(12)+1: WIDTH 13,WIDTH(12): CAPTION 13,">>"
BUTTON 14: TOP 14,TOP(13): LEFT 14,LEFT(13)+WIDTH(13)+2: WIDTH 14,29: CAPTION 14,"Mail"
BUTTON 15: TOP 15,TOP(14): LEFT 15,LEFT(14)+WIDTH(14)+1: WIDTH 15,29: CAPTION 15,"Tél."
BUTTON 16: TOP 16,TOP(15): WIDTH 16,30: LEFT 16,WIDTH(0)-34: CAPTION 16,"Quit"
FOR i% = 10 TO 16: HEIGHT i%,20: FONT_BOLD i%: ON_CLICK i%,Clk: NEXT i%
FOR i% = 10 TO 13: FONT_SIZE i%,10: NEXT i%

w100% = 420
FORM 100: HIDE 100: LEFT 100,LEFT(0)-w100%: WIDTH 100,w100%: HEIGHT 100,700
    BORDER_SMALL 100: CAPTION 100,"     -   ADRESSES   EMAIL   -"
LIST 101: PARENT 101,100: WIDTH 101,220: HEIGHT 101,HEIGHT(100)-40: ON_CLICK 101,Sendmail
    FONT_SIZE 101,10: FONT_COLOR 101,0,0,255
LIST 102: PARENT 102,100: LEFT 102,WIDTH(101): WIDTH 102,180: HEIGHT 102,HEIGHT(101)
    FONT_SIZE 102,10
BUTTON 103: PARENT 103,100: TOP 103,HEIGHT(100)-60: WIDTH 103,WIDTH(100)-20
    FONT_BOLD 103: FONT_SIZE 103,12: CAPTION 103,"Cliquer une adresse pour créer un message"
IF FILE_EXISTS(fmel$) = 1
    FILE_OPEN_READ 1,fmel$
    WHILE FILE_EOF(1) = 0
        FILE_READLN 1,a$: b$ = "": i% = INSTR(a$," ")
        IF i% > 0
            b$ = RIGHT_POS$(a$,i%+1): a$ = LEFT$(a$,i%-1)
         END_IF
         ITEM_ADD 101,a$: ITEM_ADD 102,b$
    END_WHILE
    FILE_CLOSE 1
ELSE
    HIDE 14
END_IF

FORM 120: HIDE 120: LEFT 120,LEFT(0)+WIDTH(0): WIDTH 120,250: HEIGHT 120,SCREEN_Y-30
    BORDER_SMALL 120
LIST 121: PARENT 121,120: FULL_SPACE 121
IF FILE_EXISTS(ftel$) = 1
    FILE_LOAD 121,ftel$
ELSE
    HIDE 15
END_IF
END
' ==============================================================================
Majdat:
lm%(2) = 28: Bisex(aa%): IF rs_bi% = 1 THEN lm%(2) = 29
a$ = "- "+mo$(mm%)+"  "+STR$(aa%)+" -": i% = TEXT_WIDTH(a$,1)
LEFT 1,(WIDTH(0)-i%)/2: CAPTION 1,a$
GridPict(pg%,x%,y%,nc%,nr%,wc%,hr%)
FONT_SIZE pg%,10: FONT_BOLD pg%
ct% = 0: cf% = 13158655: ' texte noir sur bleu clair
FOR i% = 1 TO 7: ' jours de la semaine
    a$ = MID$(js$,i%*2-1,2)
    GridPictEcr(pg%,wc%,hr%,i%,1,a$,1,1,ct%,cf%)
NEXT i%
FONT_BOLD_OFF pg%: FONT_COLOR pg%,0,0,255
r% = 2
FOR j% = 1 TO lm%(mm%): ' quantièmes du mois
    Joursem(aa%,mm%,j%): c% = rs_js%: IF c% = 0 THEN c% = 7
    ct% = 0: cf% = 16777215
    IF j% = jj% AND mm% = mo% AND aa% = ao%
        FONT_BOLD pg%: ct%=65536*180: cf%=65536*255+256*255: ' txt rouge sur jaune
    END_IF
    IF r% > nr% THEN nr% = nr%+1
    GridPictEcr(pg%,wc%,hr%,c%,r%,STR$(j%),1,1,ct%,cf%)
    FONT_BOLD_OFF pg%: FONT_COLOR pg%,0,0,255
    IF c% = 7 THEN r% = r%+1
NEXT j%
RETURN
' ==============================================================================
Clk:
i% = NUMBER_CLICK
SELECT i%
    CASE 10: aa% = aa%-1: GOSUB Majdat
    CASE 11: mm% = mm%-1: IF mm% < 1 THEN mm% = 12: aa% = aa%-1
             GOSUB Majdat
    CASE 12: mm% = mm%+1: IF mm% = 13 THEN mm% = 1: aa% = aa%+1
             GOSUB Majdat
    CASE 13: aa% = aa%+1: GOSUB Majdat
    CASE 14: GOSUB Afmail
    CASE 15: GOSUB Aftel
    CASE 16: TERMINATE
END_SELECT

RETURN
' ==============================================================================
Afmail:
SHOW 100
RETURN
' ==============================================================================
Sendmail:
a$ = ITEM_INDEX$(101)
EXECUTE "cmd.exe /c start /B "+wm$+" /mailurl:mailto:"+a$: ' lancement Windows Mail
HIDE 100
RETURN
' ==============================================================================
Aftel:
SHOW 120
RETURN
' ==============================================================================
SUB GridPict(pg%,x%,y%,nc%,nr%,wc%,hr%)
  ' Création d'un picture/grille npg% en x%,y%, nc%/nr% colonnes/rangées,
  ' wc%,hr% dimensions cellules largeur/hauteur (pixels)
  DIM_LOCAL i%
  IF OBJECT_EXISTS(pg%) = 0
    PICTURE pg%: TOP pg%,y%: LEFT pg%,x%: WIDTH pg%,nc%*wc%+1: HEIGHT pg%,nr%*hr%+1
  ELSE
    CLS
  END_IF
  2D_TARGET_IS pg%
  FOR i% = 0 TO WIDTH(pg%) STEP wc%
    2D_LINE i%,0,i%,HEIGHT(pg%)
  NEXT i%
  FOR i% = 0 TO HEIGHT(pg%) STEP hr%
    2D_LINE 0,i%,WIDTH(pg%),i%
  NEXT i%
END_SUB
' ==============================================================================
SUB GridPictxy(pg%,wc%,hr%,c%,r%)
  ' Coordonnées de la cellule colonne c%, rangée r% -> x%,y% (picture/grille pg%)
  x% = (c%-1)*wc%+1
  y% = (r%-1)*hr%+1
END_SUB
' ==============================================================================
SUB GridPictEcr(pg%,wc%,hr%,c%,r%,tx$,ah%,av%,ct%,cf%)
  ' Ecriture texte tx$ dans la cellule c%,r% du picture/grille pg%
  ' (attributs courants): ah%,av% = alignement horizontal et vertical
  ' (0 gauche ou haut, 1 centre, 2 droite ou bas)
  ' ct%: couleur texte (-1 si inchangé), cf%= couleur fond (-1 si inchangé)
  ' (format couleurs: r*65536 + g*256 + b)
  DIM_LOCAL x%,y%,wt%,ht%,cr%,cg%,cb%
  x% = (c%-1)*wc%+3: ' coordonnées de la case cible
  y% = (r%-1)*hr%+1
  2D_TARGET_IS pg%
  IF cf% >= 0: ' couleur fond de la case
      cr%=INT(cf%/65536): cg%=BIN_AND(cf%,65280)/256: cb%=BIN_AND(cf%,255)
      2D_FLOOD x%+2,y%+2,cr%,cg%,cb%
      2D_FILL_COLOR cr%,cg%,cb%
  END_IF
  wt% = TEXT_WIDTH(tx$,pg%): ht% = TEXT_HEIGHT(tx$,pg%)
  IF ah% > 0
    SELECT ah%
        CASE 1: WHILE wt%<wc%: tx$=" "+tx$+" ": wt%=TEXT_WIDTH(tx$,pg%): END_WHILE
        CASE 2: WHILE wt%<wc%: tx$=" "+tx$: wt%=TEXT_WIDTH(tx$,pg%): END_WHILE
    END_SELECT
    tx$ = RIGHT_POS$(tx$,2)
  END_IF
  IF av% > 0
    SELECT av%
        CASE 1: y% = y%+(hr%-ht%)/2
        CASE 2: y% = y%+ hr%-ht%-1
    END_SELECT
  END_IF
  PRINT_TARGET_IS pg%
  IF ct% >= 0: ' couleur texte
      cr%=INT(ct%/65536): cg%=BIN_AND(ct%,65280)/256: cb%=BIN_AND(ct%,255)
      FONT_COLOR pg%,cr%,cg%,cb%
  END_IF
  PRINT_LOCATE x%,y%: PRINT RTRIM$(tx$)
  2D_FILL_COLOR 255,255,255
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 Bisex(Annee)
  IF VARIABLE("rs_bi%") = 0 THEN DIM rs_bi%
  rs_bi% = 0
  IF (FRAC(Annee/4)=0 AND FRAC(Annee/100)>0) OR FRAC(Annee/400)=0 THEN rs_bi% = 1
END_SUB
' ==============================================================================