Membuat kalender Excel Legkap - Tidak kurang dari 7 artikel di iparengan.com yang membahas tentang cara membuat kalender excel, baik kalender excel dengan menggunakan kode macro maupun yang menggunakan rumus. Kalender merupakan sebuah sistem untuk memberi nama pada sebuah periode waktu (seperti hari atau tanggal sebagai contohnya). Nama-nama ini dikenal sebagai tanggal kalender. Tanggal ini bisa didasarkan dari pergerakan benda angkasa seperti matahari dan bulan. Sedangkan saat ini saya tidak akan membahas tetang cara membuat kalender hijriyah, akan tetapi saya akan membhas tetang cara membuat kalender excel tahun Masehi, karena umumnya orang menggunakan kalender Masehi, next insya Allah kita bahas cara membuat kalender Hijriyah

Membuat kalender Excel workbook

Fungsi yang saya gunakan untuk membuat kalender dalam workbook adalah
Fungsi mengetahui Bulan Jauari =DATE(theyear;1;1)
Fungsi mengetahui Bulan Februari =DATE(theyear;2;1)
Fungsi mengetahui Bulan Maret =DATE(theyear;3;1)
Fungsi mengetahui Bulan April =DATE(theyear;4;1)
Fungsi mengetahui Bulan Mei =DATE(theyear;5;1)
Fungsi mengetahui Bulan Juni =DATE(theyear;6;1)
Fungsi mengetahui Bulan Juli =DATE(theyear;7;1)
Fungsi mengetahui Bulan Agustus =DATE(theyear;8;1)
Fungsi mengetahui Bulan September =DATE(theyear;9;1)
Fungsi mengetahui Bulan Oktober =DATE(theyear;10;1)
Fungsi mengetahui Bulan November =DATE(theyear;11;1)
Fungsi mengetahui Bulan Desember =DATE(theyear;12;1)

Dalam Sel C3 letakan Tahun , misalnya tahun "2017"
Kemudian fungsi membuat tanggal berdasarkan bulan, bulan Januari saya letakan di sel C5
Awalan hari adalah hari Minggu letakan di sel C6, hari Senin letakan di sel D6, hari Selasa letakan di sel E6, hari Rabu letakan di sel F6, hari Kamis letakan di sel G6, hari Jumat letakan di sel H6, hari Sabtu letakan di sel I6
Dibawah sel hari Minggu sel C7, senin sel B7, selasa sel C7, Rabu sel D7, Kamis sel E7, Jumat sel F7, Sabtu sel G7 letakan fungsi ini
=IF(MONTH(DATE(YEAR(C5);MONTH(C5);1))<>MONTH(DATE(YEAR(C5);MONTH(C5);1)-(WEEKDAY(DATE(YEAR(C5);MONTH(C5);1))-1)+{0;1;2;3;4;5}*7+{1\2\3\4\5\6\7}-1);"";DATE(YEAR(C5);MONTH(C5);1)-(WEEKDAY(DATE(YEAR(C5);MONTH(C5);1))-1)+{0;1;2;3;4;5}*7+{1\2\3\4\5\6\7}-1)
Copy juga fungsi diatas kemudian pastekan ke sel C8 sampai I12


Kita telah selesai membuat Kalender akan tetapi haya untuk bulan januari saja, untuk hasil lengkapnya silahkan anda downlaod dilin downlaod dibawah ini
Download - Membuat kalender Excel workbook

Membuat kalender Excel VBA

Ada duda cara membuat kalender dengan VBA, cara pertama dengan menggunakan Kontrol MonthView, Cara kedua menggunakan kodde API dan kode macro. Untuk proses yang mudah adalah cara pertama yaitu dengan menggunakan kontrol MonthView akan tetapi untuk kompatibilitas cara kedua lebih unggul bahkan unggul sangat jauh. Kenapa bisa demikian ?? Karena MonthView merupakan kontrol VBA versi lanjutan SP 6.0, kontrol versi ini memerlukan pengetahuan lebih agar dapat berjalan disemua versi office, seperti yang anda ketahui versi office sudah sampai versi 2016, bisa jadi saat anda membuat kelender di office 2007 berjalan dengan lancar akan tetapi ketika dibuka di office 2016 langsung menemukan masalah, seperti masalah Error &H0000FFFFF atau Out Off Memory atau Compile error hideen module dan lain lain yang permasalahan ini agak susah mengatasinya, silahkan baca artikel terkait hal ini Masalah ketika menggunakan ListView

Okelah kita kemabli membuat kalender dengan VBA dengan cara kedua, cara pertama saya bahasa dibelakang bawah sana :), anda tidak perlu melakukan persiapan apa apa pada worksheet, langsung ke jendela VBE, Masukan Userform dan dalam form masukan kontrol Frame, atur design formnya sebagaimana gambar dibawah ini


Kode macro dalam form adalah sebagai berikut, silahkan copy dan pastekan kedalam form kode macro dibawah ini

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 ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Const GWL_STYLE As Long = -16
Private Const GWL_EXSTYLE As Long = -20
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Const WS_EX_APPWINDOW As Long = &H40000
Private Const SW_SHOW As Long = 5
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_POPUP As Long = &H80000000&
Private WithEvents Calendar1 As cCalendar
Public Target As Range
Sub minimalisuserform()
Dim lHwnd As Long, lForm_1 As Long, lForm_2 As Long
If Val(Application.Version) < 9 Then lHwnd = FindWindow("ThunderXFrame", Me.Caption) Else lHwnd = FindWindow("ThunderDFrame", Me.Caption) End If lForm_1 = GetWindowLong(lHwnd, GWL_STYLE) lForm_2 = lForm_1 Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX lForm_2 = lForm_2 And Not WS_VISIBLE And Not WS_POPUP SetWindowLong lHwnd, GWL_STYLE, lForm_2 lForm_1 = GetWindowLong(lHwnd, GWL_EXSTYLE) lForm_2 = lForm_1 Or WS_EX_APPWINDOW SetWindowLong lHwnd, GWL_EXSTYLE, lForm_2 ShowWindow lHwnd, SW_SHOW End Sub Private Sub UserForm_Activate() Call minimalisuserform End Sub Private Sub Calendar1_Click() Call CloseDatePicker(True) End Sub Private Sub Calendar1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = vbKeyEscape Then Call CloseDatePicker(False) End If End Sub Private Sub UserForm_Initialize() If Calendar1 Is Nothing Then Set Calendar1 = New cCalendar With Calendar1 .Add_Calendar_into_Frame Me.Frame1 .UseDefaultBackColors = False .DayLength = 3 .MonthLength = mlENShort .Height = 170 .Width = 220 .GridFont.Size = 9 .DayFont.Size = 9 .Refresh End With Me.Height = 209 Me.Width = 239 End If End Sub




