2013-06-19 07:44

'-------- DATE HANDLING   and   CALENDAR

'-------- LANGUAGE
'$define FRANCAIS
     $IFDEF FRANCAIS
      DEFSTR MonthName(12) = {"","janvier", "février", "mars", "avril", "mai", "juin", "juillet", "août", "septembre", "octobre", "novembre", "décembre"}
      DEFSTR DayName(7) = {"","lundi", "mardi", "mercredi", "jeudi", "vendredi", "samedi","dimanche"}
      CONST WeekStart=1  'lundi=1, dimanche=0
      CONST s_Calendar="Calendrier"
      CONST s_Today="aujourd'hui"
      CONST s_Cancel="Annuler"
     $ELSE
      DEFSTR MonthName(12) = {"","January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December"}
      DEFSTR DayName(7) = {"","Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday","Sunday"}
      CONST WeekStart=0  'Monday=1, Sunday=0
      CONST s_Calendar="Calendar"
      CONST s_Today="Today"
      CONST s_Cancel="Cancel"
     $ENDIF

' 1 - DATE HANDLING
'dates are stored in YYYY-MM-DD format
'function bisex(a as integer) as integer   =  is a leap year
'function nbdaysinmonth(an as integer, mois as integer) as integer = nb of days in given month-year
'function weekday(j as string) as integer = index of day of the week 1=Monday
'function datetext(j as string) as string = date in "Monday 8 November" format
'function advancedays(j as string, n as integer) as string = date j + n days

' 2 - CALENDAR
'function calendrier as string = displays calendar and returns date selected, in YYYY-MM-DD format

     CONST An0=1900 'do not change
     CONST jan1year0=1 'January 1, 1900 = Monday --> 1
     CONST windowwidth=300
     CONST topweek=60 : CONST topdays=85 : CONST topboutons=238
     CONST calMargLeft=20 : CONST calxSize=27
     CONST calyStep=25 : CONST calySize=22

     FUNCTION todaystr AS STRING 'today
      todaystr=MID$(DATE$,7,4)+"-"+MID$(DATE$,1,5)  'date du jour au format YYYY-MM-DD
     END FUNCTION

     FUNCTION numtodate(y AS INTEGER,m AS INTEGER, d AS INTEGER) AS STRING
      numtodate=format$("%4.4d",y)+"-"+format$("%2.2d",m)+"-"+format$("%2.2d",d)
     END FUNCTION

     FUNCTION bisex(a AS INTEGER) AS INTEGER
      IF (a MOD 4)<>0 THEN
       g=0
      ELSEIF (a MOD 400)=0 THEN
       g=1
      ELSEIF (a MOD 100)=0 THEN
       g=0
      ELSE
       g=1
      END IF
      bisex=g
     END FUNCTION

     FUNCTION nbdaysinmonth(an AS INTEGER, mois AS INTEGER) AS INTEGER 'nb of days in given month-year
      SELECT CASE mois
      CASE 2 : nbdaysinmonth=28+bisex(an)
      CASE 4,6,9,11 : nbdaysinmonth=30
      CASE ELSE : nbdaysinmonth=31
      END SELECT
     END FUNCTION

     FUNCTION numweekday(lan AS INTEGER, lemois AS INTEGER, lejour AS INTEGER) AS INTEGER
      DIM d AS LONG
      lan=lan-An0
      d=lan*365 + INT((lan+3)/4) - INT((lan+99)/100) + INT((lan+299)/400)
      FOR i=1 TO lemois-1
       d=d+nbdaysinmonth(An0+lan,i)
      NEXT
      d=d+lejour-1
      r=(d+Jan1year0)MOD 7
      IF r=0 THEN r=7
      numweekday=r
     END FUNCTION

     FUNCTION weekday(j AS STRING) AS INTEGER
      lan= VAL(LEFT$(j,4))
      lemois=VAL(MID$(j,6,2))
      lejour=VAL(MID$(j,9,2))
      weekday=numweekday(lan,lemois,lejour)
     END FUNCTION

     FUNCTION datetext(j AS STRING) AS STRING
      lemois= VAL(MID$(j,6,2))
      lejour$=STR$(VAL(MID$(j,9,2)))
      $IFDEF FRANCAIS
       IF lejour$="1" THEN lejour$="1er"
      $ENDIF
