Ce calendrier présente un semestre après l'autre avec le nom des saints et fêtes religieuses et jours fériés. Ce code a été écrit sous VB6.
Source / Exemple :
Dim yr As Integer
Sub calmensuel(obj As PictureBox, mois As Long, nyear As Integer)
Dim I As Integer, date1 As Date
obj.Cls
With obj
.AutoRedraw = True
.BorderStyle = 0
.FontSize = 8
' .FontName = "Garamond"
.Height = 6045
.ScaleMode = 3
.Width = 1695
End With
obj.ForeColor = RGB(255, 0, 0)
date1 = DateSerial(nyear, mois, 1)
obj.Print Tab(1); Format(date1, "mmmm"); Spc(1); nyear & Chr(13);
obj.Print Space(1); " ";
For I = 1 To findemois(mois, nyear)
date1 = DateSerial(nyear, mois, I)
If Weekday(JoursFériés(date1, nyear)) = Weekday(date1) Then
obj.ForeColor = RGB(255, 0, 0)
obj.FontBold = False
ElseIf Weekday(AutresFetes(date1, nyear)) = Weekday(date1) Then
obj.ForeColor = RGB(255, 0, 0)
obj.FontBold = False
ElseIf Fêtes_Religieuses(date1, nyear) = True Then
obj.ForeColor = RGB(255, 0, 0)
obj.FontBold = False
ElseIf Weekday(date1) = vbSaturday Or Weekday(date1) = vbSunday Then
obj.ForeColor = RGB(255, 0, 0)
obj.FontBold = False
Else
If Day(Now) = I And mois = Month(Now) And nyear = Year(Now) Then
' obj.FontBold = True
obj.ForeColor = RGB(0, 255, 255)
Else
' obj.FontBold = False
obj.ForeColor = RGB(0, 0, 0)
End If
End If
obj.Print Tab(1); LeftRight(Format(date1, "ddd"), 0); Tab(5); Format(date1, "dd"); Spc(1); lafete(date1, nyear)
Next I
End Sub
Function findemois(mois As Long, annee As Integer) As Integer
'cette Function determine le nombre de jours dans un mois
On Error GoTo Error_findemois
findemois = _
DateSerial(annee, mois + 1, 1) - DateSerial(annee, mois, 1)
Exit_findemois:
Exit Function
Error_findemois:
MsgBox Err.Number & " " & Err.Description
Resume Exit_findemois
End Function
Private Sub Command1_Click()
'pour afficher le 2ème semestre
Picture3(0).Visible = False
With Picture3(1)
.Visible = True
.Top = 285
.Left = 195
End With
End Sub
Private Sub Command2_Click()
'pour afficher le 1er semestre
Picture3(1).Visible = False
With Picture3(0)
.Visible = True
.Top = 285
.Left = 195
End With
End Sub
Private Sub Command3_Click(Index As Integer)
Select Case Index
Case 0
yr = yr - 1
If yr < 1 Then yr = 1
Refresh
Case 1
yr = yr + 1
Refresh
Case 2
yr = Year(Now)
Command3(2).Caption = yr
Refresh
End Select
End Sub
Private Sub Form_Load()
Dim dat2 As Date
yr = Year(Date)
dat2 = DateSerial(yr, Month(Now), Day(Now))
Me.Caption = "Calendrier annuel - " & lafete(dat2, yr) & " le " & dat2
End Sub
Private Sub Form_Paint()
'pour afficher les mois du calendrier
For I = 1 To 12
Pic(I).BorderStyle = 0
calmensuel Pic(I), CLng(I), yr
Next I
Label1.Caption = "An " & yr
'pour afficher le semestre en cours
If Format(Date, "mm") < 7 Then
Picture3(0).Visible = True
Picture3(1).Visible = False
Else
Picture3(1).Visible = True
Picture3(0).Visible = False
End If
'pour activer/désactiver les boutons
'des semestres
If Picture3(1).Visible Then
Command1.Enabled = False
Command2.Enabled = True
End If
If Picture3(0).Visible Then
Command2.Enabled = False
Command1.Enabled = True
End If
End Sub
Private Sub Form_Resize()
yr = Year(Now)
Command3(2).Caption = yr
End Sub
Conclusion :
Légère modification du code avec commentaires + ajout de polices.
Je remercie Lucky2222 qui, grâce à son travail, m'a permis de faire celui-ci qui est sans prétention aucune.
Pas de bugs connus.
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.