Kalender dengan vb 6.0

Code “Form”

Option Explicit
Const MaxYear = 2101, MinYear = 1899
Dim calDate As Date
Dim SuspendFlag As Boolean
Dim FocusedDate As String
Dim StartLabelPos As Integer

Private Sub Form_Load()
SuspendFlag = True

Dim i As Integer
For i = 0 To (MaxYear – MinYear)
YearList.List(i) = (i + MinYear)
YearList.ItemData(i) = (i + MinYear)
Next
For i = 0 To (11)
MonthList.List(i) = (i + 1)
MonthList.ItemData(i) = (i + 1)
Next

calDate = Format(Now, “m/d/yyyy”)

MonthList.Text = Month(calDate)
YearList.Text = Year(calDate)
SuspendFlag = False

Me.MonthYearLabel = MonthName(Month(calDate)) & ” ” & Str(Year(calDate))
DisplayCalendar
‘ Initially make today’s date as the selected date
For i = 0 To 41
If dateLabel(i).BackColor = &HC0E0FF Then
FocusedDate = dateLabel(i).Caption
ShowFocusedDate (FocusedDate)
Exit For
End If
Next i
End Sub

Private Sub Form_Activate()
DispOrigAuthor Me
End Sub

Private Sub DisplayCalendar()
Dim nmonth As Integer
Dim nLastDay As Integer
Dim nmodRemainder As Integer

nmonth = Month(calDate)

If nmonth = 4 Or nmonth = 6 Or nmonth = 9 Or nmonth = 11 Then
nLastDay = 30
ElseIf nmonth = 2 Then
nmodRemainder = Year(calDate) Mod 4
If nmodRemainder = 0 Then
nmodRemainder = Year(calDate) Mod 100
If nmodRemainder = 0 Then
nmodRemainder = Year(calDate) Mod 400
If nmodRemainder = 0 Then
nLastDay = 29                ‘ Leap year
Else
nLastDay = 28
End If
Else
nLastDay = 29
End If
Else
nLastDay = 28
End If
Else
nLastDay = 31
End If

Dim n As Integer, nDay As Integer, nWeekday As Integer
Dim cDay As String
Dim firstMonthYear As Date

firstMonthYear = CDate(Str(Month(calDate)) & “/01/” _
& Str(Year(calDate)))

StartLabelPos = Weekday(firstMonthYear)
nWeekday = StartLabelPos
If StartLabelPos > 1 Then
For n = 1 To (nWeekday – 1)
dateLabel(n – 1).Visible = False
Next
End If
‘ Draw dates of the month
nDay = 1
For n = nWeekday To 45
If nDay <= nLastDay Then
cDay = Str(nDay)
If Len(cDay) < 2 Then
cDay = ” ” & cDay
End If
dateLabel(n – 1).BackColor = &H80000016
If Val(cDay) < 10 Then
cDay = ” ” & cDay
End If
dateLabel(n – 1).Caption = cDay
dateLabel(n – 1).Visible = True
Else
dateLabel(n – 1).Visible = False
End If
nDay = nDay + 1
If n > 41 Then
Exit For
End If
Next
HighlightToday
End Sub

Private Sub HighlightToday()
Dim n As Integer
‘Marks “today” label in diff color
If Month(calDate) = Month(Date) And _
Year(calDate) = Year(Date) Then
n = Day(Date)
dateLabel(n + StartLabelPos – 2).BackColor = &HC0E0FF
End If
End Sub

Private Sub ShowFocusedDate(FocusedDate As String)
Dim i As Integer
For i = 0 To 41
If dateLabel(i).Visible = True Then
If dateLabel(i).Caption = FocusedDate Then
dateLabel(i).BorderStyle = 1
Else
dateLabel(i).BorderStyle = 0
End If
End If
Next
End Sub

Private Sub Datelabel_Click(Index As Integer)
FocusedDate = dateLabel(Index).Caption
ShowFocusedDate (FocusedDate)
End Sub

Private Sub Form_Unload(Cancel As Integer)
Unload frmCalendar
End Sub

Private Sub MonthDn_Click()
If MonthList.Text > 1 Then
MonthList.Text = MonthList.Text – 1
Else
If YearList.Text <> MinYear Then
MonthList.Text = 12
YearList.Text = YearList.Text – 1
End If
End If
MonthList.SetFocus
End Sub