'lan=val(mid$(j,7,4))-2000
      leweekday=weekday(j)
      nomjour$=DayName(leweekday)
      nommois$=MonthName(lemois)
      datetext=nomjour$+" "+lejour$+" "+nommois$
     END FUNCTION

     FUNCTION shortdatetext(j AS STRING) AS STRING
      lemois= VAL(MID$(j,6,2))
      lejour$=STR$(VAL(MID$(j,9,2)))
      leweekday=weekday(j)
      nomjour$=DayName(leweekday)
      nommois$=MonthName(lemois)
      shortdatetext=LEFT$(nomjour$,3)+" "+lejour$+" "+LEFT$(nommois$,3)
     END FUNCTION

     FUNCTION advancedays(j AS STRING, n AS INTEGER) AS STRING 'date j + n days
      lan=VAL(LEFT$(j,4))
      lemois=VAL(MID$(j,6,2))
      lejour=VAL(MID$(j,9,2))+n

      IF n<0 THEN GOTO daysback
      WHILE lejour>nbdaysinmonth(lan,lemois)
       lejour=lejour-nbdaysinmonth(lan,lemois)
       lemois++
       IF lemois=13 THEN lemois=1 : lan++
      WEND
      IF lan>9999 THEN lan=9999 : lemois=12 : lejour=31
      advancedays=numtodate(lan,lemois,lejour)
      EXIT FUNCTION

daysback:
      WHILE lejour<1
       lemois--
       IF lemois=0 THEN lemois=12 : lan--
       lejour=lejour+nbdaysinmonth(lan,lemois)
      WEND
      IF lan<An0 THEN lan=An0 : lemois=1 : lejour=1
      advancedays=numtodate(lan,lemois,lejour)

     END FUNCTION
'----------------- end of DATE HANDLING

'-----------------font Definition
     CREATE fnGros AS QFONT
      name="Trebuchet MS"
      size=12
      addstyles(fsbold)
     END CREATE
     CREATE fnNormal AS QFONT
      name="Trebuchet MS"
      size=10
     END CREATE
     CREATE fnGras AS QFONT
      name="Trebuchet MS"
      size=10
      addstyles(fsbold)
     END CREATE
     CREATE fnGris AS QFONT
      name="Trebuchet MS"
      size=10
      COLOR=&h606060
     END CREATE
     CREATE fnBleu AS QFONT
      name="Trebuchet MS"
      size=10
      COLOR=&hff0000
     END CREATE

'------------------ CALENDAR

     DIM jourchoisi AS STRING  'selected day
     DIM calAn AS INTEGER, calmois AS INTEGER 'current year and month
     DIM aujAn AS INTEGER, aujMois AS INTEGER, aujJour AS INTEGER 'today (start value)
     DIM semaine(6) AS QLABEL  'labels with name of the days
     DIM days(36) AS QCOOLBTN  'buttons for each day
     DECLARE SUB calkey(key AS WORD,shift AS INTEGER) 'key handling
     FUNCTION calendrier AS STRING
      DIM calXstep AS INTEGER
      CREATE cal AS QFORM
       CAPTION = s_Calendar
       Width = windowwidth
       Height = 300
       Center
       keypreview=true
       CREATE lbAn AS QLABEL
        font=fnGros
        CAPTION = "2000"
        Top = 6 : Left = (cal.width-lbAn.width)/2
        Alignment = 2
       END CREATE
       CREATE btAnPrev AS QCOOLBTN
        bmphandle=im_flecheg
        flat=true
        Left = lban.left-30
        Top = 4
       END CREATE
       CREATE btAnNext AS QCOOLBTN
        bmphandle=im_fleched
        Left = lban.left+lban.width+5
        Top = 4
        flat=true
       END CREATE
       CREATE lbMois AS QLABEL
        font=fnGras
        CAPTION = "November" : left=(cal.width-lbMois.width)/2
        Top = 30
        Alignment = 2
       END CREATE
       CREATE btMoisPrev AS QCOOLBTN
        bmphandle=im_flecheg
        flat=true
        Left = lbmois.left-30
        Top = 27
       END CREATE
       CREATE btMoisNext AS QCOOLBTN
        bmphandle=im_fleched
        flat=true
        Left = lbmois.left+lbmois.width+5
        Top = 27
       END CREATE
       CREATE btAuj AS QBUTTON
        CAPTION = s_Today
        Left = (cal.width-btAuj.width)/2: Top = topboutons
       END CREATE
       CREATE btCancel AS QBUTTON
        CAPTION=s_Cancel
        Left = cal.width-calMargLeft-btcancel.width : top=topboutons
       END CREATE
      END CREATE

      SUB showdays  'displays current month
       lbAn.CAPTION=STR$(calAn)
       lbMois.CAPTION=monthname(calMois)
       lbMois.left = (cal.width-lbMois.width)/2
       y=0
       jourdu1=weekday(STR$(calAn)+"-"+STR$(calMois)+"-01")
       nbj=nbdaysinmonth(calAn,calMois)
       startpoint=(jourdu1+7-WeekStart) MOD 7
       FOR i=0 TO startpoint-1
