Calendar control

K

kevinchurchill

New Member
Joined
Jul 20, 2015
Messages
26
Hello all,
I have a problem with my calender control user form, When I last used this form I hade windows 8 but since upgrading to win 10 64 bit my control does not work, before when i double clickrd what ever cell i assigned the calendar would appear then I choose a date and the date would be inserted in the specified cell I wil paste the code below, could you please advise.
Sorry the calendar is French.
Thank you in advance.

Code for Module, Add module and copy paste this code
Code: 
Option Explicit
Dim Semaine As Integer
Dim StopEvent As Boolean    'évite l'éxécution récursive des évênements
Function Calendrier(Optional DateInitiale As Date) As Date
    StopEvent = True
    If DateInitiale <> 0 Then
        Jour = DateInitiale
    Else
        Jour = Now
    End If
    StopEvent = False
    FormCal.Show
    Calendrier = Jour
End Function
Private Sub UserForm_Initialize()
    Dim i As Integer
    Dim m As String
    'remplit la liste des mois
    For i = 1 To 12
        m = Format("01/" & i, "mmmm")
        Mois.AddItem UCase(Left(m, 1)) & Right(m, Len(m) - 1)
    Next i
    'remplit la liste des années
    For i = 1900 To 2100
        Annee.AddItem i
    Next i
End Sub


Private Sub OK_Click()
    Semaine = Me.sem1.Caption
    Unload Me
End Sub


Private Sub Annuler_Click()
    Unload Me
End Sub


Private Sub Mois_Change()
    If Not StopEvent Then Jour.Value = CDate("01/" & Mois.ListIndex + 1 & "/" & Annee.ListIndex + 1900)
End Sub
Private Sub Annee_Change()
    If Not StopEvent Then Jour.Value = CDate("01/" & Mois.ListIndex + 1 & "/" & Annee.ListIndex + 1900)
End Sub


Private Sub Aujourdhui_Click()
    Jour.Value = Now
End Sub


'Les jours sont repérés de J1 à J42
'La valeur des propriétés .tag sont
'respectivement de 1 à 42
Private Sub J1_Click()
    ChJour Val(J1.Tag)
End Sub
Private Sub J2_Click()
    ChJour Val(J2.Tag)
End Sub
Private Sub J3_Click()
    ChJour Val(J3.Tag)
End Sub
Private Sub J4_Click()
    ChJour Val(J4.Tag)
End Sub
Private Sub J5_Click()
    ChJour Val(J5.Tag)
End Sub
Private Sub J6_Click()
    ChJour Val(J6.Tag)
End Sub
Private Sub J7_Click()
    ChJour Val(J7.Tag)
End Sub
Private Sub J8_Click()
    ChJour Val(J8.Tag)
End Sub
Private Sub J9_Click()
    ChJour Val(J9.Tag)
End Sub
Private Sub J10_Click()
    ChJour Val(J10.Tag)
End Sub
Private Sub J11_Click()
    ChJour Val(J11.Tag)
End Sub
Private Sub J12_Click()
    ChJour Val(J12.Tag)
End Sub
Private Sub J13_Click()
    ChJour Val(J13.Tag)
End Sub
Private Sub J14_Click()
    ChJour Val(J14.Tag)
End Sub
Private Sub J15_Click()
    ChJour Val(J15.Tag)
End Sub
Private Sub J16_Click()
    ChJour Val(J16.Tag)
End Sub
Private Sub J17_Click()
    ChJour Val(J17.Tag)
End Sub
Private Sub J18_Click()
    ChJour Val(J18.Tag)
End Sub
Private Sub J19_Click()
    ChJour Val(J19.Tag)
End Sub
Private Sub J20_Click()
    ChJour Val(J20.Tag)
End Sub
Private Sub J21_Click()
    ChJour Val(J21.Tag)
End Sub
Private Sub J22_Click()
    ChJour Val(J22.Tag)
End Sub
Private Sub J23_Click()
    ChJour Val(J23.Tag)
End Sub
Private Sub J24_Click()
    ChJour Val(J24.Tag)
End Sub
Private Sub J25_Click()
    ChJour Val(J25.Tag)
End Sub
Private Sub J26_Click()
    ChJour Val(J26.Tag)
End Sub
Private Sub J27_Click()
    ChJour Val(J27.Tag)
End Sub
Private Sub J28_Click()
    ChJour Val(J28.Tag)
End Sub
Private Sub J29_Click()
    ChJour Val(J29.Tag)
End Sub
Private Sub J30_Click()
    ChJour Val(J30.Tag)
End Sub
Private Sub J31_Click()
    ChJour Val(J31.Tag)
End Sub
Private Sub J32_Click()
    ChJour Val(J32.Tag)
End Sub
Private Sub J33_Click()
    ChJour Val(J33.Tag)
End Sub
Private Sub J34_Click()
    ChJour Val(J34.Tag)
End Sub
Private Sub J35_Click()
    ChJour Val(J35.Tag)
End Sub
Private Sub J36_Click()
    ChJour Val(J36.Tag)
End Sub
Private Sub J37_Click()
    ChJour Val(J37.Tag)
End Sub
Private Sub J38_Click()
    ChJour Val(J38.Tag)
End Sub
Private Sub J39_Click()
    ChJour Val(J39.Tag)
End Sub
Private Sub J40_Click()
    ChJour Val(J40.Tag)
End Sub
Private Sub J41_Click()
    ChJour Val(J41.Tag)
End Sub
Private Sub J42_Click()
    ChJour Val(J42.Tag)
End Sub


Private Sub ChJour(x As Byte)
    StopEvent = True    'evite que le changement de mois
'ou d'année ne redéclenche
'l'évênement Jour_Change
    Jour.Value = CDate(Pj.Value) + x - jPj.Value
    StopEvent = False
End Sub


Private Sub Jour_Change()
    Dim l As Control
    Dim num As Variant
    Dim j As Date
    'Mise à jour des n° de jour
    Pj.Value = CDate("01/" & Month(Jour.Value) & "/" & Year(Jour.Value))    'Premier Janvier
    jPj.Value = Weekday(Pj, vbMonday)    'n° de jour du premier janvier
    If jPj.Value = 1 Then jPj.Value = 8
    For Each l In FormCal.Controls    'on passe en revue l'ensemble des controls
        num = Val(l.Tag)
        If num >= 1 And num <= 42 Then    'si la propriété .tag est entre 1 et 42 c'est un jour
            j = CDate(Pj.Value) + num - CDate(jPj.Value)
            l.Caption = Day(j)    'mettre à jour le n° de jour


            If Month(j) <> Month(Jour.Value) Then
                l.ForeColor = &H80000011    'si le jour est dans le mois, fort constraste
                sem1.Caption = NOSEM(CDate(Day(Jour.Value) & "/" & Month(Jour.Value) & "/" & Year(Jour.Value)))
            Else
                l.ForeColor = &H800000    'sinon semaine prec et suiv, faible contraste
                sem1.Caption = NOSEM(CDate(Day(Jour.Value) & "/" & Month(Jour.Value) & "/" & Year(Jour.Value)))
            End If


            If CDate(j) = CDate(Day(Jour.Value) & "/" & Month(Jour.Value) & "/" & Year(Jour.Value)) Then
                l.SpecialEffect = 2    'si le jour correspond à la date sélectionné, aspect enfoncé
                l.BackColor = &H8000000C
            Else
                l.SpecialEffect = 3    ' pour les autres, aspect relevé
                l.BackColor = &H8000000F
            End If
        End If
    Next l
    'Mise à jour du mois
    StopEvent = True
    Mois.ListIndex = Month(Jour.Value) - 1
    'Mise à jour de l'année
    Annee.ListIndex = Year(Jour.Value) - 1900
    StopEvent = False


    'Mise à jour de la semaine
    For Each l In FormCal.Controls    'on passe en revue l'ensemble des controls
        num = Val(l.Tag)
        If num = 1 And l.ForeColor = &H80000011 Then    'le jour est dans le mois
            sem1.Caption = NOSEM(CDate(Day(Jour.Value) & "/" & Month(Jour.Value) & "/" & Year(Jour.Value)))
        ElseIf num = 1 Then
            sem1.Caption = NOSEM(CDate(Day(Jour.Value) & "/" & Month(Jour.Value) - 1 & "/" & Year(Jour.Value)))
        End If
    Next
End Sub


Function NOSEM(D As Date) As Long
    D = Int(D)
    NOSEM = DateSerial(Year(D + (8 - Weekday(D)) Mod 7 - 3), 1, 1)
    NOSEM = ((D - NOSEM - 3 + (Weekday(NOSEM) + 1) Mod 7)) \ 7 + 1
End Function


MACRO to activate this code in the worksheets, just need to edit the cell numbers according to what cell range you need to put this calendar in, then double click cell 
to insert date from calendar....




Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim UnJour As Date
    If Not Application.Intersect(Target, Range("I16")) Is Nothing Then
        UnJour = FormCal.Calendrier
        If UnJour <> 0 Then
            Target = Format(UnJour, "mm/dd/yyyy")
            Target.Offset(0, -1).Select
        Else
            Target = ""
              Target.Offset(0, -1).Select
        End If
    End If
   
End Sub
 
Last edited by a moderator:

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
Sort by date Sort by votes
Hello,

Most probably your problem is related to the Calendar Control ActiveX Object ...

Sadly you might have to look for an alternative for your Win 10 64 bit new system ...
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
Numeric Value returned when Time format returned to User Form TextBox
Replies
3
Views
126
6StringJazzer
6StringJazzer
D
  • Question Question
VBA Code to Apply an AVERAGE of a Range on Cells as New Records are added Via a User Form
Replies
2
Views
89
Denny57
D
D
  • Question Question
Possible Use of CountIF and AVERAGE Functions
Replies
1
Views
182
Denny57
D
K
  • Question Question
VBA Excel, Error code 91
4 5 6
Replies
56
Views
2K
Candyman8019
C
F
  • Question Question
Edit existing code
2
Replies
10
Views
528
Flavien
F

Forum statistics

Threads
1,224,600
Messages
6,179,836
Members
452,947
Latest member
Gerry_F

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top