📄 frmcalendar.frm
字号:
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "9"
ForeColor = &H80000008&
Height = 285
Index = 8
Left = 720
TabIndex = 12
Top = 1320
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "8"
ForeColor = &H80000008&
Height = 285
Index = 7
Left = 360
TabIndex = 11
Top = 1320
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "7"
ForeColor = &H80000008&
Height = 285
Index = 6
Left = 2520
TabIndex = 10
Top = 960
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "6"
ForeColor = &H80000008&
Height = 285
Index = 5
Left = 2160
TabIndex = 9
Top = 960
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "5"
ForeColor = &H80000008&
Height = 285
Index = 4
Left = 1800
TabIndex = 8
Top = 960
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "4"
ForeColor = &H80000008&
Height = 285
Index = 3
Left = 1440
TabIndex = 7
Top = 960
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "3"
ForeColor = &H80000008&
Height = 285
Index = 2
Left = 1080
TabIndex = 6
Top = 960
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "2"
ForeColor = &H80000008&
Height = 285
Index = 1
Left = 720
TabIndex = 5
Top = 960
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "1"
ForeColor = &H80000008&
Height = 285
Index = 0
Left = 360
TabIndex = 4
Top = 960
Width = 300
End
Begin VB.Shape Shape1
Height = 2055
Left = 240
Top = 840
Width = 2775
End
Begin VB.Label Label1
Appearance = 0 'Flat
BackColor = &H80000000&
BackStyle = 0 'Transparent
Caption = "月份&M"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 255
Index = 0
Left = 240
TabIndex = 1
Top = 120
Width = 615
End
Begin VB.Label Label1
Appearance = 0 'Flat
BackColor = &H80000000&
BackStyle = 0 'Transparent
Caption = "年份&Y"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 255
Index = 1
Left = 1800
TabIndex = 0
Top = 120
Width = 735
End
End
Attribute VB_Name = "frmcalendar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*****************************************
' 系统电子日历
'程序功能：显示当前日期，星期
'*****************************************
Private selectedate%
Private Sub cbomonth_click()
Call setday
Call lblnumber_click(selectedate% - 1)
End Sub
Private Sub cboyear_Click()
Static once% ' 改变年度
If Not once Then
once = True
Exit Sub
End If
Call cbomonth_click
End Sub
Private 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
Private Sub cmdOK_Click()
Unload frmcalendar
End Sub
Private Function determinemonth%()
Dim i%
i% = cbomonth.ListIndex '选择的月份
determinemonth% = i% + 1
End Function
Private Function determineyear%()
Dim i%
i% = cboyear.ListIndex '选择的年度
If i% = -1 Then Exit Function
determineyear% = CInt(Trim(cboyear.List(i%)))
End Function
Private 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
Private Sub fillcbomonth()
cbomonth.AddItem "一月"
cbomonth.AddItem "二月"
cbomonth.AddItem "三月"
cbomonth.AddItem "四月"
cbomonth.AddItem "五月"
cbomonth.AddItem "六月"
cbomonth.AddItem "七月"
cbomonth.AddItem "八月"
cbomonth.AddItem "九月"
cbomonth.AddItem "十月"
cbomonth.AddItem "十一月"
cbomonth.AddItem "十二月"
End Sub
Private Sub fillcboyear()
Dim i%
For i% = 1960 To 2060 '填充年度
cboyear.AddItem Str$(i%)
Next i%
End Sub
Private Sub Form_Load()
selectedate% = CInt(Format$(Now, "dd"))
'填充月份下拉框
Call fillcbomonth
'填充年份下拉框
Call fillcboyear
'设置当前时间
Dim month1%, day1%, year1%, date1$
day1% = selectedate%
month1% = cbomonth.ListIndex + 1
year1% = cboyear.ListIndex + 1960
date1$ = (Str$(month1%) + "/" + Str$(day1%) + "/" + Str$(year1%))
lbldate.Caption = Format$(date1$, "long date")
Call setdate
'显示当前是星期几
Dim caption1$
Dim r As Integer
r = Weekday(Date)
If r = 1 Then
caption1$ = "星期天"
ElseIf r = 2 Then
caption1 = "星期一"
ElseIf r = 3 Then
caption1 = "星期二"
ElseIf r = 4 Then
caption1 = "星期三"
ElseIf r = 5 Then
caption1 = "星期四"
ElseIf r = 6 Then
caption1 = "星期五"
Else
caption1 = "星期六"
End If
lblday.Caption = caption1$
Call lblnumber_click(selectedate% - 1)
End Sub
Private 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%))
Dim r%
Dim caption1$
r% = Weekday(date1$)
If r% = 1 Then
caption1$ = "星期天"
ElseIf r% = 2 Then
caption1 = "星期一"
ElseIf r% = 3 Then
caption1 = "星期二"
ElseIf r% = 4 Then
caption1 = "星期三"
ElseIf r% = 5 Then
caption1 = "星期四"
ElseIf r% = 6 Then
caption1 = "星期五"
Else
caption1 = "星期六"
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
Private Sub setdate()
'年份
Dim r%, i%
r% = CInt(Format$(Now, "yyyy"))
i% = r% - 1960
cboyear.ListIndex = i%
'月份
r% = CInt(Format$(Now, "mm"))
cbomonth.ListIndex = (r% - 1)
'日期
r% = CInt(Format$(Now, "dd"))
lblnumber(r% - 1).BorderStyle = 1
selectedate% = r%
End Sub
Private Sub setday()
Dim month1%, year1%
month1% = determinemonth()
year1% = determineyear()
Call checkdate(month1%, year1%)
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -