Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel Problème de calendrier dans UserForm

Problème de calendrier dans UserForm

4 réponses
Avatar
Jipé
Bonsoir le Forum,

Dans une UserForm, j'ai un calendrier qui à l'ouverture de l'USF m'indique
la date du jour.

Lorsque je valide, pour la copie sur la feuille de calculs, la valeur de la
date dans la cellule est sous ce format; 38254 (pour aujourd'hui). C'est
valable aussi, pour les mois d'octobre et novembre.

Pour décembre, janvier etc..... c'est OK, la valeur de la cellule est au bon
format, soit 21-DÉC-04.

Merci encore pour votre aide.

Jipé

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 DrawMenuBar Lib "user32" (ByVal hWnd As Long) As
Long
Private DayLabel() As New lblClass, idx As Integer, m As Integer

Const T As String = "Thierry's Démo sur www.Excel-Donwloads.com, May 2003"

Private Sub ScrollBar1_Change()
If Me.ScrollBar1 > m Then
iDate = DateAdd("m", 1, iDate)
Else
iDate = DateAdd("m", -1, iDate)
End If
m = Me.ScrollBar1: DP_UpDate
End Sub

Private Sub UserForm_Click()
Unload Me
End Sub

Private Sub UserForm_Initialize()

Dim L As Integer
Me.Caption = T

'trouve dernière ligne remplie
L = Sheets("Listes").Range("A65536").End(xlUp).Row

'mise des données dans la combo...
With Me
With .LbxNoms
.ColumnCount = 3 'il y a 3 colonne de A à C sur la feuille
.ColumnWidths = "120;0;0;0;0" 'Astuce, je mets la largeur à zéro pour
cacher les autres colonnes
.RowSource = "Listes!A4:C" & L 'Je mets toute la plage
.MatchEntry = fmMatchEntryFirstLetter 'Ici c'est pour faciliter la
recherche...
End With
End With

If iFlag Then
Dim lngMe&, hndMe&, Offset As Single
Offset = Me.Height - Me.InsideHeight - ((Me.Width - Me.InsideWidth) / 2)
Me.Height = Me.Height - Offset
hndMe = FindWindow(vbNullString, Me.Caption)
lngMe = GetWindowLong(hndMe, -16) And Not &HC00000
Call SetWindowLong(hndMe, -16, lngMe)
Call DrawMenuBar(hndMe)
End If
Dim i As Integer, Ctl As Control
For Each Ctl In Me.Controls
If Left(Ctl.Name, 4) = "lblJ" Then
i = Val(Mid(Ctl.Name, 5))
ReDim Preserve DayLabel(0 To i)
Set DayLabel(i).DayGroup = Ctl
End If
Next Ctl
Me.ScrollBar1 = m: iDate = Date: DP_UpDate
CbxParts.RowSource = "Inscrits!Parts"
LbxNoms.RowSource = "Listes!Liste_Inscrits"
TxtPrenom.Value = ""
TxtNumero.Value = ""
CbxParts.Value = "Parts ?"
End Sub

Private Sub LbxNoms_Change()
'Synchronisation des TextBox (Nb la Column 0 de la ComboBox existe, c'est
celle du Nom !!!

If Me.LbxNoms.ListIndex = -1 Then
MsgBox "Saisie effectuée avec succès!"
Exit Sub
Else
With Me
.TxtPrenom = .LbxNoms.Column(1, .LbxNoms.ListIndex)
.TxtNumero = .LbxNoms.Column(2, .LbxNoms.ListIndex)
End With
End If

End Sub

Friend Sub DP_UpDate()
Dim i As Integer, FirstDay As Integer
iDay = Day(iDate): iMonth = Month(iDate): iYear = Year(iDate)
FirstDay = Weekday(DateSerial(iYear, iMonth, 1)) - 1
For i = 0 To FirstDay - 1: Me.Controls("lblJ" & i).Visible = False: Next
i = 0
Do
i = i + 1
If Not IsDate(Month(iDate) & "/" & i & "/" & Year(iDate)) Then Exit Do
Me.Controls("lblJ" & FirstDay) = i
Me.Controls("lblJ" & FirstDay).Visible = True
If i = iDay Then HighLight FirstDay
FirstDay = FirstDay + 1
Loop
For i = FirstDay To UBound(DayLabel): Me.Controls("lblJ" & i).Visible =
False: Next
TxtDate = Format(iDate, "dd-mmm-yy")

End Sub

Private Sub CommandButton1_Click()
Sheets("Inscrits").Select
ActiveSheet.Unprotect

Range("B1") = LbxNoms.Value
Range("C1") = TxtPrenom.Value
Range("D1") = TxtNumero.Value
Range("E1") = CbxParts.Value
Range("F1") = Format(TxtDate.Value, "dd-mmm-yy")

Range("B2").Select
ActiveCell.FormulaR1C1 = "=UPPER(R[-1]C)"
Range("B2").Select
Selection.Copy
Range("B65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Range("C2").Select
ActiveCell.FormulaR1C1 = "=PROPER(R[-1]C)"
Range("C2").Select
Selection.Copy
Range("C65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Range("D1").Select
Selection.Copy
Range("D65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Range("E1").Select
Selection.Copy
Range("E65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Range("F2").Select
ActiveCell.FormulaR1C1 = "=UPPER(R[-1]C)"
Range("F2").Select
Selection.Copy
Range("F65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Range("B1,C1,D1,E1,F1").Select

Worksheets("Inscrits").Columns("A:F").AutoFit

Selection.ClearContents
If iFlag Then
Dim lngMe&, hndMe&, Offset As Single
Offset = Me.Height - Me.InsideHeight - ((Me.Width - Me.InsideWidth) / 2)
Me.Height = Me.Height - Offset
hndMe = FindWindow(vbNullString, Me.Caption)
lngMe = GetWindowLong(hndMe, -16) And Not &HC00000
Call SetWindowLong(hndMe, -16, lngMe)
Call DrawMenuBar(hndMe)
End If
Dim i As Integer, Ctl As Control
For Each Ctl In Me.Controls
If Left(Ctl.Name, 4) = "lblJ" Then
i = Val(Mid(Ctl.Name, 5))
ReDim Preserve DayLabel(0 To i)
Set DayLabel(i).DayGroup = Ctl
End If
Next Ctl
Me.ScrollBar1 = m: iDate = Date: DP_UpDate
LbxNoms.Value = ""
TxtNumero.Value = ""
TxtPrenom.Value = ""
CbxParts.Value = "Parts ?"
Range("A4").Select
Inscrit1.Hide
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True

End Sub

Private Sub HighLight(ByVal Ctl As Byte)
Me.Controls("lblJ" & idx).BorderStyle = 0
Me.Controls("lblJ" & idx).FontBold = False
Me.Controls("lblJ" & Ctl).BorderStyle = 1
Me.Controls("lblJ" & Ctl).FontBold = True
idx = Ctl
Me.DateOfDay = Format(iDate, "d mmmm yyyy")
End Sub
Signaler un problème avec ce contenu

4 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
LeSteph
Bonsoir,
Activecell=format(calendar1,"dd-mmm-yyyy")

lsteph

"Jipé" a écrit dans le message de
news:%
Bonsoir le Forum,

Dans une UserForm, j'ai un calendrier qui à l'ouverture de l'USF m'indique
la date du jour.

Lorsque je valide, pour la copie sur la feuille de calculs, la valeur de
la

date dans la cellule est sous ce format; 38254 (pour aujourd'hui). C'est
valable aussi, pour les mois d'octobre et novembre.

Pour décembre, janvier etc..... c'est OK, la valeur de la cellule est au
bon

format, soit 21-DÉC-04.

Merci encore pour votre aide.

Jipé

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 DrawMenuBar Lib "user32" (ByVal hWnd As Long) As
Long
Private DayLabel() As New lblClass, idx As Integer, m As Integer

Const T As String = "Thierry's Démo sur www.Excel-Donwloads.com, May 2003"

Private Sub ScrollBar1_Change()
If Me.ScrollBar1 > m Then
iDate = DateAdd("m", 1, iDate)
Else
iDate = DateAdd("m", -1, iDate)
End If
m = Me.ScrollBar1: DP_UpDate
End Sub

Private Sub UserForm_Click()
Unload Me
End Sub

Private Sub UserForm_Initialize()

Dim L As Integer
Me.Caption = T

'trouve dernière ligne remplie
L = Sheets("Listes").Range("A65536").End(xlUp).Row

'mise des données dans la combo...
With Me
With .LbxNoms
.ColumnCount = 3 'il y a 3 colonne de A à C sur la feuille
.ColumnWidths = "120;0;0;0;0" 'Astuce, je mets la largeur à zéro pour
cacher les autres colonnes
.RowSource = "Listes!A4:C" & L 'Je mets toute la plage
.MatchEntry = fmMatchEntryFirstLetter 'Ici c'est pour faciliter la
recherche...
End With
End With

If iFlag Then
Dim lngMe&, hndMe&, Offset As Single
Offset = Me.Height - Me.InsideHeight - ((Me.Width - Me.InsideWidth) /
2)

Me.Height = Me.Height - Offset
hndMe = FindWindow(vbNullString, Me.Caption)
lngMe = GetWindowLong(hndMe, -16) And Not &HC00000
Call SetWindowLong(hndMe, -16, lngMe)
Call DrawMenuBar(hndMe)
End If
Dim i As Integer, Ctl As Control
For Each Ctl In Me.Controls
If Left(Ctl.Name, 4) = "lblJ" Then
i = Val(Mid(Ctl.Name, 5))
ReDim Preserve DayLabel(0 To i)
Set DayLabel(i).DayGroup = Ctl
End If
Next Ctl
Me.ScrollBar1 = m: iDate = Date: DP_UpDate
CbxParts.RowSource = "Inscrits!Parts"
LbxNoms.RowSource = "Listes!Liste_Inscrits"
TxtPrenom.Value = ""
TxtNumero.Value = ""
CbxParts.Value = "Parts ?"
End Sub

Private Sub LbxNoms_Change()
'Synchronisation des TextBox (Nb la Column 0 de la ComboBox existe, c'est
celle du Nom !!!

If Me.LbxNoms.ListIndex = -1 Then
MsgBox "Saisie effectuée avec succès!"
Exit Sub
Else
With Me
.TxtPrenom = .LbxNoms.Column(1, .LbxNoms.ListIndex)
.TxtNumero = .LbxNoms.Column(2, .LbxNoms.ListIndex)
End With
End If

End Sub

Friend Sub DP_UpDate()
Dim i As Integer, FirstDay As Integer
iDay = Day(iDate): iMonth = Month(iDate): iYear = Year(iDate)
FirstDay = Weekday(DateSerial(iYear, iMonth, 1)) - 1
For i = 0 To FirstDay - 1: Me.Controls("lblJ" & i).Visible = False: Next
i = 0
Do
i = i + 1
If Not IsDate(Month(iDate) & "/" & i & "/" & Year(iDate)) Then Exit Do
Me.Controls("lblJ" & FirstDay) = i
Me.Controls("lblJ" & FirstDay).Visible = True
If i = iDay Then HighLight FirstDay
FirstDay = FirstDay + 1
Loop
For i = FirstDay To UBound(DayLabel): Me.Controls("lblJ" & i).Visible > False: Next
TxtDate = Format(iDate, "dd-mmm-yy")

End Sub

Private Sub CommandButton1_Click()
Sheets("Inscrits").Select
ActiveSheet.Unprotect

Range("B1") = LbxNoms.Value
Range("C1") = TxtPrenom.Value
Range("D1") = TxtNumero.Value
Range("E1") = CbxParts.Value
Range("F1") = Format(TxtDate.Value, "dd-mmm-yy")

Range("B2").Select
ActiveCell.FormulaR1C1 = "=UPPER(R[-1]C)"
Range("B2").Select
Selection.Copy
Range("B65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:úlse, Transpose:úlse

Range("C2").Select
ActiveCell.FormulaR1C1 = "=PROPER(R[-1]C)"
Range("C2").Select
Selection.Copy
Range("C65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:úlse, Transpose:úlse

Range("D1").Select
Selection.Copy
Range("D65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:úlse, Transpose:úlse

Range("E1").Select
Selection.Copy
Range("E65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:úlse, Transpose:úlse

Range("F2").Select
ActiveCell.FormulaR1C1 = "=UPPER(R[-1]C)"
Range("F2").Select
Selection.Copy
Range("F65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:úlse, Transpose:úlse

Range("B1,C1,D1,E1,F1").Select

Worksheets("Inscrits").Columns("A:F").AutoFit

Selection.ClearContents
If iFlag Then
Dim lngMe&, hndMe&, Offset As Single
Offset = Me.Height - Me.InsideHeight - ((Me.Width - Me.InsideWidth) /
2)

Me.Height = Me.Height - Offset
hndMe = FindWindow(vbNullString, Me.Caption)
lngMe = GetWindowLong(hndMe, -16) And Not &HC00000
Call SetWindowLong(hndMe, -16, lngMe)
Call DrawMenuBar(hndMe)
End If
Dim i As Integer, Ctl As Control
For Each Ctl In Me.Controls
If Left(Ctl.Name, 4) = "lblJ" Then
i = Val(Mid(Ctl.Name, 5))
ReDim Preserve DayLabel(0 To i)
Set DayLabel(i).DayGroup = Ctl
End If
Next Ctl
Me.ScrollBar1 = m: iDate = Date: DP_UpDate
LbxNoms.Value = ""
TxtNumero.Value = ""
TxtPrenom.Value = ""
CbxParts.Value = "Parts ?"
Range("A4").Select
Inscrit1.Hide
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True

End Sub

Private Sub HighLight(ByVal Ctl As Byte)
Me.Controls("lblJ" & idx).BorderStyle = 0
Me.Controls("lblJ" & idx).FontBold = False
Me.Controls("lblJ" & Ctl).BorderStyle = 1
Me.Controls("lblJ" & Ctl).FontBold = True
idx = Ctl
Me.DateOfDay = Format(iDate, "d mmmm yyyy")
End Sub




Avatar
Jipé
Re,
Bonsoir Le Steph,

je fais peût-être erreur, mais je pense que le calendrier que j'utilise dans
ma USF, a été monté de toute pièce.
Nulle part dans le code je vois "calendar1".

Par contre, ScrollBar1 me sert a changer de mois, et les lblJ sont les noms
du pavé du calendrier.

Si quelqu'un a une autre idée ou solution, merci d'avance.

Jipé
Avatar
LeSteph
Bonsoir,
Cela revient au même remplace "calendar1" par l'"expression" sensée
contenir
une date de ton calendrier et applique format(expression,"dd-mmm-yyyy")
...sinon dans les contrôles supplémentaires tu trouvera un "vrai" calendrier
s'il n'y est pas va voir sur le site de F.Sigonneau.

amicalement

lSteph

"Jipé" a écrit dans le message de
news:
Re,
Bonsoir Le Steph,

je fais peût-être erreur, mais je pense que le calendrier que j'utilise
dans

ma USF, a été monté de toute pièce.
Nulle part dans le code je vois "calendar1".

Par contre, ScrollBar1 me sert a changer de mois, et les lblJ sont les
noms

du pavé du calendrier.

Si quelqu'un a une autre idée ou solution, merci d'avance.

Jipé




Avatar
LeSteph
..j'oubliais http://perso.wanadoo.fr/frederic.sigonneau/code/Calendriers
voir CalFr2.zip

lSteph

"Jipé" a écrit dans le message de
news:
Re,
Bonsoir Le Steph,

je fais peût-être erreur, mais je pense que le calendrier que j'utilise
dans

ma USF, a été monté de toute pièce.
Nulle part dans le code je vois "calendar1".

Par contre, ScrollBar1 me sert a changer de mois, et les lblJ sont les
noms

du pavé du calendrier.

Si quelqu'un a une autre idée ou solution, merci d'avance.

Jipé