Public Sub MonthUp_Click()
If MonthList.Text < 12 Then
MonthList.Text = MonthList.Text + 1
Else
If YearList.Text <> MaxYear Then
MonthList.Text = 1
YearList.Text = YearList.Text + 1
End If
End If
MonthList.SetFocus
End Sub

Private Sub YearDn_Click()
If YearList.Text <> MinYear Then
YearList.Text = YearList.Text – 1
End If
YearList.SetFocus
End Sub

Private Sub YearUp_Click()
If YearList.Text <> MaxYear Then
YearList.Text = YearList.Text + 1
End If
YearList.SetFocus
End Sub

Private Sub MonthList_Click()
If SuspendFlag = True Then
Exit Sub
End If
Dim cNewMonth As String
Dim cNewYear As String
Dim cDay As String
Dim cNewCalDate As String

cNewMonth = Me.MonthList.Text
If Len(cNewMonth) < 2 Then
cNewMonth = “0” & cNewMonth
End If

cNewYear = Me.YearList.Text
cDay = Str(Day(Date))           ‘ Just use system date

cNewCalDate = cNewMonth & “/” & cDay & “/” & cNewYear
calDate = CDate(cNewCalDate)

Me.MonthYearLabel = MonthName(Month(calDate)) & ” ” & Str(Year(calDate))
DisplayCalendar

ShowFocusedDate (FocusedDate)
End Sub

Private Sub YearList_Click()
MonthList_Click
End Sub

Code “Modul”

Option Explicit

Declare Function CreateFontIndirect Lib “gdi32” Alias _
“CreateFontIndirectA” (lpLogFont As LOGFONT) As Long

Type LOGFONT
lfHeight As Long                           ‘ Known as em height, in logical units
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 33                  ‘ L_FACESIZE
End Type

Declare Function SelectObject Lib “gdi32” (ByVal hdc As Long, _
ByVal hObject As Long) As Long
Declare Function DeleteObject Lib “gdi32” (ByVal hObject As Long) As Long

‘ In order for Windows NT to work
Declare Function SetGraphicsMode Lib “gdi32” (ByVal hdc As Long, ByVal iMode As Long) As Long
Const GM_ADVANCED = 2

Sub DispOrigAuthor(inObj As Object)
On Error Resume Next
Dim L As LOGFONT
Dim mFont As Long
Dim mPrevFont As Long
Dim i As Integer
Dim origMode As Integer
Dim x As Single, y As Single
Dim tmpX As Single, tmpY As Single
Dim mresult
‘ For Windows NT to work
mresult = SetGraphicsMode(inObj.hdc, GM_ADVANCED)
origMode = inObj.ScaleMode
inObj.ScaleMode = vbPixels

L.lfFaceName = “Areial” & Chr$(0)
‘ L.lfEscapement = 90 * 10
L.lfEscapement = 0
L.lfHeight = 6 * -20 / Screen.TwipsPerPixelY

mFont = CreateFontIndirect(L)
mPrevFont = SelectObject(inObj.hdc, mFont)

x = inObj.ScaleLeft + 6
y = inObj.ScaleHeight – 13
inObj.CurrentX = x
inObj.CurrentY = y
tmpX = x
tmpY = y

inObj.ForeColor = &H808080
tmpX = tmpX + 1: tmpY = tmpY + 1
inObj.CurrentX = tmpX
inObj.CurrentY = tmpY
inObj.Print “By Herman Liu”

inObj.CurrentX = x
inObj.CurrentY = y
tmpX = x
tmpY = y
inObj.ForeColor = vbWhite
tmpX = tmpX – 1: tmpY = tmpY – 1
inObj.CurrentX = tmpX
inObj.CurrentY = tmpY
inObj.Print “By Herman Liu”

inObj.CurrentX = x
inObj.CurrentY = y
inObj.ForeColor = vbBlack
inObj.Print “By Herman Liu”

mresult = SelectObject(inObj.hdc, mPrevFont)
mresult = DeleteObject(mFont)
inObj.ScaleMode = origMode
End Sub

Posted in: Program VB 6.0 & VB.NET 2008