Yang kedua buatlah ClassModule, rubah nama Class1 menjadi cCalendar, lalu ketika saja kode kode panjang dibawah ini kedalam ClassModule :D


Public Event AfterUpdate()
Public Event BeforeUpdate(ByRef Cancel As Integer)
Public Event Click()
Public Event DblClick()
Public Event KeyDown( _
ByVal KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)

'# Members for Main Object
Private WithEvents CBxY As MSForms.ComboBox
Private WithEvents CBxM As MSForms.ComboBox

Private CLb As MSForms.Label
Private mDayButtons() As cCalendar
Private mLabelButtons() As cCalendar

Private PTitleNewFont As MSForms.NewFont
Private PDayNewFont As MSForms.NewFont
Private PGridNewFont As MSForms.NewFont
'# Members for Button Object
Private WithEvents CmB As MSForms.CommandButton
Private CmBl As MSForms.Label
Private CmBlNum As MSForms.Label
Private mcMain As cCalendar

'# For Properties
Private lPFontSize As Long
Private lPMonthLength As calMonthLength
Private lPDayLength As Long
Private bPYearFirst As Boolean
Private lPTitleFontColor As Long
Private lPGridFontColor As Long
Private lPDayFontColor As Long
Private lPFirstDay As calDayOfWeek
Private dValue As Date
Private lPBackColor As Long
Private lPMonth As Long
Private lPYear As Long
Private lPDay As Long
Private lPHeaderBackColor As Long
Private lPUseDefaultBackColors As Boolean
Private bPVisible As Boolean
Private sPHeight As Single
Private sPWidth As Single
Private sPTop As Single
Private sPLeft As Single
Private lPSaturdayBackColor As Long
Private lPSundayBackColor As Long
Private lPSelectedBackColor As Long
Private sPControlTipText As String
Private bPTabStop As Boolean
Private lPTabIndex As Long
Private sPTag As String

Private bPShowDays As Boolean
Private bPShowTitle As Boolean
Private bPShowDateSelectors As Boolean
Private bPValueIsNull As Boolean
Private bPRightToLeft As Boolean

Private bPMACFix As Boolean 'Fix MAC transparency errors
Private bPSaturdaySelectable As Boolean
Private bPSundaySelectable As Boolean

Private Const cDayFontColorSelected As Long = &HFFFFFF 'Button text - Black
Private Const cDayFontColorInactive As Long = &H8080FF 'Disabled text - Dark gray
Private Const cDefaultWidth As Single = 216
Private Const cDefaultHeight As Single = 144

Public Enum calDayOfWeek
dwMonday = 1
dwTuesday = 2
dwWednesday = 3
dwThursday = 4
dwFriday = 5
dwSaturday = 6
dwSunday = 7
End Enum

Public Enum calMonthLength '(Used for month and day names too.)
mlLocalLong = 0 'Local name, long form
mlLocalShort = 1 'Local name, short form
mlENLong = 2 'English name, long form
mlENShort = 3 'English name, short form
End Enum



'################################################
'# Properties for Main object - Not available

Public Property Get GridCellEffect() As Long
'Property Blank - not work
'Determines the effect used to display the grid.
End Property

Public Property Get GridLinesColor() As Long
'Property Blank - not work
'Determines the color used to display the lines in the grid.
End Property

Public Property Get ShowHorizontalGrid() As Boolean
'Property Blank - not work
'Specifies whether the calendar display horizontal gridlines.
End Property

Public Property Get ShowVerticalGrid() As Boolean
'Property Blank - not work
'Specifies whether to display vertical gridlines.
End Property

Public Property Get HelpContextID() As Long
'Property Blank - not work
'Specifies Help identifier
End Property


'###########################
'# Properties for Main object

Public Property Get Tag() As String
Tag = sPTag
End Property

Public Property Let Tag(sTag As String)
sPTag = sTag
End Property

Public Property Get Parent() As Control
If bInit Then
Set Parent = CBxY.Parent.Parent
Else
Set Parent = Nothing
End If
End Property

Public Property Get ValueIsNull() As Boolean
ValueIsNull = bPValueIsNull
End Property

Public Property Let ValueIsNull(ByVal bValueIsNull As Boolean)
bPValueIsNull = bValueIsNull
If bInit Then
Value = Value
End If
End Property

Public Property Get ShowTitle() As Boolean
ShowTitle = bPShowTitle
End Property

Public Property Let ShowTitle(ByVal bShowTitle As Boolean)
bPShowTitle = bShowTitle
If bInit Then
CLb.Visible = bPShowTitle
Call Move
End If
End Property

Public Property Get ShowDays() As Boolean
ShowDays = bPShowDays
End Property

Public Property Let ShowDays(ByVal bShowDays As Boolean)
Dim i As Long
bPShowDays = bShowDays
If bInit Then
For i = 0 To 6
mLabelButtons(i).Obj_CmBl.Visible = bShowDays
Next
Call Move
End If
End Property

Public Property Get ShowDateSelectors() As Boolean
ShowDateSelectors = bPShowDateSelectors
End Property

Public Property Let ShowDateSelectors(ByVal bShowDateSelectors As Boolean)
bPShowDateSelectors = bShowDateSelectors
If bInit Then
CBxY.Visible = bShowDateSelectors
CBxM.Visible = bShowDateSelectors
Call Move
End If
End Property

Public Property Get TabIndex() As Long
TabIndex = lPTabIndex
End Property

Public Property Let TabIndex(ByVal lTabIndex As Long)
lPTabIndex = lTabIndex
If bInit Then
CBxY.Parent.TabIndex = lTabIndex
End If
End Property

Public Property Get TabStop() As Boolean
TabStop = bPTabStop
End Property

Public Property Let TabStop(ByVal bTabStop As Boolean)
bPTabStop = bTabStop
If bInit Then
CBxY.Parent.TabStop = bTabStop
End If
End Property

Public Property Get ControlTipText() As String
ControlTipText = sPControlTipText
End Property

Public Property Let ControlTipText(ByVal sControlTipText As String)
Dim i As Long
sPControlTipText = sControlTipText
If bInit Then
For i = 0 To 6
mLabelButtons(i).Obj_CmBl.ControlTipText = sControlTipText
Next
For i = 0 To 41
mDayButtons(i).Obj_Cmb.ControlTipText = sControlTipText
Next
CBxM.ControlTipText = sControlTipText
CBxY.ControlTipText = sControlTipText
CLb.ControlTipText = sControlTipText
'CBxY.Parent.ControlTipText = sControlTipText
End If
End Property

Public Property Get GridFont() As MSForms.NewFont
Set GridFont = PGridNewFont
End Property

Public Property Set GridFont(ByRef clGridNewFont As MSForms.NewFont)
Set PGridNewFont = clGridNewFont
End Property

Public Property Get DayFont() As MSForms.NewFont
Set DayFont = PDayNewFont
End Property

Public Property Set DayFont(ByRef clDayNewFont As MSForms.NewFont)
Set PDayNewFont = clDayNewFont
End Property

Public Property Get TitleFont() As MSForms.NewFont
Set TitleFont = PTitleNewFont
End Property

Public Property Set TitleFont(ByRef clTitleNewFont As MSForms.NewFont)
Set PTitleNewFont = clTitleNewFont
End Property

Public Property Get Visible() As Boolean
Visible = bPVisible
End Property

Public Property Let Visible(ByVal bVisible As Boolean)
bPVisible = bVisible
If bInit Then
CBxY.Parent.Visible = bVisible
End If
End Property

Public Property Get Left() As Single
Left = sPLeft
End Property

Public Property Let Left(ByVal sLeft As Single)
sPLeft = sLeft
If bInit Then
CBxY.Parent.Left = sLeft
End If
End Property

Public Property Get Top() As Single
Top = sPTop
End Property

Public Property Let Top(ByVal ssTop As Single)
sPTop = ssTop
If bInit Then
CBxY.Parent.Top = ssTop
End If
End Property

Public Property Get Height() As Single
Height = sPHeight
End Property

Public Property Let Height(ByVal sHeight As Single)
sPHeight = sHeight
If bInit Then
CBxY.Parent.Height = sHeight
Call Move
End If
End Property


Public Property Get Width() As Single
Width = sPWidth
End Property

Public Property Let Width(ByVal sWidth As Single)
'sWidth = Zero_Negative_Value(sWidth)
sPWidth = sWidth
If bInit Then
CBxY.Parent.Width = sWidth
Call Move
End If
End Property

Public Property Get BackColor() As Long
BackColor = lPBackColor
End Property

Public Property Let BackColor(ByVal lBackColor As Long)
lPBackColor = lBackColor
If bInit Then
CBxY.Parent.BackColor = lBackColor
End If
End Property

Public Property Get HeaderBackColor() As Long
HeaderBackColor = lPHeaderBackColor
End Property

Public Property Let HeaderBackColor(ByVal lHeaderBackColor As Long)
Dim i As Long
lPHeaderBackColor = lHeaderBackColor
UseDefaultBackColors = False
End Property

Public Property Get UseDefaultBackColors() As Boolean
UseDefaultBackColors = lPUseDefaultBackColors
End Property

Public Property Let UseDefaultBackColors(ByVal lUseDefaultBackColors As Boolean)
lPUseDefaultBackColors = lUseDefaultBackColors
Call Refresh
End Property

Public Property Get SaturdayBackColor() As Long
SaturdayBackColor = lPSaturdayBackColor
End Property

Public Property Let SaturdayBackColor(ByVal lSaturdayBackColor As Long)
lPSaturdayBackColor = lSaturdayBackColor
UseDefaultBackColors = False
End Property

Public Property Get SundayBackColor() As Long
SundayBackColor = lPSundayBackColor
End Property

Public Property Let SundayBackColor(ByVal lSundayBackColor As Long)
lPSundayBackColor = lSundayBackColor
UseDefaultBackColors = False
End Property

Public Property Get SelectedBackColor() As Long
SelectedBackColor = lPSelectedBackColor
End Property

Public Property Let SelectedBackColor(ByVal lSelectedBackColor As Long)
lPSelectedBackColor = lSelectedBackColor
Call Refresh
End Property

Public Property Get SaturdaySelectable() As Boolean
SaturdaySelectable = bPSaturdaySelectable
End Property

Public Property Let SaturdaySelectable(ByVal bSaturdaySelectable As Boolean)
bPSaturdaySelectable = bSaturdaySelectable
Call Refresh
End Property

Public Property Get SundaySelectable() As Boolean
SundaySelectable = bPSundaySelectable
End Property

Public Property Let SundaySelectable(ByVal bSundaySelectable As Boolean)
bPSundaySelectable = bSundaySelectable
Call Refresh
End Property

Public Property Get FirstDay() As calDayOfWeek
FirstDay = lPFirstDay
End Property

Public Property Let FirstDay(ByVal vbFirstDay As calDayOfWeek)
Select Case vbFirstDay
Case 1 To 7
Case Else
vbFirstDay = 1
End Select

lPFirstDay = vbFirstDay
If bInit Then
Call ApplyWeekDayLabelChanges
Call Refresh
End If
End Property

Public Property Get DayFontColor() As Long
DayFontColor = lPDayFontColor
End Property

Public Property Let DayFontColor(ByVal lFontColor As Long)
Dim i As Long

lPDayFontColor = lFontColor
If bInit Then
For i = 0 To 6
mLabelButtons(i).Obj_CmBl.ForeColor = lFontColor
Next
End If
End Property

Public Property Get GridFontColor() As Long
GridFontColor = lPGridFontColor
End Property

Public Property Let GridFontColor(ByVal lFontColor As Long)
lPGridFontColor = lFontColor
Call Refresh
End Property

Public Property Let TitleFontColor(ByVal lFontColor As Long)
lPTitleFontColor = lFontColor
If bInit Then
CLb.ForeColor = lFontColor
End If
End Property

Public Property Get TitleFontColor() As Long
TitleFontColor = lPTitleFontColor
End Property

Public Property Get Month() As Long
Month = lPMonth
End Property

Public Property Let Month(ByVal lMonth As Long)
If lMonth = 0 Then
Value = Empty
Else
If lMonth < 0 Then lMonth = lPMonth lMonth = fMin(lMonth, 12) Value = SumMonthsToDate(dValue, lMonth - lPMonth) End If lPMonth = lMonth End Property Public Property Get Year() As Long Year = lPYear End Property Public Property Let Year(ByVal lYear As Long) If lYear = 0 Then Value = Empty Else Value = VBA.DateSerial(CheckYear(lYear), VBA.Month(dValue), VBA.Day(dValue)) End If lPYear = lYear End Property Public Property Get Day() As Long Day = lPDay End Property Public Property Let Day(ByVal lDay As Long) If lDay = 0 Then Value = Empty Else If lDay < 0 Then lDay = lPDay lDay = fMin(lDay, VBA.Day(VBA.DateSerial(VBA.Year(dValue), VBA.Month(dValue) + 1, 0))) Value = VBA.DateSerial(VBA.Year(dValue), VBA.Month(dValue), lDay) End If lPDay = lDay End Property Public Property Get Value() As Variant If bPValueIsNull Then Value = Empty Else Value = dValue End If End Property Public Property Let Value(ByVal newDate As Variant) Dim Cancel As Integer '*** Integer for backward compatibility If CheckValue(newDate) = False Then newDate = Empty RaiseEvent BeforeUpdate(Cancel) If Cancel = 0 Then 'Not canceled. If bInit And Not IsEmpty(newDate) Then CBxY.ListIndex = VBA.Year(newDate) - 1990 CBxM.ListIndex = VBA.Month(newDate) - 1 End If If (bPValueIsNull = IsEmpty(newDate)) Or (newDate <> dValue) Then
If Not IsEmpty(newDate) Then
dValue = newDate
End If
bPValueIsNull = IsEmpty(newDate)

