⭐ 欢迎来到虫虫下载站！ | 📦 资源下载 📁 资源专辑 ℹ️ 关于我们
⭐ 虫虫下载站
📤 上传资源

📄 date.frm

📁 一个可以显示阴历和阳历的月历程序,显示在桌面上,背景透明.
💻 FRM
📖 第 1 页 / 共 4 页
字号:
🔍
1234 
'设置前景色
Function setForeColor()

    '读取保存的颜色
    Call ReadColor
    
    '全部统一设置
    YearLabel.ForeColor = textColor
    YearLabel2.ForeColor = textColor
    MonthLabel.ForeColor = textColor
    MonthLabel2.ForeColor = textColor
    Dim i
    For i = 0 To 6
        WeekLabel(i).ForeColor = textColor
    Next
    For i = 0 To 79
        DayLabel(i).ForeColor = textColor
    Next
    
    '高亮设置
    '周末
    For i = 0 To 4
        DayLabel(i * 7 + 5).ForeColor = WeekendColor
        DayLabel(i * 7 + 6).ForeColor = WeekendColor
    Next
    '农历
    For i = 40 To 79
        DayLabel(i).ForeColor = LunarColor
    Next
    '今天
    For i = 0 To 39
        If DayLabel(i).Caption = GDay Then
            TodayLabel_i = i
            DayLabel(TodayLabel_i).ForeColor = TodayColor

            'Timer1.Enabled = True
                If TodayColor_loop = 1 Then
                    '红:RR,绿:GG,蓝:BB
                    RR = 0
                    Color_space = 5
                    RR1.Enabled = True
                End If
            Exit For
        End If
    Next
    
End Function

'读取颜色
Private Function ReadColor()
    TodayColor = GetSetting("Calendar", "Color", "TodayColor", "&H0000FF")
    WeekendColor = GetSetting("Calendar", "Color", "WeekendColor", "&H0080FF")
    LunarColor = GetSetting("Calendar", "Color", "LunarColor", "&HC4C4C4")
    textColor = GetSetting("Calendar", "Color", "textColor", "&HFFFFFF")
    TodayColor_loop = GetSetting("Calendar", "Color", "TodayColor_loop", "1")
End Function

'在Dialog窗口中
'保存颜色Dim TodayColor, WeekendColor, textColor



'设置背景色
Private Function setBackColor(DefinedColor)
    YearLabel.BackColor = DefinedColor
    YearLabel2.BackColor = DefinedColor
    MonthLabel.BackColor = DefinedColor
    MonthLabel2.BackColor = DefinedColor
    Dim i
    For i = 0 To 6
        WeekLabel(i).BackColor = DefinedColor
    Next
    For i = 0 To 79
        DayLabel(i).BackColor = DefinedColor
    Next
End Function

