form1.frm

实现的日历的动态查询,以及详细的日期信息.

Private m_CurrDate As Date                            '选中时间
Private m_nGridWidth As Integer, m_nGridHeight As Integer
Private m_bAcceptChange As Boolean
Private Const GRID_ROWS = 6
Private Const GRID_COLS = 7
Private NowDate(41) As Date
Private IsIndex As Integer
Private ClickIndex As Single             '保存单击picMonth时，在其上的位置索引
Private CurrMonth As Byte                '保存当前操作的月份
Private CurrYear As Integer              '保存当前操作的年
'初始化时间
Private Function GetDate(UserDate As Date, Optional Title) As Boolean

    m_CurrDate = UserDate

    If Not IsMissing(Title) Then
        Caption = Title
    End If

    If m_bAcceptChange Then
        UserDate = m_CurrDate
    End If

    GetDate = m_bAcceptChange
End Function

Private Sub Form_Load()
    Set tDate = New Cls_Date
    m_CurrDate = Date
    
    m_nGridWidth = ((picMonth.ScaleWidth - Screen.TwipsPerPixelX) \ GRID_COLS)
    m_nGridHeight = ((picMonth.ScaleHeight - Screen.TwipsPerPixelY) \ GRID_ROWS)
    m_bAcceptChange = False
    lblMonth.Caption = Date
    GetDate (CVDate(lblMonth.Caption))
    picMonthPaint                       '画出日历
    DrawToday                           '把当前天框出来
    ShowTodayDate                       '显示当天的日期情况
End Sub

Private Sub picMonth_Click()
    Dim NowClickMonth As Byte
    Dim NowClickDate As Date
    NowClickDate = NowDate(ClickIndex - 1)
    NowClickMonth = Month(NowClickDate)
'    Debug.Print "当前操作月份CurrMonth"; CurrMonth
'    Debug.Print "当前点击月份NowClickMonth"; NowClickMonth
'    Debug.Print "当前日期"; DateSerial(CurrYear, CurrMonth, 1)
    If CurrMonth <> 12 And NowClickMonth <> 12 Then
        If CurrMonth < NowClickMonth Then
            SetNewDate DateAdd("m", 1, DateSerial(CurrYear, CurrMonth, 1))
        ElseIf CurrMonth > NowClickMonth Then
            SetNewDate DateAdd("m", -1, DateSerial(CurrYear, CurrMonth, 1))
        End If
    End If
    If CurrMonth = 12 Then
        If NowClickMonth = 1 Then
            SetNewDate DateAdd("m", 1, DateSerial(CurrYear, CurrMonth, 1))
        ElseIf NowClickMonth = 11 Then
            SetNewDate DateAdd("m", -1, DateSerial(CurrYear, CurrMonth, 1))
        End If
    End If
    If NowClickMonth = 12 Then
        If CurrMonth = 1 Then
            SetNewDate DateAdd("m", -1, DateSerial(CurrYear, CurrMonth, 1))
        ElseIf CurrMonth = 11 Then
            SetNewDate DateAdd("m", 1, DateSerial(CurrYear, CurrMonth, 1))
        End If
    End If
End Sub

'日历的相关键盘事件(前提是要获得焦点)
Private Sub picMonth_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim NewDate As Date
    
    Select Case KeyCode
        Case vbKeyRight
            NewDate = DateAdd("d", 1, m_CurrDate)
        Case vbKeyLeft
            NewDate = DateAdd("d", -1, m_CurrDate)
        Case vbKeyDown
            NewDate = DateAdd("ww", 1, m_CurrDate)
        Case vbKeyUp
            NewDate = DateAdd("ww", -1, m_CurrDate)
        Case vbKeyPageDown
            NewDate = DateAdd("m", 1, m_CurrDate)
        Case vbKeyPageUp
            NewDate = DateAdd("m", -1, m_CurrDate)
        Case Else
            Exit Sub
    End Select
    SetNewDate NewDate
    KeyCode = 0
End Sub


'读出当前时间信息
Private Sub picMonth_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim index As Integer, MaxDay As Integer
    Dim tempstr As String
    Dim tempHoliday As String
'    Dim NowMoveDate As Date
    If Y \ m_nGridHeight = 6 Then
        index = ((X \ m_nGridWidth) + 1) + (Y \ m_nGridHeight - 1) * GRID_COLS
    Else
        index = ((X \ m_nGridWidth) + 1) + (Y \ m_nGridHeight) * GRID_COLS
    End If
    If IsIndex <> index Then
        m_CurrDate = NowDate(index - 1)    '当前移到的位置的日期
    
        tDate.sInitDate Year(m_CurrDate), Month(m_CurrDate), Day(m_CurrDate)
        lblDate(0).Caption = tDate.sYear & "年" & tDate.sMonth & "月" & tDate.sDay & "日" & "  " & tDate.sWeekDayStr & "  " & tDate.Constellation(tDate.sMonth, tDate.sDay) & "座"
    
        If tDate.IsLeap = False Then
            tempstr = tDate.Converts(CStr(tDate.lMonth)) & "月"
            If tempstr = "一月" Then
                 tempstr = "正月"
            End If
        Else
            tempstr = "闰" & tDate.Converts(CStr(tDate.lMonth)) & "月"
            If tempstr = "闰一月" Then
                 tempstr = "闰正月"
            End If
        End If
'        Debug.Print "tDate.lYear"; tDate.lYear
'        Debug.Print "tDate.lDay"; tDate.lDay
    
        lblDate(1).Caption = tDate.convertYear(tDate.lYear) & "  " & tempstr & tDate.CDayStr(tDate.lDay)
        lblDate(2).Caption = tDate.GanZhi(tDate.lYear) & "(" & tDate.YearAttribute(tDate.lYear) & ")年"
    
        tempHoliday = tDate.wHoliday
        If tempHoliday <> "" Then
            If tDate.sHoliday <> "" Then
                tempHoliday = tempHoliday & "," & tDate.sHoliday
            End If
        Else
            tempHoliday = tDate.sHoliday
        End If
        If tempHoliday <> "" Then
            If tDate.lHoliday <> "" Then
                tempHoliday = tempHoliday & "," & tDate.lHoliday
            End If
        Else
            tempHoliday = tDate.lHoliday
        End If
    
        If tempHoliday = "" Then
            picShowDate.Height = lblDate(3).Top
        Else
            picShowDate.Height = lblDate(3).Top + lblDate(3).Height
            lblDate(3).Caption = tempHoliday
        End If
    
'        SetNewDate NowDate(index - 1)
        picShowDate.Visible = True
        picShowDate.Left = X + 300
        picShowDate.Top = Y - 400
        
        ClickIndex = index
        IsIndex = index
    End If
End Sub

'转换到下一月
Private Sub lblNext_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And vbLeftButton Then
'        Debug.Print "m_CurrDate"; m_CurrDate
        SetNewDate DateAdd("m", 1, m_CurrDate)
    End If
End Sub

'双击转换到下一月
Private Sub lblNext_DblClick()
    SetNewDate DateAdd("m", 1, m_CurrDate)
End Sub

'点击转换到下一年
Private Sub lblNextYear_Click()
    SetNewDate DateAdd("yyyy", 1, m_CurrDate)
End Sub

'转换到上一月
Private Sub lblPrev_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And vbLeftButton Then
        SetNewDate DateAdd("m", -1, m_CurrDate)
    End If
End Sub

'双击转换到上一月
Private Sub lblPrev_DblClick()
    SetNewDate DateAdd("m", -1, m_CurrDate)
End Sub

'点击转换到上一年
Private Sub lblPrevMonth_Click()
    SetNewDate DateAdd("yyyy", -1, m_CurrDate)
End Sub

'转换新的天数
Private Sub SetNewDate(NewDate As Date)
    If CurrMonth = Month(NewDate) And CurrYear = Year(NewDate) Then
'        DrawSelectionBox False
        m_CurrDate = NewDate
'        DrawSelectionBox True
    Else
        m_CurrDate = NewDate
        picMonthPaint
        If Year(m_CurrDate) = Year(Date) And Month(m_CurrDate) = Month(Date) Then
            DrawToday
        End If
    End If
End Sub

'画图（画出日历）
Private Sub picMonthPaint()
    Dim i As Integer, j As Integer, k As Integer, n As Integer, X As Integer, Y As Integer
    Dim PrevNumDays As Integer, PrevCurrPos As Integer                                   '上个月的变量定义
    Dim NowNumDays As Integer, NowCurrPos As Integer, NowbCurrMonth As Boolean           '当前月的变量定义
    Dim NextNumDays As Integer, NextCurrPos As Integer                                   '下个月的变量定义
    Dim Pm_CurrDate As Date
    Dim Nm_CurrDate As Date
    Dim NowMonthStart As Date, PrevMonthStart As Date, NextMonthStart As Date, Buffer As String
    Dim NowMonthEnd As Date                                                              '当前月的最后一天
    Dim Count As Integer                                                                 '统计已经画了的日历数
    '判断是否是当前月
    If Month(m_CurrDate) = Month(Date) And Year(m_CurrDate) = Year(Date) Then
        NowbCurrMonth = True
    End If

    Pm_CurrDate = CDate(DateAdd("m", -1, m_CurrDate))         '上个月
    Nm_CurrDate = CDate(DateAdd("m", 1, m_CurrDate))          '下个月

    PrevMonthStart = DateSerial(Year(Pm_CurrDate), Month(Pm_CurrDate), 1)
    PrevNumDays = DateDiff("d", PrevMonthStart, DateAdd("m", 1, PrevMonthStart))    '上个月的天数
    
    CurrMonth = Month(m_CurrDate)
    CurrYear = Year(m_CurrDate)
    
    NowMonthStart = DateSerial(Year(m_CurrDate), Month(m_CurrDate), 1)
    NowNumDays = DateDiff("d", NowMonthStart, DateAdd("m", 1, NowMonthStart))             '当前月的天数
    NowMonthEnd = DateSerial(Year(m_CurrDate), Month(m_CurrDate), NowNumDays)
'    Debug.Print "这个月的第一天："; NowMonthStart
'    Debug.Print "这个月的最后一天："; NowMonthEnd
'    Debug.Print WeekDay(NowMonthEnd)
    j = WeekDay(NowMonthStart) - 1
    n = WeekDay(NowMonthEnd) + 1
    j = j - 1
    lblMonth = Format$(m_CurrDate, "mmmm yyyy")
    
    NextMonthStart = DateSerial(Year(Nm_CurrDate), Month(Nm_CurrDate), 1)
    NextNumDays = DateDiff("d", NextMonthStart, DateAdd("m", 1, NextMonthStart))    '下个月的天数
    
    picMonth.Cls
    
    '显示上个月的天数
    k = j
    If k >= 0 Then
        For i = PrevNumDays To 1 Step -1
    '        Debug.Print "PrevNumDays"; PrevNumDays
            CurrPos = k
    '        Debug.Print "CurrPos"; CurrPos
            X = (CurrPos Mod GRID_COLS) * m_nGridWidth
            Y = (CurrPos \ GRID_COLS) * m_nGridHeight
            
            picMonth.Font.Bold = False
            picMonth.Font.Size = 24
            picMonth.ForeColor = vbBlue
    
            Buffer = CStr(i)
            picMonth.CurrentX = X + ((m_nGridWidth - picMonth.TextWidth(Buffer)) / 2)
            picMonth.CurrentY = Y + ((m_nGridHeight - picMonth.TextHeight(Buffer)) / 2)
            picMonth.Print Buffer
    '        PSetNewDate DateSerial(Year(Pm_CurrDate), Month(Pm_CurrDate), PrevNumDays)
    
            NowDate(k) = DateSerial(Year(Pm_CurrDate), Month(Pm_CurrDate), i)
            k = k - 1
            Count = Count + 1
            If k < 0 Then
                Exit For
            End If
        Next i
    End If
'    Debug.Print "count1"; Count
    '显示本月的天数
    For i = 1 To NowNumDays
        CurrPos = i + j
'        Debug.Print "CurrPos"; CurrPos
        X = (CurrPos Mod GRID_COLS) * m_nGridWidth
        Y = (CurrPos \ GRID_COLS) * m_nGridHeight

        If bCurrMonth And i = Day(Date) Then
            picMonth.Font.Bold = True
            picMonth.Font.Size = 24
            picMonth.ForeColor = vbRed
        Else
            picMonth.Font.Bold = False
            picMonth.Font.Size = 24
            picMonth.ForeColor = vbBlack
        End If

        Buffer = CStr(i)
        picMonth.CurrentX = X + ((m_nGridWidth - picMonth.TextWidth(Buffer)) / 2)
        picMonth.CurrentY = Y + ((m_nGridHeight - picMonth.TextHeight(Buffer)) / 2)
        picMonth.Print CStr(i);
        
        NowDate(CurrPos) = DateSerial(Year(m_CurrDate), Month(m_CurrDate), i)
        
        Count = Count + 1
'        SetNewDate DateSerial(Year(m_CurrDate), Month(m_CurrDate), i)
    Next i
'    Debug.Print "count"; Count
    '显示下个月的天数
    If Count < 42 Then
        For i = 1 To NextNumDays
            CurrPos = Count
'            Debug.Print "CurrPos"; CurrPos
            X = (CurrPos Mod GRID_COLS) * m_nGridWidth
            Y = (CurrPos \ GRID_COLS) * m_nGridHeight
    
            picMonth.Font.Bold = False
            picMonth.Font.Size = 24
            picMonth.ForeColor = vbBlue
    
            Buffer = CStr(i)
            picMonth.CurrentX = X + ((m_nGridWidth - picMonth.TextWidth(Buffer)) / 2)
            picMonth.CurrentY = Y + ((m_nGridHeight - picMonth.TextHeight(Buffer)) / 2)
            picMonth.Print Buffer;
            
            NowDate(CurrPos) = DateSerial(Year(Nm_CurrDate), Month(Nm_CurrDate), i)
            
            Count = Count + 1
            If Count >= 42 Then
                Exit For
            End If
    '        SetNewDate DateSerial(Year(m_CurrDate), Month(m_CurrDate), i)
        Next i
    End If
'    For i = 0 To 42
'        Debug.Print NowDate(i)
'    Next i
'    DrawSelectionBox True
End Sub

'突出选择位置
'Private Sub DrawSelectionBox(bSelected As Boolean)
'    Dim clrTopLeft As Long, clrBottomRight As Long
'    Dim i As Integer, X As Integer, Y As Integer
'
'    If bSelected Then
'        clrTopLeft = vbButtonShadow
'        clrBottomRight = vb3DHighlight
'    Else
'        clrTopLeft = vbButtonFace
'        clrBottomRight = vbButtonFace
'    End If
'
'    i = WeekDay(DateSerial(Year(m_CurrDate), Month(m_CurrDate), 1)) - 1
'    i = i + (Day(m_CurrDate) - 1)
'    X = (i Mod GRID_COLS) * m_nGridWidth
'    Y = (i \ GRID_COLS) * m_nGridHeight
'
'    picMonth.Line (X, Y + m_nGridHeight)-Step(0, -m_nGridHeight), clrTopLeft
'    picMonth.Line -Step(m_nGridWidth, 0), clrTopLeft
'    picMonth.Line -Step(0, m_nGridHeight), clrBottomRight
'    picMonth.Line -Step(-m_nGridWidth, 0), clrBottomRight
'End Sub

'用红框画出当天的日期
Private Sub DrawToday()
    Dim clrTopLeft As Long, clrBottomRight As Long
    Dim i As Integer, X As Integer, Y As Integer

    i = WeekDay(DateSerial(Year(Date), Month(Date), 1)) - 1
    i = i + (Day(Date) - 1)
    X = (i Mod GRID_COLS) * m_nGridWidth
    Y = (i \ GRID_COLS) * m_nGridHeight

    picMonth.Line (X, Y + m_nGridHeight)-Step(0, -m_nGridHeight), vbRed
    picMonth.Line -Step(m_nGridWidth, 0), vbRed
    picMonth.Line -Step(0, m_nGridHeight), vbRed
    picMonth.Line -Step(-m_nGridWidth, 0), vbRed
End Sub

'显示当天的具体日历情况
Private Sub ShowTodayDate()
    tDate.sInitDate Year(Date), Month(Date), Day(Date)
    lblToday(0).Caption = "公历：" & tDate.sYear & "年" & tDate.sMonth & "月" & tDate.sDay & "日" & "  " & tDate.sWeekDayStr & "  " & tDate.Constellation(tDate.sMonth, tDate.sDay) & "座"

    If tDate.IsLeap = False Then
        tempstr = tDate.Converts(CStr(tDate.lMonth)) & "月"
        If tempstr = "一月" Then
             tempstr = "正月"
        End If
    Else
        tempstr = "闰" & tDate.Converts(CStr(tDate.lMonth)) & "月"
        If tempstr = "闰一月" Then
             tempstr = "闰正月"
        End If
    End If

    lblToday(1).Caption = "农历：" & tDate.convertYear(tDate.lYear) & "  " & tempstr & tDate.CDayStr(tDate.lDay)
    lblToday(2).Caption = "干支：" & tDate.GanZhi(tDate.lYear) & "(" & tDate.YearAttribute(tDate.lYear) & ")年"

    tempHoliday = tDate.wHoliday
    If tempHoliday <> "" Then
        If tDate.sHoliday <> "" Then
            tempHoliday = tempHoliday & "," & tDate.sHoliday
        End If
    Else
        tempHoliday = tDate.sHoliday
    End If
    If tempHoliday <> "" Then
        If tDate.lHoliday <> "" Then
            tempHoliday = tempHoliday & "," & tDate.lHoliday
        End If
    Else
        tempHoliday = tDate.lHoliday
    End If

    lblToday(3).Caption = "节日：" & tempHoliday
End Sub