Call Refresh
End If

RaiseEvent AfterUpdate
End If
End Property

Public Property Get DayLength() As calMonthLength
DayLength = lPDayLength
End Property

Public Property Let DayLength(ByVal bDayLength As calMonthLength)
lPDayLength = bDayLength
If bInit Then
Call ApplyWeekDayLabelChanges
End If
End Property

Public Property Get MonthLength() As calMonthLength
MonthLength = lPMonthLength
End Property

Public Property Let MonthLength(ByVal iMonthLength As calMonthLength)
lPMonthLength = iMonthLength

If bInit Then
CBxM.List = fMonthName(CLng(iMonthLength))
Value = Value
End If
End Property

Public Property Get YearFirst() As Boolean
YearFirst = bPYearFirst
End Property

Public Property Let YearFirst(ByVal bYearFirst As Boolean)
bPYearFirst = bYearFirst
Call RenderLabel
End Property


Public Property Get MACFix() As Boolean
MACFix = bPMACFix
End Property

Public Property Let MACFix(ByVal bMACFix As Boolean)
bPMACFix = bMACFix
Call Refresh
End Property


Public Property Get RightToLeft() As Boolean
RightToLeft = bPRightToLeft
End Property

Public Property Let RightToLeft(ByVal bRightToLeft As Boolean)
bPRightToLeft = bRightToLeft
If bInit Then
Call ApplyWeekDayLabelChanges
Call Refresh
End If
End Property


'###########################
'# Properties for Day button objects

Public Property Set Main(ByVal theMain As cCalendar)
Set mcMain = theMain
End Property

Private Property Get Main() As cCalendar
Set Main = mcMain
End Property

Public Property Get Obj_Cmb() As MSForms.CommandButton
Set Obj_Cmb = CmB
End Property

Public Property Set Obj_Cmb(ByVal vNewValue As MSForms.CommandButton)
Set CmB = vNewValue
End Property

Public Property Get Obj_CmBl() As MSForms.Label
Set Obj_CmBl = CmBl
End Property

Public Property Set Obj_CmBl(ByVal vNewValue As MSForms.Label)
Set CmBl = vNewValue
End Property

Public Property Set Obj_CmBlNum(ByVal vNewValue As MSForms.Label)
Set CmBlNum = vNewValue
End Property

Public Property Get Obj_CmBlNum() As MSForms.Label
Set Obj_CmBlNum = CmBlNum
End Property


'###########################
'# Public Methods

Public Sub AboutBox()
MsgBox "Autori: r, Kris, Gabor"
End Sub

Public Sub Add(ByVal fForm As MSForms.UserForm)

Dim cFrame As MSForms.Frame
Set cFrame = fForm.Controls.Add("Forms.Frame.1")

With cFrame
.Width = IIf(sPWidth < 0, cDefaultWidth, sPWidth) .Height = IIf(sPHeight < 0, cDefaultHeight, sPHeight) End With Call Add_Calendar_into_Frame(cFrame) End Sub Public Sub Add_Calendar_into_Frame(ByVal cFrame As MSForms.Frame) Dim i As Long Dim v(40) As Variant Dim w As Variant Dim dTemp As Date For i = 0 To 40 v(i) = CStr(1990 + i) Next With cFrame .BackColor = BackColor .Caption = "" .SpecialEffect = 0 .Visible = bPVisible End With Set CLb = cFrame.Controls.Add("Forms.Label.1") Set CBxY = cFrame.Controls.Add("Forms.ComboBox.1") Set CBxM = cFrame.Controls.Add("Forms.ComboBox.1") ReDim mLabelButtons(6) ReDim mDayButtons(41) w = fWeekdayName(CInt(lPDayLength)) For i = 0 To 6 Set mLabelButtons(i) = New cCalendar Set mLabelButtons(i).Main = Me Set mLabelButtons(i).Obj_CmBl = cFrame.Controls.Add("Forms.Label.1") With mLabelButtons(i).Obj_CmBl .Caption = w(((i + lPFirstDay - 1) Mod 7)) .ForeColor = DayFontColor .TextAlign = fmTextAlignCenter .BorderStyle = fmBorderStyleSingle .BorderColor = &H80000010& 'warna '.SpecialEffect = fmSpecialEffectEtched If HeaderBackColor = -1 Then .BackColor = cDayFontColorSelected 'Dark gray .BackStyle = fmBackStyleTransparent Else .BackColor = HeaderBackColor .BackStyle = fmBackStyleOpaque End If End With Next For i = 0 To 41 Set mDayButtons(i) = New cCalendar Set mDayButtons(i).Main = Me Set mDayButtons(i).Obj_CmBl = cFrame.Controls.Add("Forms.Label.1") With mDayButtons(i).Obj_CmBl 'MAC Fix .TextAlign = fmTextAlignCenter End With Set mDayButtons(i).Obj_CmBlNum = cFrame.Controls.Add("Forms.Label.1") With mDayButtons(i).Obj_CmBlNum .TextAlign = fmTextAlignCenter .BackStyle = fmBackStyleTransparent End With Set mDayButtons(i).Obj_Cmb = cFrame.Controls.Add("Forms.CommandButton.1") With mDayButtons(i).Obj_Cmb .BackStyle = fmBackStyleTransparent 'MAC Problem: No button transparency End With mDayButtons(i).RightToLeft = bPRightToLeft Next With CBxY .ListRows = 12 .List = v .ListIndex = VBA.Year(dValue) - 1990 .ShowDropButtonWhen = fmShowDropButtonWhenFocus .font.Bold = True .MatchRequired = True End With With CBxM .ListRows = 12 .List = fMonthName(lPMonthLength) .ListIndex = VBA.Month(dValue) - 1 .ShowDropButtonWhen = fmShowDropButtonWhenFocus .font.Bold = True .MatchRequired = True End With With CLb .ForeColor = TitleFontColor .TextAlign = fmTextAlignCenter .BackStyle = fmBackStyleTransparent End With Call ApplyWeekDayLabelChanges Call ApplyFontChanges Call Refresh_Properities Call Move End Sub Private Sub ApplyWeekDayLabelChanges() Dim i As Long Dim w w = fWeekdayName(CInt(lPDayLength)) For i = 0 To 6 If bPRightToLeft Then mLabelButtons(6 - i).Obj_CmBl.Caption = w((i + lPFirstDay - 1) Mod 7) Else mLabelButtons(i).Obj_CmBl.Caption = w((i + lPFirstDay - 1) Mod 7) End If Next End Sub Private Sub ApplyFontChanges() Dim font As MSForms.NewFont Dim i As Long If Not PDayNewFont Is Nothing Then For i = 0 To 6 With mLabelButtons(i).Obj_CmBl If .font.Bold <> DayFont.Bold Then _
.font.Bold = DayFont.Bold
If .font.Weight <> DayFont.Weight Then _
.font.Weight = DayFont.Weight
If .font.Charset <> DayFont.Charset Then _
.font.Charset = DayFont.Charset
If .font.Italic <> DayFont.Italic Then _
.font.Italic = DayFont.Italic
If .font.Name <> DayFont.Name Then _
.font.Name = DayFont.Name
If .font.Size <> DayFont.Size Then _
.font.Size = DayFont.Size
If DayFont.Strikethrough Then _
.font.Strikethrough = True
If DayFont.Underline Then _
.font.Underline = True
End With
Next
End If