'设置农历
Private Function setLunar(M)
    '当月农历
    If GYear = "2008" Then
        If (M = 9) Then Lunar = Array("初二", "初三", "初四", "初五", "初六", "初七", "初八", "初九", "初十", "十一", "十二", "十三", "十四", "十五", "十六", "十七", "十八", "十九", "二十", "廿一", "廿二", "廿三", "廿四", "廿五", "廿六", "廿七", "廿八", "廿九", "九月", "初二")
        If (M = 10) Then Lunar = Array("初三", "初四", "初五", "初六", "初七", "初八", "初九", "初十", "十一", "十二", "十三", "十四", "十五", "十六", "十七", "十八", "十九", "二十", "廿一", "廿二", "廿三", "廿四", "廿五", "廿六", "廿七", "廿八", "廿九", "三十", "十月", "初二", "初三")
        If (M = 11) Then Lunar = Array("初四", "初五", "初六", "初七", "初八", "初九", "初十", "十一", "十二", "十三", "十四", "十五", "十六", "十七", "十八", "十九", "二十", "廿一", "廿二", "廿三", "廿四", "廿五", "廿六", "廿七", "廿八", "廿九", "三十", "冬月", "初二", "初三")
        If (M = 12) Then Lunar = Array("初四", "初五", "初六", "初七", "初八", "初九", "初十", "十一", "十二", "十三", "十四", "十五", "十六", "十七", "十八", "十九", "二十", "廿一", "廿二", "廿三", "廿四", "廿五", "廿六", "廿七", "廿八", "廿九", "腊月", "初二", "初三", "初四", "初五")
    End If
    If GYear = "2009" Then
        If (M = 1) Then Lunar = Array(初六, "初七", "初八", "初九", "初十", "十一", "十二", "十三", "十四", "十五", "十六", "十七", "十八", "十九", "二十", "廿一", "廿二", "廿三", "廿四", "廿五", "廿六", "廿七", "廿八", "廿九", "三十", "正月", "初二", "初三", "初四", "初五", "初六")
        If (M = 2) Then Lunar = Array(初七, "初八", "初九", "初十", "十一", "十二", "十三", "十四", "十五", "十六", "十七", "十八", "十九", "二十", "廿一", "廿二", "廿三", "廿四", "廿五", "廿六", "廿七", "廿八", "廿九", "三十", "二月", "初二", "初三", "初四")
        If (M = 3) Then Lunar = Array(初五, "初六", "初七", "初八", "初九", "初十", "十一", "十二", "十三", "十四", "十五", "十六", "十七", "十八", "十九", "二十", "廿一", "廿二", "廿三", "廿四", "廿五", "廿六", "廿七", "廿八", "廿九", "三十", "三月", "初二", "初三", "初四", "初五")
        If (M = 4) Then Lunar = Array(初六, "初七", "初八", "初九", "初十", "十一", "十二", "十三", "十四", "十五", "十六", "十七", "十八", "十九", "二十", "廿一", "廿二", "廿三", "廿四", "廿五", "廿六", "廿七", "廿八", "廿九", "四月", "初二", "初三", "初四", "初五", "初六")
        If (M = 5) Then Lunar = Array(初七, "初八", "初九", "初十", "十一", "十二", "十三", "十四", "十五", "十六", "十七", "十八", "十九", "二十", "廿一", "廿二", "廿三", "廿四", "廿五", "廿六", "廿七", "廿八", "廿九", "五月", "初二", "初三", "初四", "初五", "初六", "初七", "初八")
        If (M = 6) Then Lunar = Array("初九", "初十", "十一", "十二", "十三", "十四", "十五", "十六", "十七", "十八", "十九", "二十", "廿一", "廿二", "廿三", "廿四", "廿五", "廿六", "廿七", "廿八", "廿九", "三十", "闰五", "初二", "初三", "初四", "初五", "初六", "初七", "初八")
        If (M = 7) Then Lunar = Array(初九, "初十", "十一", "十二", "十三", "十四", "十五", "十六", "十七", "十八", "十九", "二十", "廿一", "廿二", "廿三", "廿四", "廿五", "廿六", "廿七", "廿八", "廿九", "六月", "初二", "初三", "初四", "初五", "初六", "初七", "初八", "初九", "初十")
        If (M = 8) Then Lunar = Array(十一, "十二", "十三", "十四", "十五", "十六", "十七", "十八", "十九", "二十", "廿一", "廿二", "廿三", "廿四", "廿五", "廿六", "廿七", "廿八", "廿九", "七月", "初二", "初三", "初四", "初五", "初六", "初七", "初八", "初九", "初十", "十一", "十二")
        If (M = 9) Then Lunar = Array(十三, "十四", "十五", "十六", "十七", "十八", "十九", "二十", "廿一", "廿二", "廿三", "廿四", "廿五", "廿六", "廿七", "廿八", "廿九", "三十", "八月", "初二", "初三", "初四", "初五", "初六", "初七", "初八", "初九", "初十", "十一", "十二")
        If (M = 10) Then Lunar = Array(十三, "十四", "十五", "十六", "十七", "十八", "十九", "二十", "廿一", "廿二", "廿三", "廿四", "廿五", "廿六", "廿七", "廿八", "廿九", "九月", "初二", "初三", "初四", "初五", "初六", "初七", "初八", "初九", "初十", "十一", "十二", "十三", "十四")
        If (M = 11) Then Lunar = Array(十五, "十六", "十七", "十八", "十九", "二十", "廿一", "廿二", "廿三", "廿四", "廿五", "廿六", "廿七", "廿八", "廿九", "三十", "十月", "初二", "初三", "初四", "初五", "初六", "初七", "初八", "初九", "初十", "十一", "十二", "十三", "十四")
        If (M = 12) Then Lunar = Array(十五, "十六", "十七", "十八", "十九", "二十", "廿一", "廿二", "廿三", "廿四", "廿五", "廿六", "廿七", "廿八", "廿九", "冬月", "初二", "初三", "初四", "初五", "初六", "初七", "初八", "初九", "初十", "十一", "十二", "十三", "十四", "十五", "十六")
    End If
End Function

'设置日历
Private Function setDay()
    Dim Date1, Date2
    Date1 = CStr(GYear) + "-" + CStr(GMonth) + "-01"
    If GMonth < 12 Then
        Date2 = CStr(GYear) + "-" + CStr(GMonth + 1) + "-01"
    Else
        Date2 = CStr(GYear + 1) + "-01-01"
    End If
    FirstDay = Weekday(Date1, vbMonday)
    Dim i, j
    For i = 0 To 79
        DayLabel(i).Caption = ""
    Next
    j = 0
    For i = FirstDay - 1 To 39
        j = j + 1
        DayLabel(i).Caption = j
        DayLabel(i + 40).Caption = Lunar(j - 1)
        If DateDiff("Y", CDate(CDate(CStr(GYear) + "-" + CStr(GMonth) + "-" + CStr(j))), CDate(Date2)) = 1 Then Exit For
    Next
End Function

'设置各种标签位置
Private Function setLabelPosition()
    
    '图片位置
    ImageMove.Left = 0
    ImageMove.Top = 0
    
    Dim i, j
    '日大小
    For i = 0 To 39
        DayLabel(i).Width = 500
        DayLabel(i + 40).Width = 500
    Next
    '位置数量
    Dim startPX, widthPX, heightPX
    startPX = 1200
    widthPX = 600
    heightPX = 600
    
    '窗口大小
    Me.Width = widthPX * 7
    Me.Height = startPX + heightPX * 6
        
    '年月大小,位置
    MonthLabel2.Font.Size = 24
    MonthLabel2.Width = 420
    MonthLabel2.Height = 600
    
    MonthLabel.Font.Size = 16
    MonthLabel.Width = 300
    MonthLabel.Height = 480
    
    YearLabel2.Font.Size = 12
    YearLabel2.Width = 300
    YearLabel2.Height = 600
    
    YearLabel.Font.Size = 12
    YearLabel.Width = 600
    YearLabel.Height = 480
    
    
    MonthLabel2.Top = 0
    MonthLabel.Top = 120
    YearLabel2.Top = 180
    YearLabel.Top = 180
    MonthLabel2.Left = widthPX * 7 - 150 - MonthLabel2.Width
    MonthLabel.Left = MonthLabel2.Left - MonthLabel.Width
    YearLabel2.Left = MonthLabel.Left - YearLabel2.Width
    YearLabel.Left = YearLabel2.Left - YearLabel.Width
        
    
    '一二三四五六日
    For i = 0 To 6
        WeekLabel(i).Font.Size = 14
        WeekLabel(i).Alignment = 1
        WeekLabel(i).Left = 120 + i * widthPX
    Next
    
    '日
    For i = 0 To 5
        For j = 0 To 7
            If (i * 7 + j) > 39 Then Exit For
            '日大小,位置
            DayLabel(i * 7 + j).Font.Size = 11
            DayLabel(i * 7 + j).Font.Bold = True
            DayLabel(i * 7 + j).Left = 0 + j * widthPX
            DayLabel(i * 7 + j + 40).Left = 0 + j * widthPX
            
            DayLabel(i * 7 + j).Top = startPX + i * heightPX
            DayLabel(i * 7 + j + 40).Top = startPX + i * heightPX + 255
            
        Next
    Next
    DayLabel(TodayLabel_i).Font.Size = DayLabel(TodayLabel_i).FontSize + 4
    
    DayLabel(TodayLabel_i).Top = DayLabel(TodayLabel_i).Top - 60
    DayLabel(TodayLabel_i).Height = DayLabel(TodayLabel_i).Height + 120

End Function






'拖放窗口移动
Private Sub ImageMove_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Call ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
        '保存位置
        Call WritePos
    End If
End Sub
'读取窗口位置
 Private Function ReadPos()
    Window_X = GetSetting("Calendar", "Window", "X", 200)
    Window_Y = GetSetting("Calendar", "Window", "Y", 100)
End Function

'保存窗口位置
 Private Function WritePos()
    Call SaveSetting("Calendar", "Window", "X", Me.Left / 15)
    Call SaveSetting("Calendar", "Window", "Y", Me.Top / 15)
End Function

'红+;绿0;蓝255
Private Sub RR1_Timer()
    '红:RR,绿:GG,蓝:BB
    GG = 0
    BB = 255
    RR = RR + Color_space
    DayLabel(TodayLabel_i).ForeColor = RGB(RR, GG, BB)
    If RR > 250 Then
        RR1.Enabled = False
        BB2.Enabled = True
    End If
    
End Sub
'红255;绿0;蓝-
Private Sub BB2_Timer()
    RR = 255
    GG = 0
    BB = BB - Color_space
    DayLabel(TodayLabel_i).ForeColor = RGB(RR, GG, BB)
    If BB < 10 Then
        BB2.Enabled = False
        GG1.Enabled = True
    End If
End Sub
'红255;绿+;蓝0
Private Sub GG1_Timer()
    RR = 255
    GG = GG + Color_space
    BB = 0
    DayLabel(TodayLabel_i).ForeColor = RGB(RR, GG, BB)
    If GG > 250 Then
        GG1.Enabled = False
        RR2.Enabled = True
    End If
End Sub
'红-;绿255;蓝0
Private Sub RR2_Timer()
    RR = RR - Color_space
    GG = 255
    BB = 0
    DayLabel(TodayLabel_i).ForeColor = RGB(RR, GG, BB)
    If RR < 10 Then
        RR2.Enabled = False
        BB1.Enabled = True
    End If
End Sub
'红0;绿255;蓝+
Private Sub BB1_Timer()
    RR = 0
    GG = 255
    BB = BB + Color_space
    DayLabel(TodayLabel_i).ForeColor = RGB(RR, GG, BB)
    If BB > 250 Then
        BB1.Enabled = False
        GG2.Enabled = True
    End If
End Sub
'红0;绿-;蓝255
Private Sub GG2_Timer()
    RR = 0
    GG = GG - Color_space
    BB = 255
    DayLabel(TodayLabel_i).ForeColor = RGB(RR, GG, BB)
    If GG < 10 Then
        GG2.Enabled = False
        RR1.Enabled = True
    End If
End Sub

Private Sub Setting_Click()
    '加载当前颜色
    Dialog.TodayColorLabel.BackColor = TodayColor
    Dialog.WeekendColorLabel.BackColor = WeekendColor
    Dialog.textColorLabel.BackColor = textColor
    Dialog.LunarColorLabel.BackColor = LunarColor
    
    Dialog.TodayColorText.text = formatNum(TodayColor, 6)
    Dialog.WeekendColorText.text = formatNum(WeekendColor, 6)
    Dialog.textColorText.text = formatNum(textColor, 6)
    Dialog.LunarColorText.text = formatNum(LunarColor, 6)
    
    Dialog.ColorCheck.Value = TodayColor_loop
    
    Dialog.Show
End Sub
'格式化十六进制数字
Private Function formatNum(Num, N)
    Dim str, i
    str = CStr(Hex(Num))
    N = N - Len(str)
    If N > 0 Then
        For i = 1 To N
            str = "0" + str
        Next
    End If
    formatNum = str
End Function

Private Sub Timer1_Timer()
    On Error Resume Next
    If TodayLabel_Top < 45 Then
        TodayLabel_Top = TodayLabel_Top + 15
        DayLabel(TodayLabel_i).Top = DayLabel(TodayLabel_i).Top - 15
    Else
        DayLabel(TodayLabel_i).Top = DayLabel(TodayLabel_i).Top + TodayLabel_Top
        TodayLabel_Top = 0
    End If
End Sub

'右键菜单
Private Sub ImageMove_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
        PopupMenu OptionMenu
    End If
End Sub


Private Sub YearLabel_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
        PopupMenu OptionMenu
    End If
End Sub

Private Sub YearLabel2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
        PopupMenu OptionMenu
    End If
End Sub
Private Sub MonthLabel_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
        PopupMenu OptionMenu
    End If
End Sub
Private Sub MonthLabel2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
        PopupMenu OptionMenu
    End If
End Sub

Private Sub WeekLabel_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
        PopupMenu OptionMenu
    End If
End Sub
Private Sub DayLabel_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
        PopupMenu OptionMenu
    End If
End Sub
1234

⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -