form1.frm

简单的小日历

'小月显示的天数,先判断的一天是星期几,再在相应的星期中显示第一天
Sub YueFenXiaoYue()

NowDate = ComYear.Text & "-" & ComMonth.Text & "-1"
NowWeekDay = Weekday(NowDate)

Select Case NowWeekDay

Case vbSunday
For DayNow = 0 To 29
    Call SundayNow
Next DayNow

Case vbMonday
For DayNow = 1 To 30
    Call MondayNow
Next DayNow

Case vbTuesday
For DayNow = 2 To 31
    Call TuesdayNow
Next DayNow

Case vbWednesday
For DayNow = 3 To 32
    Call WednesdayNow
Next DayNow

Case vbThursday
For DayNow = 4 To 33
    Call ThursdayNow
Next DayNow

Case vbFriday
For DayNow = 5 To 34
    Call FridayNow
Next DayNow

Case vbSaturday
For DayNow = 6 To 35
    Call SaturdayNow
Next DayNow

End Select

End Sub

'二月显示的天数,先判断的一天是星期几,再在相应的星期中显示第一天
Sub YueFenErYue()

NowDate = ComYear.Text & "-" & ComMonth.Text & "-1"
NowWeekDay = Weekday(NowDate)

Select Case NowWeekDay

Case vbSunday
For DayNow = 0 To 27
    Call SundayNow
Next DayNow

Case vbMonday
For DayNow = 1 To 28
    Call MondayNow
Next DayNow

Case vbTuesday
For DayNow = 2 To 29
    Call TuesdayNow
Next DayNow

Case vbWednesday
For DayNow = 3 To 30
    Call WednesdayNow
Next DayNow

Case vbThursday
For DayNow = 4 To 31
    Call ThursdayNow
Next DayNow

Case vbFriday
For DayNow = 5 To 32
    Call FridayNow
Next DayNow

Case vbSaturday
For DayNow = 6 To 33
    Call SaturdayNow
Next DayNow

End Select

End Sub

'润二月显示的天数,先判断的一天是星期几,再在相应的星期中显示第一天
Sub YueFenRunErYue()

NowDate = ComYear.Text & "-" & ComMonth.Text & "-1"
NowWeekDay = Weekday(NowDate)

Select Case NowWeekDay

Case vbSunday
For DayNow = 0 To 28
    Call SundayNow
Next DayNow

Case vbMonday
For DayNow = 1 To 29
    Call MondayNow
Next DayNow

Case vbTuesday
For DayNow = 2 To 30
    Call TuesdayNow
Next DayNow

Case vbWednesday
For DayNow = 3 To 31
    Call WednesdayNow
Next DayNow

Case vbThursday
For DayNow = 4 To 32
    Call ThursdayNow
Next DayNow

Case vbFriday
For DayNow = 5 To 33
    Call FridayNow
Next DayNow

Case vbSaturday
For DayNow = 6 To 34
    Call SaturdayNow
Next DayNow

End Select

End Sub

'检查月份,以便于显示相应的天数
Sub JianChaYueFen()

Select Case ComMonth.Text
    '如果月份列表显示以下数字,为大月
    Case 1, 3, 5, 7, 8, 10, 12
        DaYue = True
        Call YueFenDaYue
    '如果月份列表显示以下数字,为小月
    Case 4, 6, 9, 11
        XiaoYue = True
        Call YueFenXiaoYue
    '如果月份列表显示以下数字,为二月
    Case 2
        ErYue = True
            '判断是否是润月
            If (ComYear.Text Mod 400 = 0) Or (ComYear.Text Mod 4 = 0 And ComYear.Text Mod 100 <> 0) Then
                RunErYue = True
                Call YueFenRunErYue
            Else
                Call YueFenErYue
            End If
End Select

End Sub

'星期日
Sub SundayNow()
LblDay(DayNow).Caption = DayNow + 1
ChinaDate.DateNow = CDate(ComYear.Text & "-" & ComMonth.Text & "-" & LblDay(DayNow).Caption)
ChineseDate = ChinaDate.ChineseDate
ChineseSolarTerm = ChinaDate.ChineseSolarTerm
If ChineseSolarTerm <> "" Then
LblDay(DayNow).BackStyle = 1
LblDay(DayNow).BackColor = RGB(100, 200, 10)
LblDay(DayNow).Caption = vbCrLf & DayNow + 1 & "号" & vbCrLf & ChineseDate & vbCrLf & ChineseSolarTerm
Else: LblDay(DayNow).Caption = vbCrLf & DayNow + 1 & "号" & vbCrLf & vbCrLf & ChineseDate
End If
ComDay.AddItem DayNow + 1
LblDay(ComDay.Text - 1).BackStyle = 1
LblDay(ComDay.Text - 1).BackColor = RGB(255, 150, 255)
End Sub

