[RESOLU] Ajout d'une colonne dans userForm

'****************************************************************
'vous êtes libre pour réutiliser ce module de code source
'dans vos propres applications à condition de laisser ces
'commentaires en place
'© G.Moriceau, septembre - Décembre 2002 : simlger@noos.fr
'
'Description : Vous montre comment créer une horloge et un petit
'Ephéméride sur un UserForm avec insertion d'une îcone sur la barre
'de titre dans VBE avec l'utilisation des APIS
'*****************************************************************
Option Explicit

Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, ByVal _
lpWindowName As String) As Long

Private Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex _
As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex _
As Long, ByVal dwNewLong As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Integer, ByVal lParam As Long) As Long

Private Declare Function DrawMenuBar Lib "user32" (ByVal _
hWnd As Long) As Long

Private wHandle As Long
Private hIcon As Long
Private Frm As Long

Dim ChDir As String
Dim Saint(370) As String
Dim Paques As Date
Dim Annee As Integer
Dim Jour As String
Dim Mois As String
Dim NoJour As Integer
Dim DateJour As Date
Dim NomSaint As String
Dim NoSemaine As String
Dim NbJours As String
Dim Horloge As Integer
Dim Couleur As Long
Dim Couleur1 As Long
Dim Anniversaire As String

Private Sub Calendar1_Click()
DateJour = Calendar1.Value
Call Calcul
End Sub

Private Sub UserForm_Initialize()
Dim Plage As Range, Cel As Range
Dim Jour As Long
Calendar1.Value = Now 'mise a jour du calendrier
FrmEphem.Height = 370 '240
'**************************************************
'l'insertion d'une icône sur la barre de titre du
'UserForm ce fait à partir des 16 lignes ci-dessous
'cette partie de code est d'un auteur inconnu que
'j'ai repris et adapté
'**************************************************
' Affichage du nom
Range("E2") = ""
Anniversaire = Sheets("Fetes").Range("B71").Value
If Range("F69") = 0 Then
FrmEphem.Height = 260
CmdBas.Visible = True
CmdHaut.Visible = False
LblAnniversaire.Visible = False

Else
FrmEphem.Height = 415
LblAnniversaire.Caption = Anniversaire
CmdBas.Visible = False
CmdHaut.Visible = True
LabCal.Visible = False
End If

Me.Caption = " Éphéméride"
Image2.Visible = True
wHandle = hwndFenetreForm(Me.Caption)
If wHandle = 0 Then Exit Sub
hIcon = Image2.Picture
SendMessage wHandle, &H80, True, hIcon
SendMessage wHandle, &H80, False, hIcon
Frm = GetWindowLong(wHandle, -20)
Frm = Frm And Not &H1
SetWindowLong wHandle, -20, Frm
DrawMenuBar wHandle

With Worksheets("Saints")
Set Plage = .Range("A1", .Range("A1").End(xlDown))
End With
For Each Cel In Plage
Saint(Jour) = Cel.Value
Jour = Jour + 1
Next Cel

DateJour = Date
Horloge = Hour(Time) * 60 + Minute(Time)
Call Calcul
Call DemarrerHorloge

End Sub

Private Sub CmdBas_Click()
' Afficher le calendrier
On Error Resume Next
CmdBas.Visible = True

FrmEphem.Height = 370
CmdHaut.Visible = True
CmdBas.Visible = False
LabCal.Visible = False

If Range("F69") <> 0 Then
FrmEphem.Height = 415

Else
FrmEphem.Height = 370

End If
End Sub

Private Sub CmdHaut_Click()
' Cacher le calendrier
On Error Resume Next
CmdBas.Visible = True
FrmEphem.Height = 260
CmdHaut.Visible = False
Calendar1.Value = Now 'mise a jour du calendrier
DateJour = Calendar1.Value
LabCal.Visible = True
Call Calcul
End Sub

'La procédure événementielle (UserForm_QueryClose)suivante
'est appelée systématiquement pour arrêter l'horloge
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call ArrêterHorloge
End Sub

Private Sub CmdQuitter_Click()
Unload Me
Range("E2") = Range("B71").Value
Range("A1").Select
End Sub

Sub Calcul()
Annee = Year(DateJour)
'Test si changement de jour
If Jour <> Format(DateJour, "dddd") Then
Jour = Format(DateJour, "dddd")
'Affichage
End If
Annee = Format(DateJour, "yyyy")
Mois = Format(DateJour, "mmmm")
NoJour = Format(DateJour, "dd")
' NoSemaine = "Semaine " & Format(DateJour, "ww", 1)
NoSemaine = "Semaine n° " & Val(Format(DateJour, "ww", vbMonday, vbFirstFourDays))
NbJours = Format(DateJour, "y") & "/" & Format(365 - Format(DateJour, "y"), "###")
Call Calcul_Paques
Call Calcul_Saint
Call Affichage_Ephemeride
End Sub

