zeltron24
XLDnaute Impliqué
Bonjour le forum,
J'ai trouvé un éphéméride libre d'accés que je souhaite transformer (J'ai déjà fait quelques modifs. Mais je souhaiterai insérer un nouveau label qui me donnerai les contenus de la colonne B de la feuille "Saints". Après bien des essais, je n'y parviens pas.
Aussi, je fais appel à vos connaissances pour de l'aide.
Voici le code se trouvant dans le formulaire.
Merci de votre aide
J'ai trouvé un éphéméride libre d'accés que je souhaite transformer (J'ai déjà fait quelques modifs. Mais je souhaiterai insérer un nouveau label qui me donnerai les contenus de la colonne B de la feuille "Saints". Après bien des essais, je n'y parviens pas.
Aussi, je fais appel à vos connaissances pour de l'aide.
Voici le code se trouvant dans le formulaire.
'****************************************************************
'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
Merci de votre aide
Dernière édition: