代码如下。。。
Public PubSelDate As Date '//代表已经选择的日期
Option Explicit '//强制声明变量
Rem ================================================================================================================农历常量
Rem 公历转农历模块
Rem // 农历数据定义 //
Rem 先以 H2B 函数还原成长度为 18 的字符串，其定义如下：
Rem 前12个字节代表1-12月：1为大月，0为小月；压缩成十六进制(1-3位)
Rem 第13位为闰月的情况，1为大月30天，0为小月29天；(4位)
Rem 第14位为闰月的月份，如果不是闰月为0，否则给出月份(5位)
Rem 最后4位为当年农历新年的公历日期，如0131代表1月31日；当作数值转十六进制(6-7位)
Rem 农历常量(1899~2100，共202年）
Private Const ylData = "AB500D2,4BD0883," _
& "4AE00DB,A5700D0,54D0581,D2600D8,D9500CC,655147D,56A00D5,9AD00CA,55D027A,4AE00D2," _
& "A5B0682,A4D00DA,D2500CE,D25157E,B5500D6,56A00CC,ADA027B,95B00D3,49717C9,49B00DC," _
& "A4B00D0,B4B0580,6A500D8,6D400CD,AB5147C,2B600D5,95700CA,52F027B,49700D2,6560682," _
& "D4A00D9,EA500CE,6A9157E,5AD00D6,2B600CC,86E137C,92E00D3,C8D1783,C9500DB,D4A00D0," _
& "D8A167F,B5500D7,56A00CD,A5B147D,25D00D5,92D00CA,D2B027A,A9500D2,B550781,6CA00D9," _
& "B5500CE,535157F,4DA00D6,A5B00CB,457037C,52B00D4,A9A0883,E9500DA,6AA00D0,AEA0680," _
& "AB500D7,4B600CD,AAE047D,A5700D5,52600CA,F260379,D9500D1,5B50782,56A00D9,96D00CE," _
& "4DD057F,4AD00D7,A4D00CB,D4D047B,D2500D3,D550883,B5400DA,B6A00CF,95A1680,95B00D8," _
& "49B00CD,A97047D,A4B00D5,B270ACA,6A500DC,6D400D1,AF40681,AB600D9,93700CE,4AF057F," _
& "49700D7,64B00CC,74A037B,EA500D2,6B50883,5AC00DB,AB600CF,96D0580,92E00D8,C9600CD," _
& "D95047C,D4A00D4,DA500C9,755027A,56A00D1,ABB0781,25D00DA,92D00CF,CAB057E,A9500D6," _
& "B4A00CB,BAA047B,B5500D2,55D0983,4BA00DB,A5B00D0,5171680,52B00D8,A9300CD,795047D," _
& "6AA00D4,AD500C9,5B5027A,4B600D2,96E0681,A4E00D9,D2600CE,EA6057E,D5300D5,5AA00CB," _
& "76A037B,96D00D3,4AB0B83,4AD00DB,A4D00D0,D0B1680,D2500D7,D5200CC,DD4057C,B5A00D4," _
& "56D00C9,55B027A,49B00D2,A570782,A4B00D9,AA500CE,B25157E,6D200D6,ADA00CA,4B6137B," _
& "93700D3,49F08C9,49700DB,64B00D0,68A1680,EA500D7,6AA00CC,A6C147C,AAE00D4,92E00CA," _
& "D2E0379,C9600D1,D550781,D4A00D9,DA400CD,5D5057E,56A00D6,A6C00CB,55D047B,52D00D3," _
& "A9B0883,A9500DB,B4A00CF,B6A067F,AD500D7,55A00CD,ABA047C,A5A00D4,52B00CA,B27037A," _
& "69300D1,7330781,6AA00D9,AD500CE,4B5157E,4B600D6,A5700CB,54E047C,D1600D2,E960882," _
& "D5200DA,DAA00CF,6AA167F,56D00D7,4AE00CD,A9D047D,A2D00D4,D1500C9,F250279,D5200D1"
Private Const ylMd0 = "初一初二初三初四初五初六初七初八初九初十十一十二十三十四十五" _
& "十六十七十八十九二十廿一廿二廿三廿四廿五廿六廿七廿八廿九三十 "
Private Const ylMn0 = "正二三四五六七八九十冬腊"
Private Const ylTianGan0 = "甲乙丙丁戊已庚辛壬癸"
Private Const ylDiZhi0 = "子丑寅卯辰巳午未申酉戌亥"
Private Const ylShu0 = "鼠牛虎兔龙蛇马羊猴鸡狗猪"
Rem ================================================================================================================窗体变量
Public youXuan As Boolean
Private cmdDay
Private strZuo As String
Private strJin As String
Rem 窗体常数
Const Min_Year = 1901
Const Max_Year = 2099
Const Min_Month = 1
Const Max_Month = 12
Const Str_Fen = "-"
Const Color_Sunday = &HFF& '//红色 '//星期六日颜色
Const Color_GrayWeekday = &H0& '//黑色 '//非本月非星期六日颜色
Const Color_DayBackNoMonth = &H8000000F '//灰色 '//非本月日期底色
Const Color_Weekday = &HFF0000 '//蓝色 '//本月非星期六日颜色
Const Color_GraySunday = &H8080FF '//红色 '//星期六日颜色
Const Color_DayBackColor = &H80FF80 '//绿色 '//本月日期底色
Const Color_DayNowBackColor = &HFF80FF '//粉色 '//今天的底色
Const Color_DayNowBackColor1 = &H80FFFF '//黄色 '//被选中日期底色
Rem 颜色： &H808080 '//红色；&HFF0000 '//蓝色
Rem 按钮相应事件
Private Sub cmdDay_Click(strDay As String, nNowMonth As Integer)
Rem Call cmdDay_Click(cmdDay11.Caption, cmdDay11.Tag)
Rem 按钮上的文字，月份差
youXuan = True
Dim dtFirstDate
Dim ln As Long
Rem 选择后：本月第一天
dtFirstDate = Replace(Replace(cmbYear.Text, "年", ""), "月", "") & Str_Fen & Replace(Replace(cmbMonth.Text, "年", ""), "月", "") & Str_Fen & "1"
Rem 计算被选择的是：那个月的那一天
PubSelDate = DateAdd("m", nNowMonth, dtFirstDate)
PubSelDate = CDate(Year(PubSelDate) & Str_Fen & Month(PubSelDate) & Str_Fen & strDay)
Rem 恢复其他控件设置
For ln = 0 To 41 '//遍历所有日期按钮
Rem 如果选择的日期是本日，则此按钮被选中
If cmdDay(ln).Caption = strDay And cmdDay(ln).Tag = nNowMonth Then
cmdDay(ln).SetFocus
cmdDay(ln).Font.Bold = True
cmdDay(ln).BackColor = Color_DayNowBackColor1
Else
cmdDay(ln).Font.Bold = False '//不是被选择日期，字体正常
Rem 非本月日期为：灰色
If cmdDay(ln).Tag <> 0 Then
cmdDay(ln).BackColor = Color_DayBackNoMonth
Else
Rem 如果是系统日，字体加粗，底色
If Replace(Replace(cmbYear.Text, "年", ""), "月", "") = CStr(Year(Now)) And Replace(Replace(cmbMonth.Text, "年", ""), "月", "") = CStr(Month(Now)) And cmdDay(ln).Caption = CStr(Day(Now)) Then
cmdDay(ln).Font.Bold = False
cmdDay(ln).BackColor = Color_DayNowBackColor
Else
cmdDay(ln).BackColor = Color_DayBackColor
End If
End If
End If
Next
' If TextFANGSHI.Text = 1 Then
' PubDateControl.Text = Format(PubSelDate, "yyyy-MM-dd")
' Else
ActiveCell.Value = Format(PubSelDate, "yyyy-mm-dd")
' End If
Unload Me '//启用时，去掉注释
End Sub
Private Sub TextFANGSHI_Change()
Rem **********************************************************************************************************使用说明
Rem ***** 单元格调用方法 *******************************************
'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' If Target.Rows.Count = 1 And Target.Columns.Count = 1 Then
' If Target.Row > 3 And Target.Row < 8 And Target.Column = 2 Then
' PubSelDate = Target.Value
' Frm_Riqi.TextFANGSHI.Text = 0 '//只在工作表中,直接将控件text=0
' Frm_Riqi.Show
' End If
' End If
'End Sub
Rem ***** 窗体中调用方法 *******************************************
' Public PubSelDate As Date '//代表已经选择的日期
' Public PubDateControl As Object '//代表日期传送到窗体的控件
' Private Sub UserForm_Initialize()
' Set PubDateControl = Text日期
' End Sub
' Private Sub Text日期_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
'
' If Len(Text日期.Text) >= 8 Then
' Rem 如果日期非空白，则显示指定日期
' PubSelDate = Text日期.Text
' Else
' Rem 如果日期空白，则是今天
' PubSelDate = Date
' End If
' Frm_Riqi.Show
' End Sub
Rem ***** 内置日期函数 *******************************************
Rem 农历和公历假日：GetJiaRi()
Rem 公历日期转农历：GetYLDate()
Rem 农历转公历日期：GetGLDate()
Rem 获得节气： GetJieQi()
End Sub
Private Sub UserForm_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Rem 双击
CommToday_Click
End Sub
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2025-4-13 12:31
楼主