'星期一
Sub MondayNow()
LblDay(DayNow).Caption = DayNow
ChinaDate.DateNow = CDate(ComYear.Text & "-" & ComMonth.Text & "-" & LblDay(DayNow).Caption)
ChineseDate = ChinaDate.ChineseDate
ChineseSolarTerm = ChinaDate.ChineseSolarTerm
If ChineseSolarTerm <> "" Then
LblDay(DayNow).BackStyle = 1
LblDay(DayNow).BackColor = RGB(100, 200, 10)
LblDay(DayNow).Caption = vbCrLf & DayNow & "号" & vbCrLf & ChineseDate & vbCrLf & ChineseSolarTerm
Else: LblDay(DayNow).Caption = vbCrLf & DayNow & "号" & vbCrLf & vbCrLf & ChineseDate
End If
ComDay.AddItem DayNow
LblDay(ComDay.Text).BackStyle = 1
LblDay(ComDay.Text).BackColor = RGB(255, 150, 255)
End Sub

'星期二
Sub TuesdayNow()
LblDay(DayNow).Caption = DayNow - 1
ChinaDate.DateNow = CDate(ComYear.Text & "-" & ComMonth.Text & "-" & LblDay(DayNow).Caption)
ChineseDate = ChinaDate.ChineseDate
ChineseSolarTerm = ChinaDate.ChineseSolarTerm
If ChineseSolarTerm <> "" Then
LblDay(DayNow).BackStyle = 1
LblDay(DayNow).BackColor = RGB(100, 200, 10)
LblDay(DayNow).Caption = vbCrLf & DayNow - 1 & "号" & vbCrLf & ChineseDate & vbCrLf & ChineseSolarTerm
Else: LblDay(DayNow).Caption = vbCrLf & DayNow - 1 & "号" & vbCrLf & vbCrLf & ChineseDate
End If
ComDay.AddItem DayNow - 1
LblDay(ComDay.Text + 1).BackStyle = 1
LblDay(ComDay.Text + 1).BackColor = RGB(255, 150, 255)
End Sub

'星期三
Sub WednesdayNow()
LblDay(DayNow).Caption = DayNow - 2
ChinaDate.DateNow = CDate(ComYear.Text & "-" & ComMonth.Text & "-" & LblDay(DayNow).Caption)
ChineseDate = ChinaDate.ChineseDate
ChineseSolarTerm = ChinaDate.ChineseSolarTerm
If ChineseSolarTerm <> "" Then
LblDay(DayNow).BackStyle = 1
LblDay(DayNow).BackColor = RGB(100, 200, 10)
LblDay(DayNow).Caption = vbCrLf & DayNow - 2 & "号" & vbCrLf & ChineseDate & vbCrLf & ChineseSolarTerm
Else: LblDay(DayNow).Caption = vbCrLf & DayNow - 2 & "号" & vbCrLf & vbCrLf & ChineseDate
End If
ComDay.AddItem DayNow - 2
LblDay(ComDay.Text + 2).BackStyle = 1
LblDay(ComDay.Text + 2).BackColor = RGB(255, 150, 255)
End Sub

'星期四
Sub ThursdayNow()
LblDay(DayNow).Caption = DayNow - 3
ChinaDate.DateNow = CDate(ComYear.Text & "-" & ComMonth.Text & "-" & LblDay(DayNow).Caption)
ChineseDate = ChinaDate.ChineseDate
ChineseSolarTerm = ChinaDate.ChineseSolarTerm
If ChineseSolarTerm <> "" Then
LblDay(DayNow).BackStyle = 1
LblDay(DayNow).BackColor = RGB(100, 200, 10)
LblDay(DayNow).Caption = vbCrLf & DayNow - 3 & "号" & vbCrLf & ChineseDate & vbCrLf & ChineseSolarTerm
Else: LblDay(DayNow).Caption = vbCrLf & DayNow - 3 & "号" & vbCrLf & vbCrLf & ChineseDate
End If
ComDay.AddItem DayNow - 3
LblDay(ComDay.Text + 3).BackStyle = 1
LblDay(ComDay.Text + 3).BackColor = RGB(255, 150, 255)
End Sub

'星期五
Sub FridayNow()
LblDay(DayNow).Caption = DayNow - 4
ChinaDate.DateNow = CDate(ComYear.Text & "-" & ComMonth.Text & "-" & LblDay(DayNow).Caption)
ChineseDate = ChinaDate.ChineseDate
ChineseSolarTerm = ChinaDate.ChineseSolarTerm
If ChineseSolarTerm <> "" Then
LblDay(DayNow).BackStyle = 1
LblDay(DayNow).BackColor = RGB(100, 200, 10)
LblDay(DayNow).Caption = vbCrLf & DayNow - 4 & "号" & vbCrLf & ChineseDate & vbCrLf & ChineseSolarTerm
Else: LblDay(DayNow).Caption = vbCrLf & DayNow - 4 & "号" & vbCrLf & vbCrLf & ChineseDate
End If
ComDay.AddItem DayNow - 4
LblDay(ComDay.Text + 4).BackStyle = 1
LblDay(ComDay.Text + 4).BackColor = RGB(255, 150, 255)
End Sub

