[RESOLU] Ajout d'une colonne dans userForm

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.

'****************************************************************
'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:
C

Compte Supprimé 979

Guest
Re : Ajout d'une colonne dans userForm

Salut zeltron24

Nous donner un code comme ça, sans fichier ne sers à rien dans ton cas :rolleyes:

Heureusement je connais ce fichier qui se trouve dans la section téléchargement du site
Excel Downloads - Ephemeride

Tu trouveras ci-joint le fichier modifié pour tes besoins

A+
 

Pièces jointes

  • Ephemeride.xls
    215.5 KB · Affichages: 45

zeltron24

XLDnaute Impliqué
Re : Ajout d'une colonne dans userForm

Bonjour BrunoM45,
Quelle chance que j'ai de tomber sur une personne qui connait le fichier.
Merci beaucoup pour ton aide car depuis mon message j'ai encore et encore essayer sans succès
Beau travail de ta part.
Voici le fichier modifié par mes soins avec les erreurs que je n'arrive pas à trouver.
Très cordialement Guy
 

Pièces jointes

  • Classeur1.xls
    256 KB · Affichages: 42
  • Classeur1.xls
    256 KB · Affichages: 40
  • Classeur1.xls
    256 KB · Affichages: 38
Dernière édition:

zeltron24

XLDnaute Impliqué
Re : Ajout d'une colonne dans userForm

J'ai fait les modifs dans mon classeur mais rien ne s'affiche dans le label "LblAutre, je ne comprends pas le pourquoi
Celui que j'ai mis dans mon message précédent n'est pas complet d'ou peut etre son disfonctionnement mais il est trop lourd pour le mettre entièrement.
J'ai remis le classeur allégé
 

Pièces jointes

  • Classeur1a.xls
    263.5 KB · Affichages: 40
  • Classeur1a.xls
    263.5 KB · Affichages: 32
  • Classeur1a.xls
    263.5 KB · Affichages: 36
Dernière édition:

phlaurent55

Nous a quittés en 2020
Repose en paix
Re : Ajout d'une colonne dans userForm

Bonjour à tous,
J'ai fait les modifs dans mon classeur mais rien ne s'affiche dans le label "LblAutre, je ne comprends pas le pourquoi
N'ayant pas trouvé le "LblAutre" dans les deux derniers fichier joints, j'ai rassemblé tous les saints dans un seul label

faire un essai avec la date du 1er août (il y a plusieurs saints ce jour-là)

à+
Philippe
 

Pièces jointes

  • 111.xlsm
    140.8 KB · Affichages: 40
  • 111.xlsm
    140.8 KB · Affichages: 46
  • 111.xlsm
    140.8 KB · Affichages: 49
  • 111.xls
    250.5 KB · Affichages: 28
  • 111.xls
    250.5 KB · Affichages: 40
  • 111.xls
    250.5 KB · Affichages: 36

zeltron24

XLDnaute Impliqué
Re : Ajout d'une colonne dans userForm

Bonsoir phlaurent55
Merci à toi pour ton travail.
Cela me convient parfaitement tout comme le travail de BrunoM45
Je vous remercie tous les deux Bonne soirée et à +
Cordialement zeltron24
 

Discussions similaires