'for i=0 to ((1+jourdu1+WeekStart+11)mod 7)-1
        days(i).visible=false
       NEXT
       lastcase=0
       FOR i=1 TO nbj
'    x=(i+jourdu1+WeekStart+11) mod 7
        x=(i+jourdu1+13-Weekstart)MOD 7
        lastcase=7*y + x
        days(lastcase).CAPTION=STR$(i)
        days(lastcase).visible=true
        days(lastcase).font=fnNormal
        joursem=numweekday(calAn,calMois,i)
        IF joursem>5 THEN days(lastcase).font=fnBleu
        IF (calAn=aujAn)AND(calMois=aujMois)AND(i=aujJour) THEN days(lastcase).font=fnGras
        IF x=6 THEN y++
       NEXT
       FOR j=lastcase +1 TO 36
        days(j).visible=false
       NEXT j
      END SUB 'showdays

      SUB AnNext
       IF calan<9999 THEN
        calAn++
        showdays
       END IF
      END SUB

      SUB AnPrev
       IF calAn>An0 THEN
        calAn--
        showdays
       END IF
      END SUB

      SUB MoisNext
       calMois++
       IF calMois=13 THEN calMois=1 : calAn++
       showdays
      END SUB

      SUB MoisPrev
       IF (calMois<>1)OR(calAn>An0) THEN
        calMois--
        IF calMois=0 THEN calMois=12 : calAn--
        showdays
       END IF
      END SUB

      SUB clickday(Sender AS QCOOLBTN)
       jourchoisi=numtodate(calan,calmois,VAL(sender.CAPTION))
       cal.visible=false
      END SUB

      SUB calAuj
       calAn=VAL(MID$(DATE$,7,4)):calMois=VAL(LEFT$(DATE$,2)):calJour=VAL(MID$(DATE$,4,2))
       showdays
      END SUB

      SUB calCancel
       jourchoisi=""
       cal.visible=false
      END SUB

      SUB calkey(key AS WORD,shift AS INTEGER)
       SELECT CASE key
       CASE 27 : calCancel  'Escape
       CASE 33 : MoisPrev   'PageUp
       CASE 34 : MoisNext   'PageDown
       END SELECT
      END SUB

'btAuj.onkeydown=calkey
'btCancel.onkeydown=calkey
      cal.onkeydown=calkey
      cal.onclose=calcancel
      btAnPrev.onclick=AnPrev : btAnNext.onclick=AnNext
      btMoisPrev.onclick=MoisPrev : btMoisNext.onclick=MoisNext
      btAuj.onclick=calAuj
      btCancel.onclick=calCancel

      calXstep=(windowwidth-2*calMargleft)/7
      FOR i=0 TO 6
       semaine(i).left=calMargLeft + i * calxStep
       semaine(i).top=topweek
       dayindex=(i+weekstart)MOD 7 : IF dayindex=0 THEN dayindex=7
       semaine(i).CAPTION=LEFT$(dayname(dayindex),2)
       semaine(i).font=fnBleu
       semaine(i).PARENT=cal
       semaine(i).alignment=2
       semaine(i).width=CalxSize
      NEXT
      FOR i=0 TO 36
       days(i).left=calMargleft+(i MOD 7) * calXstep
       days(i).top=topdays + INT(i /7) * calYstep
       days(i).width=calXsize
       days(i).height=calYsize
       days(i).flat=true
       days(i).CAPTION=STR$(i)
       days(i).PARENT=cal
       days(i).visible=false
       days(i).onclick=clickday
      NEXT i

      aujAn=VAL(MID$(DATE$,7,4)):aujMois=VAL(LEFT$(DATE$,2)):aujJour=VAL(MID$(DATE$,4,2))
      calAn=aujAn : calMois=aujMois
      showdays
      cal.visible=true
      WHILE cal.visible
       DOEVENTS
      WEND
      calendrier=jourchoisi
     END FUNCTION

2013-06-19 07:44