If Not PGridNewFont Is Nothing Then
For i = 0 To 41
If Not bPMACFix Then
Set font = mDayButtons(i).Obj_CmBlNum.font
Else
Set font = mDayButtons(i).Obj_Cmb.font
End If

With font
If .Bold <> GridFont.Bold Then _
.Bold = GridFont.Bold
If .Weight <> GridFont.Weight Then _
.Weight = GridFont.Weight
If .Charset <> GridFont.Charset Then _
.Charset = GridFont.Charset
If .Italic <> GridFont.Italic Then _
.Italic = GridFont.Italic
If .Name <> GridFont.Name Then _
.Name = GridFont.Name
If .Size <> GridFont.Size Then _
.Size = GridFont.Size
If GridFont.Strikethrough Then _
.Strikethrough = True
If GridFont.Underline Then _
.Underline = True
End With
Next
End If

If Not PTitleNewFont Is Nothing Then
With CLb
If .font.Bold <> TitleFont.Bold Then _
.font.Bold = TitleFont.Bold
If .font.Weight <> TitleFont.Weight Then _
.font.Weight = TitleFont.Weight
If .font.Charset <> TitleFont.Charset Then _
.font.Charset = TitleFont.Charset
If .font.Italic <> TitleFont.Italic Then _
.font.Italic = TitleFont.Italic
If .font.Name <> TitleFont.Name Then _
.font.Name = TitleFont.Name
If .font.Size <> TitleFont.Size Then _
.font.Size = TitleFont.Size
If TitleFont.Strikethrough Then _
.font.Strikethrough = True
If TitleFont.Underline Then _
.font.Underline = True
End With
End If

End Sub

Public Sub Move( _
Optional vLeft, _
Optional vTop, _
Optional vWidth, _
Optional vHeight, _
Optional vLayout)

Dim i As Long, l As Currency, b As Currency, lc As Currency, bc As Currency
Dim t As Long, b_ym As Currency, b_combo_m As Currency

Const h_combo As Long = 16
Const b_combo_y As Long = 52
b_combo_m = IIf(lPMonthLength = mlENShort Or lPMonthLength = mlLocalShort, 42, 66) '66
b_ym = b_combo_y + 2 + b_combo_m

If bInit Then
t = IIf(ShowDays, 7, 6)

With CBxY.Parent 'Frame
sPTop = IIf(IsMissing(vTop), IIf(Top = -1, .Top, Top), vTop)
sPLeft = IIf(IsMissing(vLeft), IIf(Left = -1, .Left, Left), vLeft)
sPHeight = IIf(IsMissing(vHeight), IIf(Height = -1, .Height, Height), vHeight)
sPWidth = IIf(IsMissing(vWidth), IIf(Width = -1, .Width, Width), vWidth)

l = Height
b = Width
l = Zero_Negative_Value(l - IIf(ShowTitle Or ShowDateSelectors, h_combo, 0) - 1)
lc = CCur(l / t)
bc = CCur(b / 7)
b = bc * 7
End With

If ShowTitle Then
With CLb
.Width = Zero_Negative_Value(IIf(ShowDateSelectors, b - b_ym, b))
.Height = h_combo
.Left = 0
End With
End If

If ShowDateSelectors Then
With CBxY
.Width = b_combo_y
.Height = h_combo
.Left = IIf(ShowTitle, CLb.Width, Int((b - b_ym) / 2)) + _
IIf(YearFirst, 0, b_combo_m + 2)
End With

With CBxM
.Width = b_combo_m
.Height = h_combo
.Left = IIf(ShowTitle, CLb.Width, Int((b - b_ym) / 2)) + _
IIf(YearFirst, b_combo_y + 2, 0)
End With
End If
If ShowDays Then
For i = 0 To 6
With mLabelButtons(i).Obj_CmBl
.Top = IIf(ShowTitle Or ShowDateSelectors, h_combo + 2, 0)
.Left = (i Mod 7) * bc - IIf(i > 0, 1, 0)
.Height = lc
.Width = bc + IIf(i > 0, 1, 0)
End With
Next
End If
For i = 0 To 41
With mDayButtons(i).Obj_Cmb
.Top = Int(i / 7) * lc + _
IIf(ShowTitle Or ShowDateSelectors, h_combo + 2, 0) + _
IIf(ShowDays, lc, 0)
.Left = (i Mod 7) * bc
.Height = lc
.Width = bc
End With
With mDayButtons(i).Obj_CmBl
.Top = mDayButtons(i).Obj_Cmb.Top
.Left = mDayButtons(i).Obj_Cmb.Left
.Height = mDayButtons(i).Obj_Cmb.Height
.Width = mDayButtons(i).Obj_Cmb.Width
End With

With mDayButtons(i).Obj_CmBlNum
.Top = Int(i / 7) * lc + _
IIf(ShowTitle Or ShowDateSelectors, h_combo, 0) + _
IIf(ShowDays, lc, 0) + 6
.Left = (i Mod 7) * bc + 3
.Height = Zero_Negative_Value(lc - 6)
.Width = Zero_Negative_Value(bc - 6)
End With

Next

Else
sPHeight = IIf(IsMissing(Height), cDefaultHeight, Height)
sPWidth = IIf(IsMissing(Width), cDefaultWidth, Width)
End If
End Sub

Public Sub NextDay()
Dim d As Date
d = dValue + 1
d = VBA.DateSerial(CheckYear(VBA.Year(d)), VBA.Month(d), VBA.Day(d))
Value = d
End Sub

Public Sub NextWeek()
Dim d As Date
d = dValue + 7
d = VBA.DateSerial(CheckYear(VBA.Year(d)), VBA.Month(d), VBA.Day(d))
Value = d
End Sub

Public Sub NextMonth()
Value = SumMonthsToDate(dValue, 1)
End Sub

Public Sub NextYear()
Dim d As Date
d = VBA.DateSerial(CheckYear(VBA.Year(dValue) + 1), VBA.Month(dValue), VBA.Day(dValue))
Value = d
End Sub

Public Sub PreviousDay()
Dim d As Date
d = dValue - 1
d = VBA.DateSerial(CheckYear(VBA.Year(d)), VBA.Month(d), VBA.Day(d))
Value = d
End Sub

Public Sub PreviousWeek()
Dim d As Date
d = dValue - 7
d = VBA.DateSerial(CheckYear(VBA.Year(d)), VBA.Month(d), VBA.Day(d))
Value = d
End Sub

Public Sub PreviousMonth()
Value = SumMonthsToDate(dValue, -1)
End Sub

Public Sub PreviousYear()
Dim d As Date
d = VBA.DateSerial(CheckYear(VBA.Year(dValue) - 1), VBA.Month(dValue), VBA.Day(dValue))
Value = d
End Sub

Public Sub Today()
Value = VBA.Date
End Sub

Public Sub Refresh()
If bInit Then
Call Refresh_Panel(VBA.Month(dValue), VBA.Year(dValue))
Call ApplyFontChanges
End If
End Sub


'###########################
'# Events for Main Object Components
'###########################

Private Sub CBxY_Change()
RenderLabel
Refresh_Panel CBxM.ListIndex + 1, CBxY.ListIndex + 1990
End Sub

Private Sub CBxM_Change()
RenderLabel
Refresh_Panel CBxM.ListIndex + 1, CBxY.ListIndex + 1990
End Sub

Private Sub CmB_Click()
Main.Value = dValue
Call Main.Event_click
End Sub

Private Sub CmB_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Call Main.Event_DblClick
End Sub


Private Sub CmB_KeyDown( _
ByVal KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)

Dim newDate As Date

'38 Up
'37 Left
'39 Right
'40 Down

newDate = dValue

Select Case KeyCode
Case 37
If bPRightToLeft Then
newDate = newDate + 1
Else
newDate = newDate - 1
End If
Case 39
If bPRightToLeft Then
newDate = newDate - 1
Else
newDate = newDate + 1
End If
Case 38
newDate = newDate - 7
Case 40
newDate = newDate + 7
Case 9
End Select

If newDate <> dValue Then
Main.Value = newDate
KeyCode = 0
Else
Call Main.Event_KeyDown(KeyCode, Shift)
End If
End Sub

'pengaturan warna
Private Sub Class_Initialize()
bPShowDays = True
bPShowTitle = True
bPShowDateSelectors = True
dValue = VBA.Date
lPMonth = VBA.Month(VBA.Date)
lPYear = VBA.Year(VBA.Date)
lPDay = VBA.Day(VBA.Date)
lPFontSize = 8
lPMonthLength = 1
lPDayLength = 1
bPYearFirst = False
lPTitleFontColor = &H4000&
lPGridFontColor = &H4000&
lPDayFontColor = &HE0E0E0
lPFirstDay = 1
lPBackColor = &H8000000F&
lPHeaderBackColor = &H4000& '&HFFAA99
lPUseDefaultBackColors = True
lPSaturdayBackColor = &HC0FFC0
lPSundayBackColor = &HC0FFC0 '&H80000002
lPSelectedBackColor = &H80000011&
bPVisible = True
sPHeight = -1
sPWidth = -1
sPTop = -1
sPLeft = -1
sPControlTipText = ""
bPRightToLeft = False
bPSaturdaySelectable = True
bPSundaySelectable = True

Set TitleFont = New MSForms.NewFont
With TitleFont
.Name = "Arial"
.Size = lPFontSize + 4
.Bold = True
End With

Set DayFont = New MSForms.NewFont
With DayFont
.Name = "Arial"
.Size = lPFontSize + 2
.Bold = True
End With

Set GridFont = New MSForms.NewFont
With GridFont
.Name = "Arial"
.Size = lPFontSize
End With

End Sub

Private Sub Class_Terminate()
Erase mDayButtons
Erase mLabelButtons
Set mcMain = Nothing
Set PTitleNewFont = Nothing
Set PDayNewFont = Nothing
Set PGridNewFont = Nothing
Set CBxY = Nothing
Set CBxM = Nothing
Set CmB = Nothing
Set CLb = Nothing
Set CmBl = Nothing
End Sub

'###########################
'# Private Function

Private Function ArraY_Days(ByVal lMonth As Long, ByVal lYear As Long)
Dim v(0 To 41) As Date, i As Long, g As Long, l As Long, p As Long, t As Date

i = VBA.DateTime.Weekday(VBA.DateSerial(lYear, lMonth, 1), 1 + lPFirstDay Mod 7) - 1

If i = 0 Then i = 7

g = VBA.Day(VBA.DateSerial(lYear, lMonth + 1, 0)) + i

p = 1
For l = i To 0 Step -1
v(l) = VBA.DateSerial(lYear, lMonth, p)
p = p - 1
Next

p = 0
For l = i To g
p = p + 1
v(l) = VBA.DateSerial(lYear, lMonth, p)
Next

For l = g To 41
v(l) = VBA.DateSerial(lYear, lMonth, p)
p = p + 1
Next

If bPRightToLeft Then
For l = 0 To 5
For i = 0 To 2
t = v(l * 7 + i)
v(l * 7 + i) = v(l * 7 + (6 - i))
v(l * 7 + (6 - i)) = t
Next
Next
End If

ArraY_Days = v
End Function

Private Sub RenderLabel()
Dim b As Currency, b_ym As Currency, b_combo_m As Long

Const b_combo_y As Long = 42
b_combo_m = IIf(lPMonthLength = mlENShort Or lPMonthLength = mlLocalShort, 42, 66) '66
b_ym = b_combo_y + 2 + b_combo_m

If bInit Then
b = CBxY.Parent.Width
If bPYearFirst Then
CLb.Caption = CBxY.Value & " " & CBxM.Value
Else
CLb.Caption = CBxM.Value & " " & CBxY.Value
End If
CLb.Width = Zero_Negative_Value(IIf(ShowDateSelectors, b - b_ym, b))
CBxM.Width = b_combo_m
CBxY.Left = IIf(ShowTitle, CLb.Width, CCur((b - b_ym) / 2)) + _
IIf(YearFirst, 0, b_combo_m + 2)
CBxM.Left = IIf(ShowTitle, CLb.Width, CCur((b - b_ym) / 2)) + _
IIf(YearFirst, b_combo_y + 2, 0)
End If
End Sub

