EXCEL Create Excel Calendar

Mrrrr's Forum (VIEW ONLY)
Un forum care ofera solutii pentru unele probleme legate in general de PC. Pe langa solutii, aici puteti gasi si alte lucruri interesante // A forum that offers solutions to some PC related issues. Besides these, here you can find more interesting stuff.

Lista Forumurilor Pe Tematici

Mrrrr's Forum (VIEW ONLY) | Reguli | Inregistrare | Login

POZE MRRRR'S FORUM (VIEW ONLY)

Nu sunteti logat.

Nou pe simpatie:
Profil Tanya_sexy

Femeie
24 ani
Hunedoara
cauta Barbat
24 - 47 ani

Mrrrr's Forum (VIEW ONLY) / Tutoriale si Ghiduri Utile // Tutorials and useful guides / [EXCEL] Create Excel Calendar

Moderat de TRaP, TonyTzu

Autor

Mesaj

Pagini: 1

Mrrrr
AdMiN

Inregistrat: acum 17 ani
Postari: 2186

Source with original calendar, and also credits to original coder:

Now for my personal edit, with Monday as the first day of the week instead of Sunday as it is default, plus some other esthetic modifications.

First, a module that if added to the end of this post would be lost. The module was part of the original code in order for one to see the date order if one wants, as in dd.mm.yyyy, mm.dd.yyyy, or yyyy.mm.dd.
Then I moved the Form.Show code from Sheet code to this module.

'https://stackoverflow.com/questions/22739362/how-to-check-os-system-date-format-using-excel-vba
Sub checkPCTimeAndDateFormat()
' 0 = mm.dd.yyyy; 1 = dd.mm.yyyy; 2 = yyyy.mm.dd
If Application.International(xlDateOrder) = 0 Then
Debug.Print "mm.dd.yyyy"

ElseIf Application.International(xlDateOrder) = 1 Then
Debug.Print "dd.mm.yyyy"

ElseIf Application.International(xlDateOrder) = 2 Then
Debug.Print "yyyy.mm.dd"
End If
End Sub

Sub frmCalendarShow()
frmCalendar.Show (False)
End Sub

The design part of the calendar.

The month combo box on the top left is called: Month_Box
The year combo box on the top right is called: Year_Box
The 42 days are named from top left to bottom right: C1 to C42
Their default color is: Button Face, or &H8000000F&
The frame behind all those days is named Frame2 and has BackColor as ActiveTitleBar, or &H80000002&
The outer frame with caption "Alege luna si anul" is named Frame1
Day names are normal labels, no naming convention here

The rest of the coloring is done through code.

The code part of the Userform.

Option Explicit
Dim This_Day As Date
Dim This_Month As Date
Dim This_Year As Date
Dim calender As Boolean
Dim i As Integer

Private Sub C1_Click()
Selection.Value = Me.C1.ControlTipText
End Sub

Private Sub C11_Click()
Selection.Value = Me.C11.ControlTipText
End Sub

Private Sub C12_Click()
Selection.Value = Me.C12.ControlTipText
End Sub

Private Sub C13_Click()
Selection.Value = Me.C13.ControlTipText
End Sub

Private Sub C14_Click()
Selection.Value = Me.C14.ControlTipText
End Sub

Private Sub C15_Click()
Selection.Value = Me.C15.ControlTipText
End Sub

Private Sub C16_Click()
Selection.Value = Me.C16.ControlTipText
End Sub

Private Sub C17_Click()
Selection.Value = Me.C17.ControlTipText
End Sub

Private Sub C18_Click()
Selection.Value = Me.C18.ControlTipText
End Sub

Private Sub C19_Click()
Selection.Value = Me.C19.ControlTipText
End Sub

Private Sub C2_Click()
Selection.Value = Me.C2.ControlTipText
End Sub

Private Sub C20_Click()
Selection.Value = Me.C20.ControlTipText
End Sub

Private Sub C21_Click()
Selection.Value = Me.C21.ControlTipText
End Sub

Private Sub C22_Click()
Selection.Value = Me.C22.ControlTipText
End Sub

Private Sub C23_Click()
Selection.Value = Me.C23.ControlTipText
End Sub

Private Sub C24_Click()
Selection.Value = Me.C24.ControlTipText
End Sub

Private Sub C25_Click()
Selection.Value = Me.C25.ControlTipText
End Sub

Private Sub C26_Click()
Selection.Value = Me.C26.ControlTipText
End Sub

Private Sub C27_Click()
Selection.Value = Me.C27.ControlTipText
End Sub

Private Sub C28_Click()
Selection.Value = Me.C28.ControlTipText
End Sub

Private Sub C29_Click()
Selection.Value = Me.C29.ControlTipText
End Sub

Private Sub C3_Click()
Selection.Value = Me.C3.ControlTipText
End Sub

Private Sub C30_Click()
Selection.Value = Me.C30.ControlTipText
End Sub

Private Sub C31_Click()
Selection.Value = Me.C31.ControlTipText
End Sub

Private Sub C32_Click()
Selection.Value = Me.C32.ControlTipText
End Sub

Private Sub C33_Click()
Selection.Value = Me.C33.ControlTipText
End Sub

Private Sub C34_Click()
Selection.Value = Me.C34.ControlTipText
End Sub

Private Sub C35_Click()
Selection.Value = Me.C35.ControlTipText
End Sub

Private Sub C36_Click()
Selection.Value = Me.C36.ControlTipText
End Sub

Private Sub C37_Click()
Selection.Value = Me.C37.ControlTipText
End Sub

Private Sub C38_Click()
Selection.Value = Me.C38.ControlTipText
End Sub

Private Sub C39_Click()
Selection.Value = Me.C39.ControlTipText
End Sub

Private Sub C4_Click()
Selection.Value = Me.C4.ControlTipText
End Sub

Private Sub C40_Click()
Selection.Value = Me.C40.ControlTipText
End Sub

Private Sub C41_Click()
Selection.Value = Me.C41.ControlTipText
End Sub

Private Sub C42_Click()
Selection.Value = Me.C42.ControlTipText
End Sub

Private Sub C5_Click()
Selection.Value = Me.C5.ControlTipText
End Sub

Private Sub C6_Click()
Selection.Value = Me.C6.ControlTipText
End Sub

Private Sub C7_Click()
Selection.Value = Me.C7.ControlTipText
End Sub

Private Sub C8_Click()
Selection.Value = Me.C8.ControlTipText
End Sub

Private Sub C9_Click()
Selection.Value = Me.C9.ControlTipText
End Sub

Private Sub C10_Click()
Selection.Value = Me.C10.ControlTipText
End Sub

Private Sub Frame1_Click()

End Sub

Private Sub Month_Box_Change()
If Me.Month_Box.Value <> "" And Me.Year_Box.Value <> "" Then
Call Create_Calender
End If
End Sub

Private Sub UserForm_Initialize()
Application.EnableEvents = False
This_Day = Date
This_Month = Format(This_Day, "mm")
This_Year = Format(This_Day, "yyyy")
For i = 1 To 12
'Month_Box.AddItem Format(DateSerial(Year(Date), Month(Date) + i, 0), "mmmm") ' snippet from original code
Month_Box.AddItem Format(DateSerial(Year(Date), i + 1, 0), "mmmm")
Next
'Month_Box.ListIndex = Format(Date, "mm") - Format(Date, "mm") ' snippet from original code
Month_Box.ListIndex = Format(Date, "mm") - 1
For i = -10 To 30
If i = 1 Then Year_Box.AddItem Format((This_Day), "yyyy") Else Year_Box.AddItem _
Format((DateAdd("yyyy", (i - 1), This_Day)), "yyyy")
Next
Year_Box.ListIndex = 11
calender = True
Call Create_Calender
Application.EnableEvents = True
End Sub

Sub Create_Calender()

frmCalendar.Caption = StrConv(Month_Box.Value, vbProperCase) & " " & Year_Box.Value

' 0 = mm.dd.yyyy; 1 = dd.mm.yyyy; 2 = yyyy.mm.dd
For i = 1 To 42
If Application.International(xlDateOrder) = 0 Then

If i < Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday) Then
Controls("C" & (i)).Caption = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d")

Controls("C" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "mm/dd/yyyy")

ElseIf i >= Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday) Then
Controls("C" & (i)).Caption = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d")

Controls("C" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "mm/dd/yyyy")
End If

If Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "mmmm") = ((Month_Box.Value)) Then
If Controls("C" & (i)).BackColor <> &HFFFFFF Then Controls("C" & (i)).BackColor = &HFFFFFF
Controls("C" & (i)).Font.Bold = True

If Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "mm/dd/yyyy") = Format(This_Day, "mm/dd/yyyy") Then Controls("C" & (i)).SetFocus
Else
If Controls("C" & (i)).BackColor <> &H80000016 Then Controls("C" & (i)).BackColor = &H8000000F
Controls("C" & (i)).Font.Bold = False
End If

' ##### color current day differently
If Controls("C" & (i)).ControlTipText = Format(Now(), "mm.dd.yyyy") Then
Controls("C" & (i)).BackColor = &H80FFFF
Controls("C" & (i)).Font.Bold = True
End If
' #####

ElseIf Application.International(xlDateOrder) = 1 Then

If i < Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday) Then
Controls("C" & (i)).Caption = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d")

Controls("C" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "dd/mm/yyyy")

ElseIf i >= Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday) Then
Controls("C" & (i)).Caption = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d")

Controls("C" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "dd/mm/yyyy")
End If

If Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "mmmm") = ((Month_Box.Value)) Then
If Controls("C" & (i)).BackColor <> &HFFFFFF Then Controls("C" & (i)).BackColor = &H80000018 '&HFFFFFF
Controls("C" & (i)).Font.Bold = True

If Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "dd/mm/yyyy") = Format(This_Day, "dd/mm/yy") Then Controls("C" & (i)).SetFocus
Else
If Controls("C" & (i)).BackColor <> &H80000016 Then Controls("C" & (i)).BackColor = &H8000000F
Controls("C" & (i)).Font.Bold = False
End If

' ##### color current day differently
If Controls("C" & (i)).ControlTipText = Format(Now(), "dd.mm.yyyy") Then
Controls("C" & (i)).BackColor = &H80FFFF
Controls("C" & (i)).Font.Bold = True
End If
' #####

ElseIf Application.International(xlDateOrder) = 2 Then

If i < Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday) Then
Controls("C" & (i)).Caption = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d")

Controls("C" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "yyyy/mm/dd")

ElseIf i >= Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday) Then
Controls("C" & (i)).Caption = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d")

Controls("C" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "yyyy/mm/dd")
End If

If Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "mmmm") = ((Month_Box.Value)) Then
If Controls("C" & (i)).BackColor <> &H8000000F Then Controls("C" & (i)).BackColor = &HFFFFFF
Controls("C" & (i)).Font.Bold = True

If Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value), vbMonday)), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "yyyy/mm/dd") = Format(This_Day, "yyyy/mm/dd") Then Controls("C" & (i)).SetFocus
Else
If Controls("C" & (i)).BackColor <> &H80000016 Then Controls("C" & (i)).BackColor = &H8000000F
Controls("C" & (i)).Font.Bold = False
End If

End If

' ##### color current day differently
If Controls("C" & (i)).ControlTipText = Format(Now(), "yyyy.mm.dd") Then
Controls("C" & (i)).BackColor = &H80FFFF
Controls("C" & (i)).Font.Bold = True
End If
' #####

Next i

End Sub

Private Sub Year_Box_Change()
If Me.Month_Box.Value <> "" And Me.Year_Box.Value <> "" Then
Call Create_Calender
End If
End Sub

_______________________________________

pus acum 2 luni

Pagini: 1

Mergi la