frmmain.frm

VB精美仿VISTA时钟

        If CanExit = True Then Exit Sub
    Next
    
    frmInfo.Caption = "↓ 日程信息"
    
    For i = 0 To Me.Combo1.ListCount - 1
        If Me.Combo1.List(i) = Me.picMain.FontName Then Me.Combo1.ListIndex = i: Exit For
        DoEvents
    Next i
    Me.Combo1.Enabled = True
    CanExit = True
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If CanExit = False Then
        If Me.Combo1.Enabled = False Then
            'Cancel = 1: Beep: Me.Timer2.Enabled = True
            CanExit = True
        End If
    End If
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    If Me.Width < oldWidth Then Me.Width = oldWidth
    If Me.Height < oldHeight Then Me.Height = oldHeight
    Me.Combo1.Move Me.ScaleWidth - Me.Combo1.Width - 120
    Me.picToolbar.Move Me.Combo1.Left - Me.picToolbar.Width - 120
    Me.picMain.Move 0, Me.picMain.Top, Me.ScaleWidth, Me.ScaleHeight - Me.picMain.Top
    frmInfo.Move Me.Left + Me.Width, Me.Top, frmInfo.Width, Me.Height
    Me.Command1.Move Me.ScaleWidth - Me.Command1.Width - Me.Command2.Width, 0
    Me.Command2.Move Me.ScaleWidth - Me.Command2.Width, 0
    If Me.WindowState = 0 Then
        If HideInfo = False Then frmInfo.Show
    Else
        frmInfo.Hide
    End If
    ReDrawCalendar
End Sub

Public Sub ReDrawCalendar()
    Dim i As Integer
    Dim j As Integer, X As Integer, Y As Integer
    Dim NumDays As Integer, CurrPos As Integer, bCurrMonth As Boolean
    Dim MonthStart As Date, Buffer As String
    Me.picMain.BackColor = vbWhite
    Me.picMain.Cls
    picMain.ForeColor = RGB(236, 233, 216)
    picMain.Line (0, 0)-(Me.picMain.ScaleWidth, Me.picMain.TextHeight("星期") + 4), , BF
    picMain.ForeColor = RGB(182, 189, 210)
    picMain.Line (0, Me.picMain.TextHeight("星期") + 5)-(Me.picMain.ScaleWidth, Me.picMain.TextHeight("星期") + 5), , BF
    tmpA = Me.picMain.ScaleWidth / 7
    tmpB = (Me.picMain.ScaleHeight - Me.picMain.TextHeight("星期") - 4) / 6
    MonthStart = DateSerial(curYear, curMonth, 1)
    NumDays = DateDiff("d", MonthStart, DateAdd("m", 1, MonthStart))
    j = WeekDay(MonthStart) - 1
    j = j - 1
    For i = 1 To NumDays
        CurrPos = i + j
        X = 1 + (CurrPos Mod 7) * tmpA
        Y = Me.picMain.TextHeight("星期") + 5 + 1 + (CurrPos \ 7) * tmpB
        If i = curDay Then
            picMain.Font.Bold = True
        Else
            picMain.Font.Bold = False
        End If
        picMain.ForeColor = vbWhite
        picMain.Line (X, Y)-(X + tmpA, Y + tmpB), , BF
        Select Case WeekDay(DateSerial(curYear, curMonth, i), vbSunday)
            Case 1
                picMain.ForeColor = vbRed
            Case 7
                picMain.ForeColor = RGB(0, 128, 0)
            Case Else
                picMain.ForeColor = vbBlack
        End Select
        If curMonth = Month(Date) And i = Day(Date) And curYear = Year(Date) Then
            picMain.ForeColor = vbBlue
        End If
        dateClass.sInitDate curYear, curMonth, i
        If dateClass.sHolidayRecess = True Then
            picMain.ForeColor = vbRed
        End If
        picMain.CurrentX = X + 4
        picMain.CurrentY = Y + 4
        picMain.Print Format(i) & " " & dateClass.CDayStr(dateClass.lDay)
        If dateClass.sHoliday <> "" Then
            picMain.CurrentX = X + 4
            picMain.Print dateClass.sHoliday
        End If
        If dateClass.lHoliday <> "" Then
            picMain.CurrentX = X + 4
            picMain.Print dateClass.lHoliday
        End If
        If dateClass.lSolarTerm <> "" Then
            picMain.CurrentX = X + 4
            picMain.Print dateClass.lSolarTerm
        End If
    Next i
    picMain.ForeColor = RGB(182, 189, 210)
    For i = 1 To 7
        picMain.Line (i * tmpA, 0)-(i * tmpA, Me.picMain.ScaleHeight)
    Next i
    For i = 1 To 6
        picMain.Line (0, Me.picMain.TextHeight("星期") + 4 + i * tmpB)-(Me.picMain.ScaleWidth, Me.picMain.TextHeight("星期") + 4 + i * tmpB)
    Next i
    picMain.ForeColor = vbBlack
    picMain.Font.Bold = False
    For i = 1 To 7
        picMain.CurrentX = (i - 1) * tmpA + 3
        picMain.CurrentY = 3
        picMain.Print WeekdayName(i, False, vbSunday)
    Next i
    picMain.ForeColor = RGB(182, 189, 210)
    picMain.ForeColor = vbBlack
    dateClass.sInitDate curYear, curMonth, curDay
    Me.Label1.Caption = Format(curYear) & "年" & Format(curMonth) & "月" & Format(curDay) & "日 " & dateClass.sWeekDayStr & "  " & dateClass.GanZhi(CLng(curYear)) & "(" & dateClass.YearAttribute(CLng(curYear)) & ") " & MonthName(dateClass.lMonth, False) & dateClass.CDayStr(dateClass.lDay)
    Me.Label2.Caption = Me.Label1.Caption
    UpdateInfo
