Voici une nouvelle version de mon agenda.
Le code a été un peu remanié.
Plus besoin de compiler un pbi a part.
la suggestion de Zorro a été pris en compte. Maintenant les jours ou il y a des écritures apparaissent en gras et italique dans les calendriers.
Il ne vous reste plus qu'a trouver 4 icones pour mettre a la place des miennes.
Bon rendez-vous.
Code : Tout sélectionner
;============== MLD =================
;== 20/1/2014- modif le 31/08/2017 ==
;=========== PB 5.60 ================
;==============
;***constantes***
; calendrier journalier
#fenagd = 1:#btajd = 4:
#text1 = 5:#text2 = 6:#text3 = 7:#text4 = 8
#txtj1 = 10:#txtj2 = 11:#txtj3 = 12:#txtj4 = 13:#txtj5 = 14:#txtj6 = 15:#txtj7 = 16:#txtj8 = 17:#txtj9 = 18:#txtj10 = 19
#txtj11 = 20:#txtj12 = 21:#txtj13 = 22:#txtj14 = 23:#txtj15 = 24:#txtj16 = 25:#txtj17 = 26:#txtj18 = 27:#txtj19 = 28:#txtj20 = 29
#txtj21 = 30:#txtj22 = 31:#txtj23 = 32:#txtj24 = 33:#txtj25 = 34:#txtj26 = 35:#txtj27 = 36:#txtj28 = 37:#txtj29 = 38:#txtj30 = 39
#txtj31 = 40:#txtj32 = 41:#txtj33 = 42:#txtj34 = 43:#txtj35 = 44:#txtj36 = 45:#txtj37 = 46:#txtj38 = 47:#txtj39 = 48:#txtj40 = 49
#txtj41 = 50:#txtj42 = 51
#txtj43 = 60:#txtj44 = 61:#txtj45 = 62:#txtj46 = 63:#txtj47 = 64:#txtj48 = 65:#txtj49 = 66:#txtj50 = 67:#txtj51 = 68:#txtj52 = 69
#txtj53 = 70:#txtj54 = 71:#txtj55 = 72:#txtj56 = 73:#txtj57 = 74:#txtj58 = 75:#txtj59 = 76:#txtj60 = 77:#txtj61 = 78:#txtj62 = 79
#txtj63 = 80:#txtj64 = 81:#txtj65 = 82:#txtj66 = 83:#txtj67 = 84:#txtj68 = 85:#txtj69 = 86:#txtj70 = 87:#txtj71 = 88:#txtj72 = 89
#txtj73 = 90:#txtj74 = 91:#txtj75 = 92:#txtj76 = 93:#txtj77 = 94:#txtj78 = 88:#txtj79 = 89:#txtj80 = 90:#txtj81 = 91:#txtj82 = 92
#txtj83 = 93:#txtj84 = 94:#txtj85 = 95:#txtj86 = 96:#txtj87 = 97:#txtj88 = 98:#txtj89 = 99:#txtj90 = 100:#txtj91 = 101:#txtm = 102
;jours de la semaine + mois
#txtjs1 = 111:#txtjs2 = 112:#txtjs3 = 113:#txtjs4 = 114:#txtjs5 = 115:#txtjs6 = 116:#txtjs7 = 117:#txtjs8 = 118:#txt2js1 = 120:#txt2js2 = 121
#txt2js3 = 122:#txt2js4 = 123:#txt2js5 = 124:#txt2js6 = 125:#txt2js7 = 126:#txt2m = 128
;boutons des mois
#btmp1 = 130:#btmm1 = 131
;commades générales
#btstop = 140:#bteffrv = 141:#bteffan = 142:#textefan = 143:#stringefan = 144:#btokefan = 145:#btimp = 146
;pour les autres boutons et gadgets
#texttrai1 = 150:#texttrai2 = 151:#texth8 = 152:#texth830 = 153:#texth9 = 154:#texth930 = 155:#texth10 = 156:#texth1030 = 157:#texth11 = 158
#texth1130 = 159:#texth12 = 160:#texth1230 = 161:#texth13 = 162:#texth1330 = 163:#texth14 = 164:#texth1430 = 165:#texth15 = 166:#texth1530 = 167
#texth16 = 168:#texth1630 = 169:#texth17 = 170:#texth1730 = 171:#texth18 = 172:#texth1830 = 173:#texth19 = 174:#texth1930 = 175:#texth20 = 176
#stringh1 = 177:#stringh2 = 178:#stringh3 = 179:#stringh4 = 180:#stringh5 = 181:#stringh6 = 182:#stringh7 = 183:#stringh8 = 184:#stringh9 = 185
#stringh10 = 186:#stringh11 = 187:#stringh12 = 188:#stringh13 = 189:#stringh14 = 190:#stringh15 = 191:#stringh16 = 192:#stringh17 = 193
#stringh18 = 194:#stringh19 = 195:#stringh20 = 196:#stringh21 = 197:#stringh22 = 198:#stringh23 = 199:#stringh24 = 200:#stringh25 = 201
#texttrai3 = 202:#texttrai4 = 203:#texttrai5 = 204:#agimg = 205:#textinfo = 206
;fichier
#Fag = 500
;images
#Image0 = 900:#Image1 = 901:#Image2 = 902:#Image3 = 903:#Image4 = 904
;ecran
#Ldef = 1280 :#Hdef = 800
;***fin constantes***
CatchImage(#Image0, ?Image0)
CatchImage(#Image1, ?Image1)
CatchImage(#Image2, ?Image2)
CatchImage(#Image3, ?Image3)
CatchImage(#Image4, ?Image4)
DataSection
Image0: :IncludeBinary "47.ico";icone pour le bouton arrêt du logiciel
Image1: :IncludeBinary "283.ico";icone pour le bouton efface la ligne en cours
Image2: :IncludeBinary "315.ico";icone pour le bouton imprime
Image3: :IncludeBinary "378.ico";icone pour le bouton supprime une année
Image4: :IncludeBinary "380.ico";icone montre ou réveil matin pour faire joli
EndDataSection
If DefaultPrinter() <> 0
printer_DC.l = StartDrawing(PrinterOutput())
If printer_DC.l
DPIHZ.l = GetDeviceCaps_(printer_DC,#LOGPIXELSX)
EndIf
StopDrawing()
EndIf
Select DPIHZ.l
Case 600
Global FontID6 = LoadFont(6,"MS san serif",60 ,#PB_Font_HighQuality);pour imprimante
Default
Global FontID6 = LoadFont(6,"MS san serif",30 ,#PB_Font_HighQuality);pour imprimante
EndSelect
Global tdate$
Global indstrok.B = 0
Global av$
Declare affcal(tdate$)
Declare moischif(nommois$)
Declare compare(av$,ap$)
Declare detectext()
Global FontID1 = LoadFont(1,"MS san serif",12 ,#PB_Font_HighQuality)
Global FontID2 = LoadFont(2,"MS san serif",18 ,#PB_Font_HighQuality)
Global FontID3 = LoadFont(3,"MS san serif",14 ,#PB_Font_HighQuality)
Global FontID4 = LoadFont(4,"MS san serif",36 ,#PB_Font_HighQuality)
Global FontID5 = LoadFont(5,"MS san serif",28 ,#PB_Font_HighQuality)
Global FontID7 = LoadFont(7,"MS san serif",12 ,#PB_Font_Bold|#PB_Font_Italic|#PB_Font_HighQuality)
Global EPframeH.d,EPframeL.d
Macro coulfond(gad)
SetGadgetColor(gad,#PB_Gadget_BackColor,$CCCCCC)
EndMacro
Procedure resizefontecran(gad,num.b)
definecrlt.d = GetSystemMetrics_(#SM_CXSCREEN)
Select num
Case 1
If definecrlt.d > 1441
SetGadgetFont(gad, FontID(1))
EndIf
Case 2
If definecrlt.d > 1400
SetGadgetFont(gad, FontID(2))
Else
SetGadgetFont(gad, FontID(3))
EndIf
Case 3
If definecrlt.d > 1400
SetGadgetFont(gad, FontID(3))
Else
SetGadgetFont(gad, FontID(1))
EndIf
Case 4
If definecrlt.d > 1400
SetGadgetFont(gad, FontID(4))
Else
SetGadgetFont(gad, FontID(5))
EndIf
EndSelect
EndProcedure
Procedure GestionCaret(Gadget) ; Gestion du caret dans stringGadget
SendMessage_(GadgetID(Gadget), #EM_GETSEL, @Debut_Position, @Fin_position)
y = Debut_Position
Texte.s = GetGadgetText(Gadget)
x =Len(Texte)
Texte2.s = Left(Texte,y ) + Right(Texte,x-y)
SendMessage_(GadgetID(Gadget), #EM_SETSEL, x, x)
EndProcedure
;>>>>>>>>>>>>>>>>>>>>>>>>> Fen auto >>>>>>>>>>>>>>>>>>>>>
Procedure Ywp(hp.d,optwp.i)
definecrht.d = GetSystemMetrics_(#SM_CYSCREEN)
Select optwp.i
Case 1
ProcedureReturn 0 ;en haut de l'écran
Case 2
If definecrht.d = #Hdef
ProcedureReturn hp * 1
Else
ProcedureReturn hp * (definecrht /#Hdef)
EndIf
EndSelect
EndProcedure
Procedure Hw(Dh.d)
definecrht.d = GetSystemMetrics_(#SM_CYSCREEN)
Define tepSVEData.RECT:Define tpeAPPData.APPBARDATA
SHAppBarMessage_(5,tpeAPPData)
tepSVEData\top = tpeAPPData\rc\Top
tepSVEData\bottom = tpeAPPData\rc\Bottom
htTaskbarwin = tepSVEData\bottom - tepSVEData\top
OpenWindow(2000,0,0,200,200,"",#PB_Window_SystemMenu|#PB_Window_Invisible)
GetTitleBarInfo_(WindowID(2000),pti)
If OSVersion() = #PB_OS_Windows_XP
EPframeH.d = WindowX(2000, #PB_Window_InnerCoordinate)
EPframeL.d = WindowX(2000, #PB_Window_InnerCoordinate)
Else
EPframeH = (WindowX(2000, #PB_Window_InnerCoordinate)*3)
EPframeL = WindowX(2000, #PB_Window_InnerCoordinate)
EndIf
Httitre.i = WindowY(2000, #PB_Window_InnerCoordinate)
CloseWindow(2000)
If definecrht <> #Hdef
hwq.d = Dh * (definecrht /#Hdef)
ProcedureReturn Hwq.d
Else
Hwq.d = Dh
ProcedureReturn Hwq.d
EndIf
EndProcedure
Procedure XWp(lp.d,optwp.i)
definecrlt.d = GetSystemMetrics_(#SM_CXSCREEN)
Select optwp.i
Case 1
ProcedureReturn 2 ;a gauche
Case 2
If definecrlt <> #Ldef
ProcedureReturn lp.d * (definecrlt /#Ldef)
Else
ProcedureReturn lp.d
EndIf
EndSelect
EndProcedure
Procedure Lw(Dl.d,optw.i)
definecrlarg = GetSystemMetrics_(#SM_CXSCREEN)
Select optw.i
Case 1 ;largeur max avec bordure
Lbw.d = definecrlarg - ((EPframeL*2)+4)
ProcedureReturn Lbw.d
Case 2 ;largeur max sans bordure
Lbw.d = definecrlarg
ProcedureReturn Lbw.d
Case 3 ;largeur quelconque
If definecrlarg <> #Ldef
hwq.d = Dl* (definecrlarg /#Ldef)
ProcedureReturn hwq.d
Else
Lbw.d = Dl
ProcedureReturn Lbw.d
EndIf
EndSelect
EndProcedure
Procedure kh(Gh.d)
definecrht.d = GetSystemMetrics_(#SM_CYSCREEN)
If definecrht = #Hdef
ProcedureReturn Gh
Else
ProcedureReturn Gh * (definecrht/#Hdef)
EndIf
EndProcedure
Procedure kl(Gl.d)
definecrlarg.d = GetSystemMetrics_(#SM_CXSCREEN)
If definecrlarg = #Ldef
ProcedureReturn Gl
Else
ProcedureReturn Gl *(definecrlarg /#Ldef)
EndIf
EndProcedure
Procedure Forme(win)
Region = CreateRoundRectRgn_(0, 0, WindowWidth(win), WindowHeight(win), 20, 20) ; Création de la région pour faire une fenêtre avec les angles arrondis
SetWindowRgn_(WindowID(win), Region, #True) ; On applique la région
DeleteObject_(Region) ; On supprime la région
EndProcedure
Procedure ToolTipMic(WindowNumber.l,GadgetNumber.l,Text.s,couleurf)
Protected Balloon.TOOLINFO
Tooltip=CreateWindowEx_(0,"ToolTips_Class32","",#WS_POPUP | #TTS_NOPREFIX | #TTS_BALLOON,0,0,0,0,WindowID(WindowNumber),0,GetModuleHandle_(0),0)
SendMessage_(Tooltip,#TTM_SETTIPTEXTCOLOR,GetSysColor_(#COLOR_INFOTEXT),0)
SendMessage_(Tooltip,#TTM_SETTIPBKCOLOR,couleurf,0)
SendMessage_(Tooltip,#TTM_SETMAXTIPWIDTH,0,180)
Balloon\cbSize=SizeOf(TOOLINFO)
Balloon\uFlags=#TTF_IDISHWND | #TTF_SUBCLASS
If IsGadget(GadgetNumber)
Balloon\hwnd=GadgetID(GadgetNumber)
Balloon\uId=GadgetID(GadgetNumber)
Else
Balloon\hwnd=GadgetNumber
Balloon\uId=GadgetNumber
EndIf
Balloon\lpszText=@Text
SendMessage_(Tooltip,#TTM_ADDTOOL,0,@Balloon)
ProcedureReturn Tooltip
EndProcedure
;=========== fichier =================
Global numenrfag.w
Procedure.l nbenrfag(fichier$)
ReadFile(#Fag,fichier$)
lectlig$ = ReadString(#Fag)
nbenrligne.l = Lof(#Fag)/(Len(lectlig$)+2)
CloseFile(#Fag)
ProcedureReturn nbenrligne.l
EndProcedure
Procedure.l enrfag(Numenrfich.w)
a$ = Str(Numenrfich.w) + Space(5 - Len(Str(Numenrfich.w)))+Chr(191)
b$ = Right(tdate$,4)
c$ = Mid(tdate$,3,2)
If Left(c$,1) = "0" :c$ = Mid(c$,2,1):EndIf
d$ = Left(tdate$,2)
e$ = (b$ + c$ + d$) + Space(8 - (Len(b$)+Len(c$)+Len(d$)))+Chr(191)
ligjour$ = a$ + e$
For zz = 177 To 201
ligjour$ = ligjour$ + GetGadgetText(zz)+ Space(60 - Len(GetGadgetText(zz)))+Chr(191)
Next
OpenFile(#Fag,"Agd.mld")
Nbenrfich.w = (Lof(#Fag)/(Len(ligjour$)+2))
If Numenrfich.w > Nbenrfich.w
FileSeek(#Fag,Lof(#Fag));positionne a la fin du fichier
Else
FileSeek(#Fag,(Numenrfich.w * 1542)-1542);positionne sur le début de la bonne ligne
EndIf
WriteStringN(#Fag,ligjour$);enregistre
CloseFile(#Fag)
EndProcedure
Procedure controllect(tdate$)
For xz = 177 To 201 ;raz des strings
SetGadgetText(xz,"")
Next
Global av$ = ""
b$ = Right(tdate$,4)
c$ = Mid(tdate$,3,2)
If Left(c$,1) = "0" :c$ = Mid(c$,2,1):EndIf
d$ = Left(tdate$,2)
e$ = b$ + c$ + d$
Okenr.b = 0
If ReadFile(#Fag, "Agd.mld")
While Eof(#Fag) = 0
ligjour$ = ReadString(#Fag)
If e$ = Trim(StringField(ligjour$,2,Chr(191)))
okenr = 1
Break
EndIf
Wend
CloseFile(#Fag)
EndIf
If okenr = 1 ;des enregistrement a cette date existe
indstring.w = 2 ;remplis les strings
For zz = 177 To 201
indstring = indstring +1
SetGadgetText(zz,Trim(StringField(ligjour$,indstring ,Chr(191))))
GestionCaret(zz)
Next
Global numenrfag.w = Val(StringField(ligjour$,1,Chr(191))) ; indique le numéro de ligne enregistrée
For zx = 177 To 201
av$ = av$ + Trim(GetGadgetText(zx)); remplis une variable avec les strings pour comparaison avant enr
Next
Else
For zx = 177 To 201
av$ = av$ + Trim(GetGadgetText(zx)); remplis une variable avec les strings pour comparaison avant enr
Next
numenrfag.w = 0
EndIf
SetActiveGadget(177)
EndProcedure
Procedure controlenr()
OpenFile(#Fag,"Agd.mld") ;pour la première utilisation du logiciel
If nbenrfag("Agd.mld")= 0
EndIf
For zx = 177 To 201 ;remplis une variable avec les strings pour comparaison avant enr (pour <> avec la var lecture)
ap$ = ap$ + Trim(GetGadgetText(zx))
Next
If numenrfag.w = 0 ; c'est un nouvel enr
If compare(av$,ap$) = 1
numenrfag.w = nbenrfag("Agd.mld") +1
enrfag(numenrfag.w)
EndIf
Else
If compare(av$,ap$) = 1 ;c'est une modif des RV
enrfag(numenrfag.w)
EndIf
EndIf
ap$ = ""
EndProcedure
;======================================
Procedure bissextile(annee)
If (annee % 4 = 0 And annee % 100 <> 0) Or annee % 400 = 0
bissextile= #True
Else
bissextile = #False
EndIf
ProcedureReturn bissextile
EndProcedure
Procedure Ffix(j,m)
Dt$ = Str(j) + "/" + Str(m)
Select Dt$
Case "1/1" ;1er janvier
indf.B = 1
Case "1/5" ;1er mai
indf.B = 1
Case "8/5" ;8 mai
indf.B = 1
Case "14/7" ;14 juillet
indf.B = 1
Case "15/8" ;15 aout
indf.B = 1
Case "1/11" ;1 Novembre
indf.B = 1
Case "11/11" ;11 novembre
indf.B = 1
Case "25/12" ;25 décembre
indf.B = 1
Default
indf.B = 0
EndSelect
ProcedureReturn indf.B
EndProcedure
Procedure calulftrelig(jr,mr,y)
datref$ = FormatDate("%dd%mm%yyyy",Date(y,mr,jr,0,0,0))
;dimanche de paque
c.w = y / 100
n.w = (y % 19)
k.w = (c - 17) / 25
b.w = c /4
e.w = (c - k) / 3
f.w = c - b - e + (19 * n) + 15
h.w = (f % 30)
p.w = h / 28
q.w = 29 / (h + 1)
r.w = (21 - n) / 11
i.w = h - (p * (1 - (p * q * r)))
s.w = y / 4
t.w = c / 4
u.w = y + s + i + 2 - c + t
j.w = (u % 7)
w.w = (i - j + 40) / 44
m.w = 3 + w
x.w = m / 4
d.w = i - j + 28 - (31 * x)
Dimanchepaque$ = FormatDate("%dd%mm%yyyy",Date(y,m,d,0,0,0))
lundipaque$ = FormatDate("%dd%mm%yyyy",AddDate(Date(y,m,d,0,0,0),#PB_Date_Day,1))
jeudiasc$ = FormatDate("%dd%mm%yyyy",AddDate(Date(y,m,d,0,0,0),#PB_Date_Day,39))
dimanchepent$ = FormatDate("%dd%mm%yyyy",AddDate(Date(y,m,d,0,0,0),#PB_Date_Day,49))
lundipent$ = FormatDate("%dd%mm%yyyy",AddDate(Date(y,m,d,0,0,0),#PB_Date_Day,50))
indftm.b = 0
If datref$ = Dimanchepaque$
indftm.b = 1
EndIf
If datref$ = lundipaque$
indftm.b = 1
EndIf
If datref$ = jeudiasc$
indftm.b = 1
EndIf
If datref$ = dimanchepent$
indftm.b = 1
EndIf
If datref$ = lundipent$
indftm.b = 1
EndIf
ProcedureReturn indftm.b
EndProcedure
Procedure.i DF(date.i);dimanche europe
d.i = DayOfWeek(date)
If d = 0 :d = 7 :EndIf ;dimanche, retourne 7 au lieu de 0
ProcedureReturn d
EndProcedure
Procedure.s calculnumjour(an,mois,jour,z1,z2,z3);calcul le nombre de jour écoulé a la date indiqué et ce qui reste
;======= calcul jour ==========
If bissextile(an) = 1
totalj.w = 366
Else
totalj.w = 365
EndIf
nbjt.w = DayOfYear(Date(an, mois, jour, 0, 0, 0))
diffjour.w = totalj - nbjt.w
;======= calcul num semaine =====
Date = Date(an,mois,jour,z1,z2,z3)
jda.i = DayOfYear(date): an.i = Year(date)
DjanP.i = 4 - DF(Date(an, 1, 4, 0,0,0));dernier jour année précédente
Djan.i = 4 - DF(Date(an,12,28, 0,0,0)) + DayOfYear(Date(an,12,31, 0,0,0));dernier jour de l'année
If jda.i <= Djan.i
If jda.i <= DjanP.i
jda.i + DayOfYear(Date(an-1,12,31, 0,0,0));le 1er est dans la dernière semaine de l'année précédente.
DjanP.i = 4 - DF(Date(an-1,1,4, 0,0,0))
EndIf
Weeknum = Round((jda-DjanP)/7, #PB_Round_Up)
Else ;si non c'est dans la 1ere semaine
Weeknum = 1
EndIf
ProcedureReturn "Semaine: " + Str(Weeknum) + " " + "Jour: " + Str(nbjt.w) + "/" + Str(totalj) + "-" + Str(diffjour)
EndProcedure
Procedure calculnbjm(an,mois,jour,z1,z2,z3)
Select mois
Case 1,3,5,7,8,10,12 ; calcul le nombre de jours par mois
nbjpm.w = 31
Case 2
If bissextile(an) = 1 ; tien compte des années bissextiles
nbjpm.w = 29
Else
nbjpm.w = 28
EndIf
Case 4,6,9,11
nbjpm.w = 30
EndSelect
ProcedureReturn nbjpm.w
EndProcedure
Procedure cal()
; ============ cal gauche================
posh = 20
poshl = 21
posv = 50
posvh = 16
posjs = 34
posD.w = 0
For x = 10 To 51
posD = posD +1
Select x
Case 11 To 16 ,18 To 23 ,25 To 30,32 To 37, 39 To 44,46 To 51
posh = posh + poshl
EndSelect
If x = 17 Or x = 24 Or x = 31 Or x = 38 Or x = 45
posv = posv + posvh
posh = 20
EndIf
TextGadget(x,kl(posh),kh(posv),kl(20),kh(15),"",#PB_Text_Center|#SS_NOTIFY)
resizefontecran(x,1)
coulfond(x);coulfond gad
Next
posh = 20
For y= 1 To 7
numsem$ = StringField("Lu,Ma,Me,Je,Ve,Sa,Di",y,",")
TextGadget(y +110,kl(posh),kh(posjs),kl(20),kh(15),numsem$,#PB_Text_Center)
resizefontecran(y,1)
coulfond(y+110);coulfond gad
posh = posh + poshl
Next
TextGadget(102,kl(20),kh(posjs-16),kl(140),kh(15),"",#PB_Text_Center)
resizefontecran(102,1)
; ================ cal droit =====================
posh = 340
poshl = 21
posv = 50
posvh = 16
posjs = 34
posD = 0
For x = 60 To 101
posD = posD +1
Select x
Case 61 To 66 ,68 To 73 ,75 To 80,82 To 87, 89 To 94, 96 To 101;place les textgad
posh = posh + poshl
EndSelect
If x = 67 Or x = 74 Or x = 81 Or x = 88 Or x = 95;1er textgad de la ligne
posv = posv + posvh
posh = 340
EndIf
TextGadget(x,kl(posh),kh(posv),kl(20),kh(15),"",#PB_Text_Center|#SS_NOTIFY)
resizefontecran(x,1)
coulfond(x);coulfond gad
Next
posh = 340
For y= 1 To 7
numsem$ = StringField("Lu,Ma,Me,Je,Ve,Sa,Di",y,",");inscrit les jours
TextGadget(y +120,kl(posh),kh(posjs),kl(20),kh(15),numsem$,#PB_Text_Center)
coulfond(y+120);coulfond gad
resizefontecran(y,1)
posh = posh + poshl
Next
TextGadget(128,kl(340),kh(posjs-16),kl(140),kh(15),"",#PB_Text_Center);mois
resizefontecran(128,1)
TextGadget(8,kl(167),kh(130),kl(163),kh(17),"",#PB_Text_Center)
resizefontecran(8,1)
SetGadgetColor(8,#PB_Gadget_FrontColor,$858585)
coulfond(8);coulfond gad
EndProcedure
Procedure affcal(tdate$)
jour.w = Val(Left(tdate$,2));transforme la date en chiffres
mois.w = Val(Mid(tdate$,3,2))
an.w = Val(Right(tdate$,4))
Moisl$ = "JANVIER,FEVRIER,MARS,AVRIL,MAI,JUIN,JUILLET,AOUT,SEPTEMBRE,OCTOBRE,NOVEMBRE,DECEMBRE"
Jourl$ = "Dimanche,Lundi,Mardi,Mercredi,Jeudi,Vendredi,Samedi"
For x = 10 To 51
SetGadgetText(x,"");raz des textgad,couleurs,font
SetGadgetColor(x,#PB_Gadget_FrontColor,$0):resizefontecran(x,1)
Next
For xa = 16 To 51 Step 7
SetGadgetColor(xa,#PB_Gadget_FrontColor,$0000FF):resizefontecran(xa,1)
Next
For xx = 60 To 101
SetGadgetText(xx,"")
SetGadgetColor(xx,#PB_Gadget_FrontColor,$707070):resizefontecran(xx,1)
Next
For xb = 66 To 101 Step 7
SetGadgetColor(xb,#PB_Gadget_FrontColor,$0000FF):resizefontecran(xb,1)
Next
;=========== affiche cal gauche ===========
premjour.w = DayOfWeek(Date(an,mois,1,0,0,0));Calcul le 1er jour du mois
If premjour.w = 0 :premjour.w = 7 :EndIf ; pour le placement donne le num 7 au dimanche au lieu de 0
nbjpm.w = calculnbjm(an,mois,jour,0,0,0)
jm = 0
For j = 10 + (premjour.w -1) To (10 + nbjpm.w + (premjour.w-1))-1; remplis les textgads en tenant compte du
jm = jm +1 ; premier jour du mois
SetGadgetText(j,Str(jm))
If Ffix(jm,mois) = 1 Or calulftrelig(jm,mois,an)
SetGadgetColor(J,#PB_Gadget_FrontColor,$0000FF)
EndIf
Next
numois.w = Month(Date(an,mois,jour,0,0,0))
SetGadgetText(102,StringField(Moisl$,numois.w,",")+ " " + Str(an))
coulfond(102);coulfond gad
;=== affichage du centre cal ========
TextGadget(5,kl(167),kh(15),kl(163),kh(30),StringField(Jourl$,DayOfWeek(Date(an,mois,jour,0,0,0))+1,","),#PB_Text_Center)
coulfond(5);coulfond gad
resizefontecran(5,2)
TextGadget(6,kl(167),kh(45),kl(163),kh(40),Str(jour),#PB_Text_Center)
coulfond(6);coulfond gad
resizefontecran(6,4)
SetGadgetColor(6, #PB_Gadget_FrontColor,$0045FF)
TextGadget(7,kl(167),kh(100),kl(163),kh(25),StringField(Moisl$,numois.w,","),#PB_Text_Center)
coulfond(7);coulfond gad
resizefontecran(7,2)
;==========================================
;===== calcul num semaine et nb jour ======
SetGadgetText(8,calculnumjour(an,mois,jour,0,0,0))
;===========================================
;===== calcul la position du jour (aujourd'hui) ======
If mois = Val(FormatDate("%mm",Date()))
posjourj.w = (10 + premjour.w + Val(FormatDate("%dd",Date())) ) -2
SetGadgetColor(posjourj.w,#PB_Gadget_FrontColor,$FAFAFF) ;et color
EndIf
;============================================
;============ affiche cal droit ===============
; ;attention si cal gauche est a 12 mois rectifier la date
If mois.w = 12
jour.w = Val(Left(tdate$,2))
mois.w = 0
an.w = an.w + 1
EndIf
premjour2.w = DayOfWeek(Date(an,mois+1,1,0,0,0))
If premjour2.w = 0 :premjour2.w = 7 :EndIf
mois = mois +1
nbjpm2.w = calculnbjm(an,mois,jour,0,0,0)
jmd = 0
For jd = 60 + (premjour2.w-1) To (60 + nbjpm2.w + (premjour2.w-1))-1
jmd = jmd +1
SetGadgetText(jd,Str(jmd))
If Ffix(jmd,mois) = 1 Or calulftrelig(jmd,mois,an)
SetGadgetColor(Jd,#PB_Gadget_FrontColor,$0000FF)
EndIf
Next
numois2.w = Month(Date(an,mois,1,0,0,0))
SetGadgetText(128,StringField(Moisl$,numois2.w,",")+ " " + Str(an))
coulfond(128);coulfond gad
If indstrok.B = 1;permet d'afficher dans les strings
controllect(tdate$)
EndIf
detectext();*************
EndProcedure
Procedure clickcal(tdate$,gad,gd.s)
jour.w = Val(Left(tdate$,2));transforme la date en chiffres
mois.w = Val(Mid(tdate$,3,2))
an.w = Val(Right(tdate$,4))
Moisl$ = "JANVIER,FEVRIER,MARS,AVRIL,MAI,JUIN,JUILLET,AOUT,SEPTEMBRE,OCTOBRE,NOVEMBRE,DECEMBRE"
Jourl$ = "Dimanche,Lundi,Mardi,Mercredi,Jeudi,Vendredi,Samedi"
;=== affichage du centre cal ========
numois.w = Month(Date(an,mois,1,0,0,0))
If DayOfWeek(Date(an,mois,jour,0,0,0)) = 0
cj.w = 1
Else
cj.w = DayOfWeek(Date(an,mois,jour,0,0,0)) +1
EndIf
SetGadgetText(5,StringField(Jourl$,cj,","))
SetGadgetText(6,Str(jour))
SetGadgetText(7,StringField(Moisl$,numois.w,","))
;===== calcul num semaine et nb jour ======
SetGadgetText(8,calculnumjour(an,mois,jour,0,0,0))
;===========================================
Static posclik.w
Static colorbase
If posclik.w <> 0
SetGadgetColor(posclik.w,#PB_Gadget_FrontColor,colorbase)
EndIf
posclik.w = gad
colorbase = GetGadgetColor(posclik.w,#PB_Gadget_FrontColor)
SetGadgetColor(posclik.w,#PB_Gadget_FrontColor,$00FFFF)
If indstrok.B = 1;permet d'afficher dans les strings
controllect(tdate$)
EndIf
EndProcedure
Procedure moischif(nommois$)
Select nommois$
Case "JANVIER"
numero.w = 1
Case "FEVRIER"
numero.w = 2
Case "MARS"
numero.w = 3
Case "AVRIL"
numero.w = 4
Case "MAI"
numero.w = 5
Case "JUIN"
numero.w = 6
Case "JUILLET"
numero.w = 7
Case "AOUT"
numero.w = 8
Case "SEPTEMBRE"
numero.w = 9
Case "OCTOBRE"
numero.w = 10
Case "NOVEMBRE"
numero.w = 11
Case "DECEMBRE"
numero.w = 12
EndSelect
ProcedureReturn numero.w
EndProcedure
Procedure compare(av$,ap$)
indenr.B = 0
If Len(av$) <> Len(ap$)
indenr = 1
Else
For zz.w = 1 To Len(av$)
If Mid(av$,zz,1) <> Mid(ap$,zz,1)
indenr = 1
Break
EndIf
Next
EndIf
ProcedureReturn indenr
EndProcedure
Procedure infos(*valeur)
Select *valeur
Case 1
SetGadgetColor(206,#PB_Gadget_FrontColor,$0000FF)
SetGadgetText(206, "Il manque une date ?")
Sleep_(3500)
SetGadgetText(206, "")
Case 2
SetGadgetColor(206,#PB_Gadget_FrontColor,$006400)
SetGadgetText(206, "Année supprimée")
Sleep_(2500)
HideGadget(143,1)
SetGadgetText(144,"")
HideGadget(144,1)
HideGadget(145,1)
SetActiveGadget(177)
SetGadgetState(142,0)
SetGadgetText(206, "")
Case 3
SetGadgetColor(206,#PB_Gadget_FrontColor,$0000FF)
SetGadgetText(206, "Impréssion impossible")
Sleep_(3500)
SetGadgetText(206, "")
EndSelect
EndProcedure
Procedure supan(an$)
If an$ <> ""
indgr.w = 0
Dim Tabrv.s(0)
If ReadFile(#Fag, "Agd.mld")
While Eof(#Fag) = 0
ligjour$ = ReadString(#Fag)
If an$ <> Trim(Left(Trim(StringField(ligjour$,2,Chr(191))),4))
indgr = indgr + 1
ReDim Tabrv(indgr)
Tabrv.s(indgr) = ligjour$
EndIf
Wend
EndIf
CloseFile(#Fag)
CreateFile(#Fag, "Agd.mld")
For zy.w = 1 To ArraySize(Tabrv())
WriteStringN(#Fag,Tabrv(zy))
Next
FreeArray(Tabrv.s())
CreateThread(@infos(),2)
Else
CreateThread(@infos(),1)
EndIf
EndProcedure
Procedure impjour()
If DPIHZ = 600;prend en compte le DPI imprimante 300 ou 600
kdpi.l = 1
Else
kdpi.l = 2
EndIf
If StartPrinting("agenda")
htpagemm = PrinterPageHeight()
margg = 229/kdpi.l
margd = 229/kdpi.l
margbas = htpagemm - (1145/kdpi.l)
intlig = 68/kdpi.l
deplig = 687/kdpi.l
If StartDrawing(PrinterOutput())
DrawingMode(#PB_2DDrawing_Transparent)
FrontColor($0)
DrawingFont(FontID(6))
a$ = GetGadgetText(5) + " " + GetGadgetText(6) + " " + GetGadgetText(7)+ " " + Right(tdate$,4)
DrawText(280/kdpi.l,229/kdpi.l,a$)
lig = lig + (intlig*6)
DrawText(margg ,lig ,"")
For z = 152 To 176
lig = lig + (intlig*3)
ip$ = GetGadgetText(z) + " " + GetGadgetText(z + 25)
DrawText(margg + (40/kdpi.l),lig ,ip$)
Next
EndIf
StopDrawing()
StopPrinting()
EndIf
EndProcedure
Procedure detectext()
anencours.w = Val(Right(tdate$,4))
moisencours.w = Val(Mid(tdate$,3,2))
anmoisencours$ = Right(tdate$,4) + Str(moisencours.w)
anmoisencoursp1$ = Right(tdate$,4) + Str(moisencours.w+1)
If ReadFile(#Fag, "Agd.mld")
While Eof(#Fag) = 0
ligjour$ = ReadString(#Fag)
Lectdat$ = Trim(StringField(ligjour$,2,Chr(191)))
anmois$ = Left(Lectdat$,Len(Lectdat$)-2)
If anmoisencours$ = anmois$
jourenr$ = Right(Lectdat$,2)
For x =10 To 51
If Len(GetGadgetText(x))< 2 :ad$ = "0" + GetGadgetText(x):Else:ad$ = GetGadgetText(x):EndIf
If ad$ = jourenr$
SetGadgetFont(x, FontID(7))
Break
EndIf
Next
EndIf
If anmoisencoursp1$ = anmois$
jourenr$ = Right(Lectdat$,2)
For xx =60 To 101
If Len(GetGadgetText(xx))< 2 :ad2$ = "0" + GetGadgetText(xx):Else:ad2$ = GetGadgetText(xx):EndIf
If ad2$ = jourenr$
SetGadgetFont(xx, FontID(7))
Break
EndIf
Next
EndIf
Wend
CloseFile(#Fag)
EndIf
EndProcedure
OpenWindow(1,Xwp(0,1),ywp(0,1),Lw(500,3),Hw(750), "Agenda",#PB_Window_BorderLess|#PB_Window_ScreenCentered )
Forme(1)
StickyWindow(1, 1)
SetWindowColor(1,$CCCCCC)
cal()
tdate$ = FormatDate("%dd%mm%yyyy",Date())
affcal(tdate$)
TextGadget(150,kl(30),kh(157),kl(18),kh(1),"")
SetGadgetColor(150,#PB_Gadget_BackColor,$FF0000)
TextGadget(202,kl(132),kh(157),kl(76),kh(1),"")
SetGadgetColor(202,#PB_Gadget_BackColor,$FF0000)
TextGadget(203,kl(292),kh(157),kl(76),kh(1),"")
SetGadgetColor(203,#PB_Gadget_BackColor,$FF0000)
TextGadget(204,kl(452),kh(157),kl(18),kh(1),"")
SetGadgetColor(204,#PB_Gadget_BackColor,$FF0000)
TextGadget(151,kl(30),kh(702),kl(440),kh(1),"")
SetGadgetColor(151,#PB_Gadget_BackColor,$FF0000)
ImageGadget(205,kl(50),kh(180),kl(40),kh(40),ImageID(#Image4))
ButtonGadget(4,kl(210),kh(150),kl(80),kh(15),Chr(60)+ Chr(62))
ButtonGadget(130,kl(370),kh(150),kl(80),kh(15),Chr(62)+ Chr(62))
ButtonGadget(131,kl(50),kh(150),kl(80),kh(15),Chr(60)+ Chr(60))
ButtonImageGadget(140,kl(420),kh(707),kl(40),kh(40),ImageID(#Image0))
ToolTipMic(1,140, "Arrêt Agenda",$C9FBFD)
ButtonImageGadget(141,kl(380),kh(707),kl(40),kh(40),ImageID(#Image1))
ToolTipMic(1,141, "Efface la ligne en cours",$C9FBFD)
ButtonImageGadget(146,kl(340),kh(707),kl(40),kh(40),ImageID(#Image2))
ToolTipMic(1,146, "Imprime la journée",$C9FBFD)
ButtonImageGadget(142,kl(300),kh(707),kl(40),kh(40),ImageID(#Image3),#PB_Button_Toggle)
ToolTipMic(1,142,"Supprime une année",$C9FBFD)
TextGadget(143,kl(145),kh(712),kl(80),kh(15),"Supprime année")
resizefontecran(143,1)
HideGadget(143,1)
coulfond(143);coulfond gad
StringGadget(144,kl(145),kh(728),kl(80),kh(16),"",#PB_String_Numeric|#ES_CENTER|#PB_String_BorderLess)
resizefontecran(144,1)
HideGadget(144,1)
SendMessage_(GadgetID(144), #EM_LIMITTEXT,4, 0)
SetGadgetColor(144,#PB_Gadget_BackColor,$2C2CEE)
ButtonGadget(145,kl(230),kh(718),kl(20),kh(20),"Ok")
HideGadget(145,1)
TextGadget(206,kl(10),kh(716),kl(100),kh(15),"",#PB_Text_Center)
resizefontecran(206,1)
coulfond(206);coulfond gad
hth.w = 155 : Hr.w = 7: d.B = 0
For z = 152 To 176
hth.w = hth.w + 20
If d.b = 0
d.B = 1
Hr.w = Hr +1
afh$ = Str(Hr.w)+ "h"
hth.w = hth.w + 2
colorh.f = $CD0000
Else
d.B = 0
afh$ = "30"
colorh.f = $5E798B
EndIf
TextGadget(z,kl(90),kh(hth.w),kl(20),kh(18),afh$,#PB_Text_Center)
coulfond(z);coulfond gad
SetGadgetColor(z, #PB_Gadget_FrontColor,colorh.f)
StringGadget(z+25,kl(115),kh(hth.w-1),kl(300),kh(14),"",#PB_String_BorderLess)
SendMessage_(GadgetID(z+25), #EM_LIMITTEXT, 60, 0)
SetGadgetColor(z+25, #PB_Gadget_BackColor,$D0D0D0)
resizefontecran(z,1)
resizefontecran(z+25,1)
Next
SetActiveGadget(177)
indstrok.B = 1 ;indique que les strings peuvent recevoir du texte
controllect(tdate$)
Repeat
Event = WaitWindowEvent()
Select Event
Case #WM_KEYDOWN ; déplacement dans les strings avec flèches haute et basse
id_touche = EventwParam()
If id_touche = 40 And GetActiveGadget() => 177 And GetActiveGadget() < 201 ;descend
SetActiveGadget(GetActiveGadget()+1)
GestionCaret(GetActiveGadget())
EndIf
If id_touche = 38 And GetActiveGadget() > 177 And GetActiveGadget() <= 201 ;monte
SetActiveGadget(GetActiveGadget()-1)
GestionCaret(GetActiveGadget())
EndIf
Case #WM_LBUTTONDOWN
SendMessage_(WindowID(1), #WM_NCLBUTTONDOWN, #HTCAPTION, 0);pour bouger la fenetre
Case #PB_Event_Gadget
If EventGadget() => 177 And EventGadget()<= 201 ;scrute et indique qu'elle ligne de RV est active
lignerv.w = EventGadget()
Select EventType()
Case #PB_EventType_Change;met la 1er lettre des strings en majuscule
If Len(GetGadgetText(lignerv.w)) = 1
SetGadgetText(lignerv.w,UCase(GetGadgetText(lignerv.w)))
GestionCaret(GetActiveGadget())
EndIf
EndSelect
EndIf
Select EventGadget() ; Gadgets
Case 10 To 51 ;Gère les clics sur cal gauche
If GetGadgetText(EventGadget()) <> "" ; pas de clik sur case vide
controlenr();enr s'il a lieu avant changement de date
jour.w = Val(GetGadgetText(EventGadget()))
mois.w = moischif(Mid(GetGadgetText(102),1,Len(GetGadgetText(102))-5))
an.w = Val(Right(GetGadgetText(102),4))
tdate$ = FormatDate("%dd%mm%yyyy",Date(an,mois,jour,0,0,0))
clickcal(tdate$,EventGadget(),"g")
EndIf
Case 60 To 101;Gère les clics sur cal droit
If GetGadgetText(EventGadget()) <> "" ; pas de clik sur case vide
controlenr();enr s'il a lieu avant changement de date
jour.w = Val(GetGadgetText(EventGadget()))
mois.w = moischif(Mid(GetGadgetText(128),1,Len(GetGadgetText(128))-5))
an.w = Val(Right(GetGadgetText(128),4))
tdate$ = FormatDate("%dd%mm%yyyy",Date(an,mois,jour,0,0,0))
clickcal(tdate$,EventGadget(),"d")
EndIf
Case 4;remet a la date du jour
controlenr();enr s'il a lieu avant changement de date
tdate$ = FormatDate("%dd%mm%yyyy",Date())
affcal(tdate$)
Case 130
controlenr();enr s'il a lieu avant changement de date
jour.w = Val(Left(tdate$,2));transforme la date en chiffres
mois.w = Val(Mid(tdate$,3,2))
an.w = Val(Right(tdate$,4))
jour = 1 : mois = mois + 1
If mois > 12 : mois = 1:an = an +1: jour = 1:EndIf
dateact$ = FormatDate("%dd%mm%yyyy",Date())
anact.w = Val(Right(dateact$,4))
moiact.w = Val(Mid(dateact$,3,2))
If anact = an And moiact = mois
tdate$ = FormatDate("%dd%mm%yyyy",Date())
Else
tdate$ = FormatDate("%dd%mm%yyyy",Date(an,mois,jour,0,0,0))
EndIf
affcal(tdate$)
Case 131
controlenr();enr s'il a lieu avant changement de date
jour.w = Val(Left(tdate$,2));transforme la date en chiffres
mois.w = Val(Mid(tdate$,3,2))
an.w = Val(Right(tdate$,4))
mois = mois - 1 : jour = calculnbjm(an,mois,1,0,0,0)
If mois = 0
mois = 12
an = an -1
jour = calculnbjm(an,mois,1,0,0,0)
EndIf
dateact$ = FormatDate("%dd%mm%yyyy",Date())
anact.w = Val(Right(dateact$,4))
moiact.w = Val(Mid(dateact$,3,2))
If anact = an And moiact = mois
tdate$ = FormatDate("%dd%mm%yyyy",Date())
Else
tdate$ = FormatDate("%dd%mm%yyyy",Date(an,mois,jour,0,0,0))
EndIf
affcal(tdate$)
Case 141 ;efface un R-V
SetGadgetText(lignerv.w,"")
SetActiveGadget(lignerv.w)
Case 142 ;efface une année(prépare)
If GetGadgetState(142) = 1
HideGadget(143,0)
HideGadget(144,0)
HideGadget(145,0)
SetActiveGadget(144)
Else
HideGadget(143,1)
HideGadget(144,1)
HideGadget(145,1)
SetActiveGadget(177)
EndIf
Case 146 ;imprime
If DefaultPrinter()
impjour()
Else
CreateThread(@infos(),3)
EndIf
Case 145 ;efface une année
supan(GetGadgetText(144))
Case 140;bt stop
controlenr();enr s'il a lieu avant arrêt
CloseWindow(1)
DestroyWindow_(Tooltip.l)
Break
EndSelect
EndSelect
Until Event = #PB_Event_CloseWindow