Private Sub Affichage_Ephemeride()
'LblDateHeure.Caption = Format(Date, "Long Date") _
& " " & "( " & Format(Now, "Long Time") & " )"
'Définir les couleurs
LblHeure.ForeColor = &H4000&
LblNoSemaine.ForeColor = &HC00000
LblNbJours.ForeColor = &HC00000
LblJour.ForeColor = Couleur
LblNoJour.ForeColor = Couleur
LblMois.ForeColor = Couleur
LblSaint.ForeColor = Couleur1
' LblAnnee.ForeColor = &H4000&
LblAns.ForeColor = &H4000&
'Affichage sur le UserForm
LblHeure.Caption = Format(Now, "Long Time")
LblJour.Caption = Jour
LblNoJour.Caption = NoJour
LblMois.Caption = Mois
LblSaint.Caption = NomSaint
LblNoSemaine.Caption = NoSemaine
LblNbJours.Caption = NbJours
LblAnnee.Caption = Annee
End Sub

Private Sub Calcul_Paques()
Dim i1, i2, i3, i4, i5, i6, i7
i1 = Annee Mod 19 + 1
i2 = (Annee \ 100) + 1
i3 = ((3 * i2) \ 4) - 12
i4 = (((8 * i2) + 5) \ 25) - 5
i5 = ((5 * Annee) \ 4) - i3 - 10
i6 = (11 * i1 + 20 + i4 - i3) Mod 30
If (i6 = 25 And i1 > 11) Or (i6 = 24) Then
i6 = i6 + 1
End If
i7 = 44 - i6
If i7 < 21 Then
i7 = i7 + 30
End If
i7 = i7 + 7
i7 = i7 - (i5 + i7) Mod 7
If i7 <= 31 Then
Paques = DateValue(CStr(i7) & "/3/" & CStr(Annee))
Else
Paques = DateValue(CStr(i7 - 31) & "/4/" & CStr(Annee))
End If
End Sub

Private Sub Calcul_Saint()
Dim i
'Couleur de base
Couleur1 = &HC000C0
Couleur = &H40C0
'Test si l'année est bisextile
If Annee Mod 4 = 0 Then
i = -2
Else
i = -1
End If
If Format(DateJour, "dd/mm") = "29/02" Then
NomSaint = "ST AUGUSTE"
Else
NomSaint = Saint(Format(DateJour, "y") + i)
End If
If Format(DateJour, "dddd") = "dimanche" Then
'Test si 1er Dimanche de Janvier
If Format(DateJour, "m") = "1" And Format(DateJour, "dd") < "08" Then
NomSaint = "EPIPHANIE"
End If
'Test si Dernier Dimanche d'Avril
If Format(DateJour, "m") = "4" And Format(DateJour, "dd") > "23" Then
NomSaint = "SOUV. DEPORTES"
End If
'Test si deuxième Dimanche de Mai
If Format(DateJour, "m") = "5" And Format(DateJour, "dd") > "07" And Format(DateJour, "dd") < "15" Then
NomSaint = "FETE J. D'ARC"
End If
End If
'Si Samedi : couleur jaune
If Format(DateJour, "w", vbMonday) = 6 Then
Couleur = RGB(200, 100, 0)
End If
'Si Dimanche : couleur rouge
If Format(DateJour, "w", vbMonday) = 7 Then
Couleur = RGB(200, 0, 0)
End If
'Les fêtes mobiles sont de couleur bleue
If DateJour = Paques Then
NomSaint = "PAQUES"
Couleur = RGB(0, 0, 250)
End If
'Lundi de Pâques
If DateJour = Paques + 1 Then
Couleur = RGB(0, 0, 250)
End If
If DateJour = Paques + 39 Then
NomSaint = "ASCENSION"
Couleur = RGB(0, 0, 250)
End If
If DateJour = Paques + 49 Then
NomSaint = "PENTECOTE"
Couleur = RGB(0, 0, 250)
End If
'Lundi de Pentecôte
If DateJour = Paques + 50 Then
Couleur = RGB(0, 0, 250)
End If
If DateJour = Paques - 42 Then
NomSaint = "CAREME"
End If
If DateJour = Paques - 46 Then
NomSaint = "CENDRES"
End If
If DateJour = Paques - 47 Then
NomSaint = "MARDI GRAS"
End If
If DateJour = Paques - 7 Then
NomSaint = "RAMEAUX"
End If
If DateJour = Paques + 63 Then
NomSaint = "FETE DIEU"
End If
'Couleur bleue pour les fêtes fixes
If Format(DateJour, "dd/mm") = "01/01" Then
Couleur = RGB(0, 0, 250)
End If
If Format(DateJour, "dd/mm") = "01/05" Then
Couleur = RGB(0, 0, 250)
End If
If Format(DateJour, "dd/mm") = "08/05" Then
Couleur = RGB(0, 0, 250)
End If
If Format(DateJour, "dd/mm") = "14/07" Then
Couleur = RGB(0, 0, 250)
End If
If Format(DateJour, "dd/mm") = "15/08" Then
Couleur = RGB(0, 0, 250)
End If
If Format(DateJour, "dd/mm") = "01/11" Then
Couleur = RGB(0, 0, 250)
End If
If Format(DateJour, "dd/mm") = "11/11" Then
Couleur = RGB(0, 0, 250)
End If
If Format(DateJour, "dd/mm") = "25/12" Then
Couleur = RGB(0, 0, 250)
End If
End Sub

Cliquez pour agrandir...