End Sub

Public Function GetMonthDayCount(Year As Integer, Month As Integer) As Integer
    If Year Mod 4 = 0 Then
        Select Case Month
            Case 1, 3, 5, 7, 8, 10, 12
                GetMonthDayCount = 31
            Case 4, 6, 9, 11
                GetMonthDayCount = 30
            Case 2
                GetMonthDayCount = 29
        End Select
    Else
        Select Case Month
            Case 1, 3, 5, 7, 8, 10, 12
                GetMonthDayCount = 31
            Case 4, 6, 9, 11
                GetMonthDayCount = 30
            Case 2
                GetMonthDayCount = 28
        End Select
    End If
End Function

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

Private Sub Image2_Click(Index As Integer)
    Select Case Index
        Case 0
            curDay = 1
            curYear = curYear - 1
            If curYear = 1900 Then curYear = 1901
        Case 1
            curDay = 1
            curMonth = curMonth - 1
            If curMonth = 0 Then curMonth = 12: curYear = curYear - 1
            If curYear = 1900 Then curYear = 1901
        Case 2
            curDay = 1
            curMonth = curMonth + 1
            If curMonth = 13 Then curMonth = 1: curYear = curYear + 1
            If curYear = 2050 Then curYear = 2049
        Case 3
            curDay = 1
            curYear = curYear + 1
            If curYear = 2050 Then curYear = 2049
        Case 4
            curYear = Year(Date$)
            curMonth = Month(Date$)
            curDay = Day(Date$)
    End Select
    ReDrawCalendar
End Sub

Private Sub mnuCalendarLastMonth_Click()
    Image2_Click 1
End Sub

Private Sub mnuCalendarLastYear_Click()
    Image2_Click 0
End Sub

Private Sub mnuCalendarNextMonth_Click()
    Image2_Click 2
End Sub

Private Sub mnuCalendarNextYear_Click()
    Image2_Click 3
End Sub

Private Sub mnuViewShowInfo_Click()
    Me.mnuViewShowInfo.Checked = Not Me.mnuViewShowInfo.Checked
    Command2_Click
End Sub

Private Sub picMain_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyRight
            curDay = curDay + 1
            If curDay > GetMonthDayCount(curYear, curMonth) Then
                curDay = 1
                curMonth = curMonth + 1
                If curMonth > 12 Then
                    curMonth = 1
                    curYear = curYear + 1
                    If curYear = 2050 Then curYear = 2049
                End If
            End If
        Case vbKeyLeft
            curDay = curDay - 1
            If curDay <= 0 Then
                curMonth = curMonth - 1
                If curMonth <= 0 Then
                    curMonth = 12
                    curYear = curYear - 1
                    If curYear = 1900 Then curYear = 1901
                End If
                curDay = GetMonthDayCount(curYear, curMonth)
            End If
        Case vbKeyDown
            curDay = curDay + 7
            If curDay > GetMonthDayCount(curYear, curMonth) Then
                curDay = 1
                curMonth = curMonth + 1
                If curMonth > 12 Then
                    curMonth = 1
                    curYear = curYear + 1
                    If curYear = 2050 Then curYear = 2049
                End If
            End If
        Case vbKeyUp
            curDay = curDay - 7
            If curDay <= 0 Then
                curMonth = curMonth - 1
                If curMonth <= 0 Then
                    curMonth = 12
                    curYear = curYear - 1
                    If curYear = 1900 Then curYear = 1901
                End If
                curDay = GetMonthDayCount(curYear, curMonth)
            End If
        Case vbKeyPageUp
            curDay = 1
            curMonth = curMonth - 1
            If curMonth = 0 Then curMonth = 12: curYear = curYear - 1
            If curYear = 1900 Then curYear = 1901
        Case vbKeyPageDown
            curDay = 1
            curMonth = curMonth + 1
            If curMonth = 13 Then curMonth = 1: curYear = curYear + 1
            If curYear = 2050 Then curYear = 2049
    End Select
    ReDrawCalendar
End Sub

Private Sub picMain_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error Resume Next
    Dim i As Integer, MaxDay As Integer
    If Y < Me.picMain.TextHeight("星期") + 5 + 1 Then Exit Sub
    i = WeekDay(DateSerial(curYear, curMonth, 1)) - 1
    i = ((((X + 1) \ tmpA) + 1) + (((Y - (Me.picMain.TextHeight("星期") + 5 + 1)) \ tmpB) * 7)) - i
    MaxDay = GetMonthDayCount(curYear, curMonth)
    If i >= 1 And i <= MaxDay Then
        curDay = i
    End If
    ReDrawCalendar
End Sub

Private Sub Timer1_Timer()
    On Error Resume Next
    If Me.Width < oldWidth Then Me.Width = oldWidth
    If Me.Height < oldHeight Then Me.Height = oldHeight
    Me.picToolbar.Move Me.Combo1.Left - Me.picToolbar.Width - 120
    Me.picMain.Move 0, Me.picMain.Top, Me.ScaleWidth, Me.ScaleHeight - Me.picMain.Top
    frmInfo.Move Me.Left + Me.Width, Me.Top, frmInfo.Width, Me.Height
    If HideInfo Then If frmInfo.Visible = True Then frmInfo.Visible = False: Exit Sub
    If Me.WindowState = 0 Then
        If frmInfo.Visible = False And HideInfo = False Then frmInfo.Visible = True
    Else
        If frmInfo.Visible = True Then frmInfo.Visible = False
    End If
End Sub

Private Sub UpdateInfo()
    Me.Caption = "蓝雪万年历 - [" & Me.Label1.Caption & "]"

    Dim s As String
    Dim i As Integer
    Dim a As String
    dateClass.sInitDate curYear, curMonth, curDay
    s = ""
    s = s & "        好软件，蓝蓝小雪造。       " & vbCrLf
    s = s & "       [e-mail]       " & vbCrLf
    s = s & "       http://blog.snow518.cn      " & vbCrLf
    s = s & "===================================" & vbCrLf
    s = s & "日程信息 (" & Format(curYear) & "年" & Format(curMonth) & "月" & Format(curDay) & "日)" & vbCrLf
    s = s & "===================================" & vbCrLf
    s = s & "年份：" & dateClass.Era(CLng(curYear)) & vbCrLf
    s = s & "公历：" & Format(curYear) & "年" & Format(curMonth) & "月" & Format(curDay) & "日 " & dateClass.sWeekDayStr & vbCrLf
    s = s & "农历：" & dateClass.GanZhi(CLng(curYear)) & "(" & dateClass.YearAttribute(CLng(curYear)) & ")" & "年" & IIf(dateClass.IsLeap, "闰", "") & MonthName(dateClass.lMonth, False) & dateClass.CDayStr(dateClass.lDay) & vbCrLf
    s = s & "===================================" & vbCrLf
    s = s & "公历节日：" & vbCrLf & dateClass.sHoliday & " " & dateClass.wHoliday & vbCrLf
    s = s & "农历节日：" & vbCrLf & dateClass.lHoliday & vbCrLf
    s = s & "===================================" & vbCrLf
    s = s & BI5(curDay - 1) & vbCrLf
    s = s & "===================================" & vbCrLf
    s = s & "生日花语 - "
    a = Format(curMonth) & "月" & Format(curDay) & "日"
    For i = 0 To UBound(BI)
        If InStr(BI(i), a) Then
            s = s & Replace(BI4(i), "\n", vbCrLf) & vbCrLf
            Exit For
        End If
    Next i
    s = s & "===================================" & vbCrLf
    s = s & "星座：" & dateClass.Constellation(CLng(curMonth), CLng(curDay)) & "座(" & dateClass.Constellation2(CLng(curMonth), CLng(curDay)) & ")" & vbCrLf
    a = Format(curMonth) & "月" & Format(curDay) & "日"
    For i = 0 To UBound(BI)
        If InStr(BI(i), a) Then
            s = s & BI(i) & vbCrLf & vbCrLf
            Exit For
        End If
    Next i
    
    a = dateClass.Constellation(CLng(curMonth), CLng(curDay)) & "座"
    For i = 0 To UBound(BI6)
        If Left(BI6(i), 3) = a Then
            s = s & Replace(BI6(i), "$", vbCrLf) & vbCrLf & vbCrLf
            Exit For
        End If
    Next i
    
    s = s & vbCrLf
    a = dateClass.Constellation(CLng(curMonth), CLng(curDay)) & "座的男人和女人"
    For i = 0 To UBound(BI2)
        If InStr(BI2(i), a) Then
            s = s & Replace(BI2(i), "\n", vbCrLf) & vbCrLf
            Exit For
        End If
    Next i
    s = s & "===================================" & vbCrLf
    s = s & "属相："
    a = dateClass.YearAttribute(CLng(curYear))
    For i = 0 To UBound(BI3)
        If InStr(BI3(i), a) Then
            s = s & Replace(BI3(i), "\n", vbCrLf) & vbCrLf
            Exit For
        End If
    Next i
    frmInfo.Text1.Text = s
End Sub

Private Sub Timer2_Timer()
    If Me.Combo1.Enabled = False Then frmInfo.Caption = "↙ 正在处理字体，无法退出……"
End Sub