'星期六
Sub SaturdayNow()
LblDay(DayNow).Caption = DayNow - 5
ChinaDate.DateNow = CDate(ComYear.Text & "-" & ComMonth.Text & "-" & LblDay(DayNow).Caption)
ChineseDate = ChinaDate.ChineseDate
ChineseSolarTerm = ChinaDate.ChineseSolarTerm
If ChineseSolarTerm <> "" Then
LblDay(DayNow).BackStyle = 1
LblDay(DayNow).BackColor = RGB(100, 200, 10)
LblDay(DayNow).Caption = vbCrLf & DayNow - 5 & "号" & vbCrLf & ChineseDate & vbCrLf & ChineseSolarTerm
Else: LblDay(DayNow).Caption = vbCrLf & DayNow - 5 & "号" & vbCrLf & vbCrLf & ChineseDate
End If
ComDay.AddItem DayNow - 5
LblDay(ComDay.Text + 5).BackStyle = 1
LblDay(ComDay.Text + 5).BackColor = RGB(255, 150, 255)
End Sub

'鼠标点击日期按钮后,改边颜色,(注意:如果日期标签为空,不做任何操作)
Private Sub LblDay_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)

If LblDay(Index) = "" Then

GoTo Err:

ElseIf LblDay(Index).BackStyle = 1 Then

GoTo Err:

Else
LblDay(Index).BackStyle = 1
LblDay(Index).BackColor = RGB(100, 100, 255)
End If

Err:

End Sub

'鼠标抬起后,颜色变回,并显示相应的国、农历时间,(注意:如果日期标签为空,不做任何操作)
Private Sub LblDay_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)

If LblDay(Index) = "" Then
GoTo Err:
ElseIf (LblDay(Index).BackStyle = 1 And LblDay(Index).BackColor = RGB(255, 150, 255)) Or (LblDay(Index).BackStyle = 1 And LblDay(Index).BackColor = RGB(100, 200, 10)) Then

GoTo Here:

Else
LblDay(Index).BackStyle = 0
LblDay(Index).BackColor = &H8000000F

Here:
    ComDay.Text = LblDay(Index).Caption
    If Mid(ComDay.Text, 3, 2) = Mid(ComDay.Text, 3, 1) & "号" Then
        ComDay.Text = Mid(ComDay.Text, 3, 1)
    Else
        ComDay.Text = Mid(LblDay(Index).Caption, 3, 2)
    End If
        LblDate(2).Caption = ComYear.Text & "年" & ComMonth.Text & "月" & ComDay.Text & "日"
        ChinaDate.DateNow = CDate(ComYear.Text & "年" & ComMonth.Text & "月" & ComDay.Text & "日")
        ChineseDate = ChinaDate.ChineseDate
        ChineseGanZhi = ChinaDate.ChineseGanZhi
        ChineseSolarTerm = ChinaDate.ChineseSolarTerm
        ChineseAnimal = ChinaDate.ChineseAnimal
        LblDate(3).Caption = ChineseDate & vbCrLf & ChineseGanZhi & vbCrLf & "(" & ChineseAnimal & ")" & vbCrLf & ChineseSolarTerm
End If

Err:

End Sub

'用户点击或选择日期
Sub UserClick()
LblDate(2).Caption = ComYear.Text & "年" & ComMonth.Text & "月" & ComDay.Text & "日"
ChinaDate.DateNow = CDate(ComYear.Text & "年" & ComMonth.Text & "月" & ComDay.Text & "日")
ChineseDate = ChinaDate.ChineseDate
ChineseGanZhi = ChinaDate.ChineseGanZhi
ChineseSolarTerm = ChinaDate.ChineseSolarTerm
ChineseAnimal = ChinaDate.ChineseAnimal
LblDate(3).Caption = ChineseDate & vbCrLf & ChineseGanZhi & vbCrLf & "(" & ChineseAnimal & ")" & vbCrLf & ChineseSolarTerm
End Sub

'显示系统当前时间
Private Sub TimSystem_Timer()
LblTime.Caption = "当前时间:" & Time
End Sub

'如果是二月,天数又比二月的天数大,就不变颜色
Sub ClickErYue()

If ErYue = True Then
    If ComDay.Text > 28 Then
        For Index = 0 To 41
            LblDay(Index).BackStyle = 0
            LblDay(Index).BackColor = &H8000000F
        Next Index
    End If
End If

If RunErYue = True Then
    If ComDay.Text > 29 Then
        For Index = 0 To 41
            LblDay(Index).BackStyle = 0
            LblDay(Index).BackColor = &H8000000F
        Next Index
    End If
End If

End Sub