Private Function bInit() As Boolean
If Not CBxY Is Nothing Then bInit = True
End Function


Private Function SumMonthsToDate(dDate As Date, Optional lMonth As Long = 1) As Date
Dim d As Date

d = VBA.DateSerial( _
VBA.Year(dDate), _
VBA.Month(dDate) + lMonth, _
fMin( _
VBA.Day(dDate), _
VBA.Day( _
VBA.DateSerial( _
VBA.Year(dDate), _
VBA.Month(dDate) + 1 + VBA.Abs(lMonth), _
0))))

If d = VBA.DateSerial(CheckYear(VBA.Year(d)), VBA.Month(d), VBA.Day(d)) Then
SumMonthsToDate = d
Else
SumMonthsToDate = dDate
End If
End Function

Private Function fMin(vFirstValue, ParamArray vValues())
Dim i As Long
fMin = vFirstValue

If IsMissing(vValues) = False Then
For i = 0 To UBound(vValues)
If fMin > vValues(i) Then
fMin = vValues(i)
End If
Next
End If
End Function

Private Function fMonthName(lIndex As Long)
Dim m(11), i As Long, v As Variant
lIndex = lIndex Mod 4
If Int(lIndex / 2) Then
If lIndex Mod 2 Then
v = Array("Jan", "Feb", "Mar", "Apr", "May", _
"Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
Else
v = Array("January", "February", "March", _
"April", "May", "June", "July", "August", _
"September", "October", "November", "December")
End If
fMonthName = v
Else
For i = 0 To 11
m(i) = VBA.Strings.MonthName(i + 1, lIndex Mod 2)
Next
fMonthName = m
End If
End Function


Private Function fWeekdayName(lIndex As Long)
Dim m(6), i As Long, v As Variant
lIndex = lIndex Mod 4
If Int(lIndex / 2) Then
If lIndex Mod 2 Then
v = Array("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun")
Else
v = Array("Monday", "Tuesday", "Wednesday", _
"Thursday", "Friday", "Saturday", "Sunday")
End If
fWeekdayName = v
Else
For i = 0 To 6
m(i) = VBA.Strings.WeekdayName(i + 1, lIndex Mod 2, vbMonday)
Next
fWeekdayName = m
End If
End Function


Private Function CheckYear(ByVal lYear As Long) As Long
Select Case lYear
Case Is < 1990 CheckYear = 1990 Case 1990 To 2030 CheckYear = lYear Case Else CheckYear = 2030 End Select End Function '########################### '# Private Sub Public Sub Event_DblClick() RaiseEvent DblClick End Sub Public Sub Event_click() RaiseEvent Click End Sub Public Sub Event_KeyDown( _ ByVal KeyCode As MSForms.ReturnInteger, _ ByVal Shift As Integer) RaiseEvent KeyDown(KeyCode, Shift) End Sub Private Sub Refresh_Properities() With Me .BackColor = .BackColor .ControlTipText = .ControlTipText .DayFontColor = .DayFontColor .DayLength = .DayLength .GridFontColor = .GridFontColor .MonthLength = .MonthLength If .UseDefaultBackColors = False Then .SaturdayBackColor = .SaturdayBackColor .SundayBackColor = .SundayBackColor .HeaderBackColor = .HeaderBackColor End If .ShowDateSelectors = .ShowDateSelectors .ShowDays = .ShowDays .ShowTitle = .ShowTitle .TabIndex = .TabIndex .TabStop = .TabStop .TitleFontColor = .TitleFontColor .ValueIsNull = .ValueIsNull .YearFirst = .YearFirst End With End Sub Private Sub Refresh_Selected_Day(ByVal dValue As Date) Dim i As Long, c As MSForms.Label For i = 0 To 41 If mDayButtons(i).Value = dValue And Not bPValueIsNull Then On Error Resume Next mDayButtons(i).Obj_Cmb.SetFocus On Error GoTo 0 If Not bPMACFix Then With mDayButtons(i).Obj_CmBl .BackStyle = fmBackStyleOpaque .BackColor = lPSelectedBackColor .ForeColor = cDayFontColorSelected End With Else With mDayButtons(i).Obj_Cmb .BackStyle = fmBackStyleOpaque .BackColor = lPSelectedBackColor .ForeColor = cDayFontColorSelected End With End If lPMonth = VBA.Month(dValue) lPYear = VBA.Year(dValue) lPDay = VBA.Day(dValue) End If Next End Sub Private Sub Refresh_Panel(ByVal lMonth As Long, ByVal lYear As Long) Dim v As Variant, i As Long, l As Long Dim iDay As Long If bInit Then v = ArraY_Days(lMonth, lYear) For i = 0 To 41 mDayButtons(i).Value = v(i) If Not bPMACFix Then 'MAC: no label - command button text '# Normal mode ' Text day label With mDayButtons(i).Obj_CmBlNum If .Caption <> VBA.Day(v(i)) Then
.Caption = VBA.Day(v(i))
End If
If lMonth = VBA.Month(v(i)) Then
If .ForeColor <> GridFontColor Then
.ForeColor = GridFontColor
End If
Else
If .ForeColor <> cDayFontColorInactive Then
.ForeColor = cDayFontColorInactive
End If
End If
End With
' Day background label
With mDayButtons(i).Obj_CmBl
iDay = VBA.DateTime.Weekday(v(i))
If .BackStyle = fmBackStyleOpaque Then
.BackStyle = fmBackStyleTransparent
End If
If UseDefaultBackColors = False Then
If iDay = vbSaturday Then
If .BackColor <> lPSaturdayBackColor Then
.BackColor = lPSaturdayBackColor
End If
If .BackStyle <> fmBackStyleOpaque Then
.BackStyle = fmBackStyleOpaque
End If
ElseIf iDay = vbSunday Then
If .BackColor <> lPSundayBackColor Then
.BackColor = lPSundayBackColor
End If
If .BackStyle <> fmBackStyleOpaque Then
.BackStyle = fmBackStyleOpaque
End If
End If
End If
If Not SaturdaySelectable And iDay = vbSaturday Then
mDayButtons(i).Obj_Cmb.Enabled = False
ElseIf Not SundaySelectable And iDay = vbSunday Then
mDayButtons(i).Obj_Cmb.Enabled = False
Else
mDayButtons(i).Obj_Cmb.Enabled = True
End If
End With
' Button not altered
With mDayButtons(i).Obj_Cmb
If .Caption <> "" Then 'After MACFix
.Caption = ""
End If
If .BackStyle <> fmBackStyleTransparent Then 'Button visible
.BackStyle = fmBackStyleTransparent
End If
End With
Else
'# MAC Fix mode
With mDayButtons(i).Obj_CmBlNum
If .Caption <> "" Then
.Caption = ""
End If
End With
With mDayButtons(i).Obj_CmBl
If .BackStyle = fmBackStyleOpaque Then
.BackStyle = fmBackStyleTransparent
End If
End With
With mDayButtons(i).Obj_Cmb
If .Caption <> VBA.Day(v(i)) Then
.Caption = VBA.Day(v(i))
End If
If lMonth = VBA.Month(v(i)) Then
If .ForeColor <> GridFontColor Then
.ForeColor = GridFontColor
End If
Else
If .ForeColor <> cDayFontColorInactive Then
.ForeColor = cDayFontColorInactive
End If
End If
If .BackStyle <> fmBackStyleOpaque Then 'Button visible
.BackStyle = fmBackStyleOpaque
End If
If UseDefaultBackColors = False Then
iDay = VBA.DateTime.Weekday(v(i))
If iDay = vbSaturday Then
If .BackColor <> lPSaturdayBackColor Then
.BackColor = lPSaturdayBackColor
End If
ElseIf iDay = vbSunday Then
If .BackColor <> lPSundayBackColor Then
.BackColor = lPSundayBackColor
End If
Else
If .BackColor <> BackColor Then
.BackColor = BackColor
End If
End If
Else
If .BackColor <> BackColor Then
.BackColor = BackColor
End If
End If
End With
End If
If CheckValue(v(i)) = False Then
mDayButtons(i).Obj_Cmb.Locked = True
Else
If mDayButtons(i).Obj_Cmb.Locked = True Then
mDayButtons(i).Obj_Cmb.Locked = False
End If
End If
Next

If UseDefaultBackColors = False Then
For l = 0 To 6
If mLabelButtons(l).Obj_CmBl.BackStyle = fmBackStyleTransparent Then
mLabelButtons(l).Obj_CmBl.BackStyle = fmBackStyleOpaque
End If
If mLabelButtons(l).Obj_CmBl.BackColor <> lPHeaderBackColor Then
mLabelButtons(l).Obj_CmBl.BackColor = lPHeaderBackColor
End If
Next
Else
For l = 0 To 6
If mLabelButtons(l).Obj_CmBl.BackStyle = fmBackStyleOpaque Then
mLabelButtons(l).Obj_CmBl.BackStyle = fmBackStyleTransparent
End If
Next
End If

If lMonth = VBA.Month(dValue) And lYear = VBA.Year(dValue) Then
Call Refresh_Selected_Day(dValue)
Else
lPMonth = 0
lPYear = 0
lPDay = 0
End If
End If
End Sub

Private Function CheckValue(d) As Boolean
If VarType(d) = vbDate Then
Select Case d
Case 1462 To 74510
CheckValue = CLng(d) = d
End Select
End If
End Function

Private Function Zero_Negative_Value(sNumber As Single) As Single
If sNumber > 0 Then
Zero_Negative_Value = sNumber
End If
End Function

Selesai silahkan dicoba :)


