Calendar routines
Submitted By:
Unknown
Rating:
(Not rated) (
Rate It)
VERSION 2.00
Begin Form frmcalendar
BorderStyle = 1 'Fixed Single
Caption = "Calendar"
ClientHeight = 2865
ClientLeft = 930
ClientTop = 1485
ClientWidth = 4290
ControlBox = 0 'False
Height = 3270
Icon = FORM1.FRX:0000
Left = 870
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 2865
ScaleWidth = 4290
Top = 1140
Width = 4410
Begin ComboBox cboyear
Height = 300
Left = 2880
Style = 2 'Dropdown List
TabIndex = 3
Top = 360
Width = 1215
End
Begin ComboBox cbomonth
Height = 300
Left = 120
Style = 2 'Dropdown List
TabIndex = 1
Top = 360
Width = 2415
End
Begin CommandButton cmdcancel
Cancel = -1 'True
Caption = "&Cancel"
Height = 345
Left = 3000
TabIndex = 5
Top = 2400
Width = 1215
End
Begin CommandButton cmdok
Caption = "&OK"
Default = -1 'True
Height = 345
Left = 3000
TabIndex = 4
Top = 1965
Width = 1215
End
Begin Label lbldate
Alignment = 2 'Center
ForeColor = &H00000080&
Height = 615
Left = 2880
TabIndex = 38
Top = 1200
Width = 1215
End
Begin Label lblday
Alignment = 2 'Center
ForeColor = &H00000080&
Height = 255
Left = 2880
TabIndex = 37
Top = 1000
Width = 1215
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "29"
Height = 285
Index = 28
Left = 240
TabIndex = 7
Top = 2400
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "30"
Height = 285
Index = 29
Left = 600
TabIndex = 8
Top = 2400
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "31"
Height = 285
Index = 30
Left = 960
TabIndex = 9
Top = 2400
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "16"
Height = 285
Index = 15
Left = 600
TabIndex = 10
Top = 1680
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "17"
Height = 285
Index = 16
Left = 960
TabIndex = 11
Top = 1680
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "18"
Height = 285
Index = 17
Left = 1320
TabIndex = 12
Top = 1680
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "19"
Height = 285
Index = 18
Left = 1680
TabIndex = 13
Top = 1680
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "20"
Height = 285
Index = 19
Left = 2040
TabIndex = 36
Top = 1680
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "21"
Height = 285
Index = 20
Left = 2400
TabIndex = 35
Top = 1680
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "15"
Height = 285
Index = 14
Left = 240
TabIndex = 34
Top = 1680
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "23"
Height = 285
Index = 22
Left = 600
TabIndex = 33
Top = 2040
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "24"
Height = 285
Index = 23
Left = 960
TabIndex = 32
Top = 2040
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "25"
Height = 285
Index = 24
Left = 1320
TabIndex = 31
Top = 2040
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "26"
Height = 285
Index = 25
Left = 1680
TabIndex = 30
Top = 2040
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "27"
Height = 285
Index = 26
Left = 2040
TabIndex = 29
Top = 2040
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "28"
Height = 285
Index = 27
Left = 2400
TabIndex = 28
Top = 2040
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "22"
Height = 285
Index = 21
Left = 240
TabIndex = 27
Top = 2040
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "9"
Height = 285
Index = 8
Left = 600
TabIndex = 26
Top = 1320
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "10"
Height = 285
Index = 9
Left = 960
TabIndex = 25
Top = 1320
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "11"
Height = 285
Index = 10
Left = 1320
TabIndex = 24
Top = 1320
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "12"
Height = 285
Index = 11
Left = 1680
TabIndex = 23
Top = 1320
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "13"
Height = 285
Index = 12
Left = 2040
TabIndex = 22
Top = 1320
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "14"
Height = 285
Index = 13
Left = 2400
TabIndex = 21
Top = 1320
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "8"
Height = 285
Index = 7
Left = 240
TabIndex = 20
Top = 1320
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "2"
Height = 285
Index = 1
Left = 600
TabIndex = 19
Top = 960
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "3"
Height = 285
Index = 2
Left = 960
TabIndex = 18
Top = 960
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "4"
Height = 285
Index = 3
Left = 1320
TabIndex = 17
Top = 960
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "5"
Height = 285
Index = 4
Left = 1680
TabIndex = 16
Top = 960
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "6"
Height = 285
Index = 5
Left = 2040
TabIndex = 15
Top = 960
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "7"
Height = 285
Index = 6
Left = 2400
TabIndex = 14
Top = 960
Width = 300
End
Begin Label lblnumber
Alignment = 2 'Center
Caption = "1"
Height = 285
Index = 0
Left = 240
TabIndex = 6
Top = 960
Width = 300
End
Begin Shape Shape1
Height = 1935
Left = 120
Top = 840
Width = 2655
End
Begin Label Label1
Caption = "&Year"
Height = 255
Index = 1
Left = 2880
TabIndex = 2
Top = 120
Width = 495
End
Begin Label Label1
Caption = "&Month"
Height = 255
Index = 0
Left = 120
TabIndex = 0
Top = 120
Width = 615
End
End
'This code has been developed for EVERYONE'S use
' don't re-distribute this without ALL original files!!
'Phil Jones 1994
Option Explicit
Dim selectedate%
Sub cbomonth_click ()
Call setday
Call lblnumber_click(selectedate% - 1)
End Sub
Sub cboyear_Click ()
Static once% ' get rid of first click event
If Not once Then
once = True
Exit Sub
End If
Call cbomonth_click
End Sub
Sub checkdate (month1%, year1%)
Dim i%, value%, date1$
For i% = 28 To 32
date1$ = (Str$(month1%) + "/" + Str$(i%) + "/" + Str$(year1%))
If IsDate(date1$) Then
value% = i%
Else
Call displaynumbers(value%)
Exit Sub
End If
Next i%
End Sub
Sub cmdcancel_Click ()
Unload frmcalendar
End Sub
Sub cmdok_Click ()
Dim month1%, day1%, year1%, date1$
day1% = selectedate%
month1% = cbomonth.ListIndex + 1
year1% = cboyear.ListIndex + 1960
date1$ = (Str$(month1%) + "/" + Str$(day1%) + "/" + Str$(year1%))
date1$ = Format$(date1$, "general date")
MsgBox Format$(date1$, "long date") 'do whatever here to pass the date where
'you need it!
End Sub
Function determinemonth% ()
Dim i%
i% = cbomonth.ListIndex'which month is selected?
determinemonth% = i% + 1
End Function
Function determineyear% ()
Dim i%
i% = cboyear.ListIndex'which year was selected?
If i% = -1 Then Exit Function'problem!!
determineyear% = CInt(Trim(cboyear.List(i%)))
End Function
Sub displaynumbers (number%)
Dim i%
For i% = 28 To 30
lblnumber(i%).Visible = False
Next i%
For i% = 28 To number% - 1
lblnumber(i%).Visible = True
Next i%
End Sub
Sub fillcbomonth ()
cbomonth.AddItem "January"
cbomonth.AddItem "February"
cbomonth.AddItem "March"
cbomonth.AddItem "April"
cbomonth.AddItem "May"
cbomonth.AddItem "June"
cbomonth.AddItem "July"
cbomonth.AddItem "August"
cbomonth.AddItem "September"
cbomonth.AddItem "October"
cbomonth.AddItem "November"
cbomonth.AddItem "December"
End Sub
Sub fillcboyear ()
Dim i%
For i% = 1960 To 2060'put whatever years tyou want here,
cboyear.AddItem Str$(i%)'but don't forget to also change the code in setdate
Next i%
End Sub
Sub Form_Load ()
selectedate% = CInt(Format$(Now, "dd"))
'fill month combo box
Call fillcbomonth
'fill year combo box
Call fillcboyear
'put current date and year im combo box
Call setdate
'set current name for day
Dim r%, caption1$
r% = Weekday(Format$(Now, "general date"))
If r% = 1 Then
caption1$ = "Sunday"
ElseIf r% = 2 Then
caption1 = "Monday"
ElseIf r% = 3 Then
caption1 = "Tuesday"
ElseIf r% = 4 Then
caption1 = "Wednesday"
ElseIf r% = 5 Then
caption1 = "Thursday"
ElseIf r% = 6 Then
caption1 = "Friday"
Else
caption1 = "Saturday"
End If
lblday.Caption = caption1$
End Sub
Sub lblnumber_click (Index As Integer)
Dim i%
On Error GoTo err1
For i% = 0 To 30
lblnumber(i%).BorderStyle = 0
Next i%
If lblnumber(Index).BorderStyle = 1 Then
lblnumber(Index).BorderStyle = 0
Else
lblnumber(Index).BorderStyle = 1
End If
selectedate% = Index + 1
Dim month1%, day1%, year1%, date1$
day1% = selectedate%
month1% = cbomonth.ListIndex + 1
year1% = cboyear.ListIndex + 1960
date1$ = (Str$(month1%) + "/" + Str$(day1%) + "/" + Str$(year1%))
'date1$ = Format$(date1$, "general date")
Dim r%
Dim caption1$
r% = Weekday(date1$)
If r% = 1 Then
caption1$ = "Sunday"
ElseIf r% = 2 Then
caption1 = "Monday"
ElseIf r% = 3 Then
caption1 = "Tuesday"
ElseIf r% = 4 Then
caption1 = "Wednesday"
ElseIf r% = 5 Then
caption1 = "Thursday"
ElseIf r% = 6 Then
caption1 = "Friday"
Else
caption1 = "Saturday"
End If
lblday.Caption = caption1$
lbldate.Caption = Format$(date1$, "long date")
err1:
If Err = 0 Then Exit Sub
If Err = 13 Then
selectedate% = selectedate% - 1
Exit Sub
End If
End Sub
Sub setdate ()
'since the list starts at 1960, this is 0, so we're going
' to get the date, and subtract 1960 from it, and use this
'as our starting listindex
'put whatever value you need to for the first year
'year
Dim r%, i%
r% = CInt(Format$(Now, "yyyy"))
i% = r% - 1960
cboyear.ListIndex = i%
'month
r% = CInt(Format$(Now, "mm"))
cbomonth.ListIndex = (r% - 1)
'day
r% = CInt(Format$(Now, "dd"))
lblnumber(r% - 1).BorderStyle = 1
selectedate% = r%
End Sub
Sub setday ()
Dim month1%, year1%
month1% = determinemonth()
year1% = determineyear()
Call checkdate(month1%, year1%)
End Sub