Download - Kalender VBA

Baca lanjutan Cara membuat Kalender excel (selesai)


Membuat kalender lengkap bagian dua - Kalender merupakan sebuah sistem untuk memberi nama pada sebuah periode waktu (seperti hari atau tanggal sebagai contohnya). Nama-nama ini dikenal sebagai tanggal kalender. Tanggal ini bisa didasarkan dari pergerakan benda angkasa seperti matahari dan bulan. Sedangkan saat ini saya tidak akan membahas tetang cara membuat kalender hijriyah, akan tetapi saya akan membhas tetang cara membuat kalender excel tahun Masehi, karena umumnya orang menggunakan kalender Masehi, next insya Allah kita bahas cara membuat kalender Hijriyah

Pada postingan sebelumnya telah saya paparkan cara membuat kalender excel dengan fungsi formula (Rumus) dan memakai kode Macro yang sangat panjang, untuk kali ini saya akan kembali memberikan tips cara membuat kalender excel dengan VBA tanpa kode macro, kenapa tanpa kode macro ?? karena pada dasarnya Visual basic telah menyediakan fitur kalender, Fitur kalender ini bisa langsung anda akses pada menu toolbox, mau tau cara membuatnya ikuti dan simak baik baik artikel dibawah ini

Membuat kalender lengkap bagian dua

Biar tidak kepanjangan langsung saja buka Microsoft Excel anda, langsung masuk kejendela VBE dengan menekan kombinasi tombol Alt diikuti tombol F11, untuk membuat kalender silahkan insert Userform, panggil toolbox lalu pilih kontrol MontView, perhatikan gambar dibawah ini


Tekan F5 untuk mencoba kalender ini, insya Allah berhasil dan sukses.

Membuat kalender lengkap bagian dua

Ada yang anehkah dengan tutorial ini ?? saya rasa tidak ada namun bagi sebagian anda pasti bertanya tanya karena anda tidak menemukan kontrol MontView pada toolbox, jika masalah anda ini caranya cukup mudah, tinggal tambahkan kontrol montView pada toolbox , caranya :
Pada area Toolbox klik kanan pada mouse anda untuk menampilkan opsi
Pada menu opsi pilih Additional Controls
Pada jendela box Additional Controls scrol kebawah cari tulisan Microsoft MonthView Control, Version 6.0", letaknya dibawah "Microsoft ListView Control Version 6.0
Ceklis "Microsoft MonthView Control, Version 6.0", lalu klik OK
Selesai kontrol "Microsoft MonthView Control, Version 6.0" telah tersedia dalam ToolBox


Membuat kalender lengkap bagian dua

Setelah anda berhasil membuat kalender dengan Montview anda akan melihat bahwa kalender ini bisa digunakan seumur hidup anda, namun bagaimana cara menggunakan aklender ini?? maksudnya masa iya kalender ini hanya untuk pajangan ??

Nah untuk menggunakan kalender ini sebagai input, caranya cukup tambahkan kode macro ini kedalam userform

Private Sub MonthView1_DateClick(ByVal DateClicked As Date)
On Error Resume Next
Dim cell As Object
For Each cell In Selection.Cells
cell.Value = DateClicked
Next cell
Unload Me
End Sub

Setiap sel yang terpilih akan terinput tanggal pada kalender yang anda klik.

Untuk memanggil kalender agar tampil dalam sheet, ada cara menarik yaitu dengan menambahkan menu ke klik kanan, silahkan baca cara selengkapnya disini "Cara menambahkan menu klik kanana pada Excel"

Download - Sampel cara membuat kalender

Demikianlah rangkaian cara membuat kalender, semoga artikel atau postingan ini bermanfaat bagi saya anda dan kita semua yang membutuhkanya. Salam dan selamat berakhir pekan.
1 comment
candle light

pak.. password rar nya apa ya ??

Reply