csdn论坛中关于在word中生成日历的问题的解答
2005-10-10 00:12
549 查看
原贴地址http://community.csdn.net/Expert/topic/4304/4304006.xml?temp=.9009668
因为代码比较长所以帖到blog中来，也欢迎大家提意见
曾经将以前在web上看到的一个挺不错的万年历javascript脚本移植到VB，今天再把它移植到VBA上来
运行效果见http://blog.csdn.net/chewinggum/gallery/image/73261.aspx
和http://blog.csdn.net/chewinggum/gallery/image/73262.aspx
下面是完整的宏代码。可以将下面的代码保存成为.bas文件，并在word的VisualBasic编辑器中导入该文件。然后在空白文档中运行Macro1()宏，就可以按照提示生成月历。年份范围1900~2049
Option Explicit
Dim LunarInfo(0 To 149) As Long
Dim SolarMonth
Dim Gan
Dim Zhi
Dim Animals
Dim SolarTerm
Dim sTermInfo
Dim nStr1
Dim nStr2
Dim nStr3
Dim MonthName
Dim sFtv
Dim lFtv
Dim wFtv
Sub Macro1()
Dim InputYear As Integer '输入年
Dim InputMonth As Integer '输入年
Dim intTableRows As Integer '表格的列数
Dim intMonthDays As Integer '该月的天数
Dim intWeekDay As Integer '星期几
Dim intFirstDayWeek As Integer '第一天是星期几
Dim i As Integer
Initialize '初始化数据
InputYear = CInt(InputBox("输入年如 2005:", , "2005"))
InputMonth = CInt(InputBox("输入月如 09:", , "09"))
'计算表格的列数
intMonthDays = SolarDays(InputYear, InputMonth)
intFirstDayWeek = Weekday(InputYear & "-" & InputMonth & "-1")
intTableRows = (intMonthDays + intFirstDayWeek - 1)
If intTableRows / 7 <> Int(intTableRows / 7) Then
intTableRows = Int(intTableRows / 7) + 1
Else
intTableRows = intTableRows / 7
End If
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=intTableRows * 2 + 2, NumColumns:= _
7, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitWindow
Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
Selection.Tables(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Tables(1).LeftPadding = CentimetersToPoints(0.05)
Selection.Tables(1).RightPadding = CentimetersToPoints(0.05)
Selection.Tables(1).Spacing = 0
'生成表头
Selection.Tables(1).Cell(1, 1).Select
Selection.SelectRow
Selection.Cells.Merge
Selection.Cells.Shading.BackgroundPatternColor = wdColorIndigo
Selection.Font.Size = 15
Selection.Font.Color = wdColorWhite
Selection.TypeText "公元" & InputYear & "年" & InputMonth & "月 "
Selection.Font.Color = wdColorYellow
Selection.TypeText "农历 " & cyclical(InputYear) & Animal(InputYear) & "年"
For i = 1 To 7
If i = 1 Or i = 7 Then
Selection.Tables(1).Cell(2, i).Range.Font.Color = wdColorRed
Else
Selection.Tables(1).Cell(2, i).Range.Font.Color = wdColorBlack
End If
Selection.Tables(1).Cell(2, i).Range.Font.Size = 15
Selection.Tables(1).Cell(2, i).Range.Font.Bold = True
Selection.Tables(1).Cell(2, i).Range.Text = nStr1(i - 1)
Selection.Tables(1).Cell(2, i).Shading.BackgroundPatternColor = wdColorYellow
Next
'生成日历
For i = 1 To intMonthDays
Dim intRow As Integer
Dim strDate As String
intWeekDay = Weekday(InputYear & "-" & InputMonth & "-" & i)
intRow = ((intFirstDayWeek + i - 2) / 7 + 1) * 2 + 1 '计算行位置
Dim strTmp As String
Dim lngColor As Long
strTmp = Trim(GetDayString(CDate((InputYear & "-" & InputMonth & "-" & i)), lngColor))
Selection.Tables(1).Cell(intRow, intWeekDay).Select
If intWeekDay = 1 Or intWeekDay = 7 Then
Selection.Font.Color = wdColorRed
ElseIf Left(strTmp, 1) = "*" Then
Selection.Font.Color = wdColorRed
strTmp = Replace(strTmp, "*", "")
Else
Selection.Font.Color = wdColorBlack
End If
Selection.Font.Size = 22
Selection.Font.Name = "Arial Black"
Selection.Font.Bold = True
Selection.TypeText i
Selection.TypeText Chr(11)
If Len(strTmp) > 5 Then
Selection.Font.Size = 8
Else
Selection.Font.Size = 10
End If
Selection.Font.Name = "宋体"
Selection.Font.Color = lngColor
Selection.TypeText strTmp
Next
'以下部分是为了美化输出，如搂住不需要可以将以下部分完全注释掉
With Selection.Tables(1)
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Borders(wdBorderTop).LineStyle = wdLineStyleNone
.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
.Borders(wdBorderVertical).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
.Borders.Shadow = False
End With
'以下部分是按照搂主要求增加一行
' For i = 1 To intMonthDays
' intWeekDay = Weekday(InputYear & "-" & InputMonth & "-" & i)
' intRow = ((intFirstDayWeek + i - 2) / 7 + 1) * 2 + 2 '计算行位置
' Selection.Tables(1).Cell(intRow, intWeekDay).Select
' Selection.TypeText i
' Next
End Sub
'数据初始化
Private Sub Initialize()
Dim strTmp As String
LunarInfo(0) = &H4BD8
LunarInfo(1) = &H4AE0
LunarInfo(2) = &HA570
LunarInfo(3) = &H54D5
LunarInfo(4) = &HD260
LunarInfo(5) = &HD950
LunarInfo(6) = &H16554
LunarInfo(7) = &H56A0
LunarInfo(8) = &H9AD0
LunarInfo(9) = &H55D2
LunarInfo(10) = &H4AE0
LunarInfo(11) = &HA5B6
LunarInfo(12) = &HA4D0
LunarInfo(13) = &HD250
LunarInfo(14) = &H1D255
LunarInfo(15) = &HB540
LunarInfo(16) = &HD6A0
LunarInfo(17) = &HADA2
LunarInfo(18) = &H95B0
LunarInfo(19) = &H14977
LunarInfo(20) = &H4970
LunarInfo(21) = &HA4B0
LunarInfo(22) = &HB4B5
LunarInfo(23) = &H6A50
LunarInfo(24) = &H6D40
LunarInfo(25) = &H1AB54
LunarInfo(26) = &H2B60
LunarInfo(27) = &H9570
LunarInfo(28) = &H52F2
LunarInfo(29) = &H4970
LunarInfo(30) = &H6566
LunarInfo(31) = &HD4A0
LunarInfo(32) = &HEA50
LunarInfo(33) = &H6E95
LunarInfo(34) = &H5AD0
LunarInfo(35) = &H2B60
LunarInfo(36) = &H186E3
LunarInfo(37) = &H92E0
LunarInfo(38) = &H1C8D7
LunarInfo(39) = &HC950
LunarInfo(40) = &HD4A0
LunarInfo(41) = &H1D8A6
LunarInfo(42) = &HB550
LunarInfo(43) = &H56A0
LunarInfo(44) = &H1A5B4
LunarInfo(45) = &H25D0
LunarInfo(46) = &H92D0
LunarInfo(47) = &HD2B2
LunarInfo(48) = &HA950
LunarInfo(49) = &HB557
LunarInfo(50) = &H6CA0
LunarInfo(51) = &HB550
LunarInfo(52) = &H15355
LunarInfo(53) = &H4DA0
LunarInfo(54) = &HA5D0
LunarInfo(55) = &H14573
LunarInfo(56) = &H52D0
LunarInfo(57) = &HA9A8
LunarInfo(58) = &HE950
LunarInfo(59) = &H6AA0
LunarInfo(60) = &HAEA6
LunarInfo(61) = &HAB50
LunarInfo(62) = &H4B60
LunarInfo(63) = &HAAE4
LunarInfo(64) = &HA570
LunarInfo(65) = &H5260
LunarInfo(66) = &HF263
LunarInfo(67) = &HD950
LunarInfo(68) = &H5B57
LunarInfo(69) = &H56A0
LunarInfo(70) = &H96D0
LunarInfo(71) = &H4DD5
LunarInfo(72) = &H4AD0
LunarInfo(73) = &HA4D0
LunarInfo(74) = &HD4D4
LunarInfo(75) = &HD250
LunarInfo(76) = &HD558
LunarInfo(77) = &HB540
LunarInfo(78) = &HB5A0
LunarInfo(79) = &H195A6
LunarInfo(80) = &H95B0
LunarInfo(81) = &H49B0
LunarInfo(82) = &HA974
LunarInfo(83) = &HA4B0
LunarInfo(84) = &HB27A
LunarInfo(85) = &H6A50
LunarInfo(86) = &H6D40
LunarInfo(87) = &HAF46
LunarInfo(88) = &HAB60
LunarInfo(89) = &H9570
LunarInfo(90) = &H4AF5
LunarInfo(91) = &H4970
LunarInfo(92) = &H64B0
LunarInfo(93) = &H74A3
LunarInfo(94) = &HEA50
LunarInfo(95) = &H6B58
LunarInfo(96) = &H55C0
LunarInfo(97) = &HAB60
LunarInfo(98) = &H96D5
LunarInfo(99) = &H92E0
LunarInfo(100) = &HC960
LunarInfo(101) = &HD954
LunarInfo(102) = &HD4A0
LunarInfo(103) = &HDA50
LunarInfo(104) = &H7552
LunarInfo(105) = &H56A0
LunarInfo(106) = &HABB7
LunarInfo(107) = &H25D0
LunarInfo(108) = &H92D0
LunarInfo(109) = &HCAB5
LunarInfo(110) = &HA950
LunarInfo(111) = &HB4A0
LunarInfo(112) = &HBAA4
LunarInfo(113) = &HAD50
LunarInfo(114) = &H55D9
LunarInfo(115) = &H4BA0
LunarInfo(116) = &HA5B0
LunarInfo(117) = &H15176
LunarInfo(118) = &H52B0
LunarInfo(119) = &HA930
LunarInfo(120) = &H7954
LunarInfo(121) = &H6AA0
LunarInfo(122) = &HAD50
LunarInfo(123) = &H5B52
LunarInfo(124) = &H4B60
LunarInfo(125) = &HA6E6
LunarInfo(126) = &HA4E0
LunarInfo(127) = &HD260
LunarInfo(128) = &HEA65
LunarInfo(129) = &HD530
LunarInfo(130) = &H5AA0
LunarInfo(131) = &H76A3
LunarInfo(132) = &H96D0
LunarInfo(133) = &H4BD7
LunarInfo(134) = &H4AD0
LunarInfo(135) = &HA4D0
LunarInfo(136) = &H1D0B6
LunarInfo(137) = &HD250
LunarInfo(138) = &HD520
LunarInfo(139) = &HDD45
LunarInfo(140) = &HB5A0
LunarInfo(141) = &H56D0
LunarInfo(142) = &H55B2
LunarInfo(143) = &H49B0
LunarInfo(144) = &HA577
LunarInfo(145) = &HA4B0
LunarInfo(146) = &HAA50
LunarInfo(147) = &H1B255
LunarInfo(148) = &H6D20
LunarInfo(149) = &HADA0
SolarMonth = Array(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
Gan = Array("甲", "乙", "丙", "丁", "戊", "己", "庚", "辛", "壬", "癸")
Zhi = Array("子", "丑", "寅", "卯", "辰", "巳", "午", "未", "申", "酉", "戌", "亥")
Animals = Array("鼠", "牛", "虎", "兔", "龙", "蛇", "马", "羊", "猴", "鸡", "狗", "猪")
SolarTerm = Array("小寒", "大寒", "立春", "雨水", "惊蛰", "春分", "清明", "谷雨", "立夏", "小满", "芒种", "夏至", "小暑", "大暑", "立秋", "处暑", "白露", "秋分", "寒露", "霜降", "立冬", "小雪", "大雪", "冬至")
sTermInfo = Array(0, 21208, 42467, 63836, 85337, 107014, 128867, 150921, 173149, 195551, 218072, 240693, 263343, 285989, 308563, 331033, 353350, 375494, 397447, 419210, 440795, 462224, 483532, 504758)
nStr1 = Array("日", "一", "二", "三", "四", "五", "六", "七", "八", "九", "十", "十一", "十二")
nStr2 = Array("初", "十", "廿", "卅", " ")
MonthName = Array("JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC")
'国历节日 *表示放假日
strTmp = ""
strTmp = strTmp + "0101*元旦,"
strTmp = strTmp + "0214 情人节,"
strTmp = strTmp + "0305 学雷锋纪念日,"
strTmp = strTmp + "0308 妇女节,"
strTmp = strTmp + "0312 植树节,"
strTmp = strTmp + "0315 消费者权益日,"
strTmp = strTmp + "0401 愚人节,"
strTmp = strTmp + "0407 世界卫生日,"
strTmp = strTmp + "0422 世界地球日,"
strTmp = strTmp + "0501*劳动节,"
strTmp = strTmp + "0502*劳动节,"
strTmp = strTmp + "0503*劳动节,"
strTmp = strTmp + "0504 青年节,"
strTmp = strTmp + "0508 世界红十字日,"
strTmp = strTmp + "0512 国际护士节,"
strTmp = strTmp + "0515 国际家庭日,"
strTmp = strTmp + "0517 国际电信日,"
strTmp = strTmp + "0601 国际儿童节,"
strTmp = strTmp + "0605 世界环境保护日,"
strTmp = strTmp + "0606 全国爱眼日,"
strTmp = strTmp + "0609 口香糖的结婚纪念日,"
strTmp = strTmp + "0625 全国土地日,"
strTmp = strTmp + "0626 国际禁毒日,"
strTmp = strTmp + "0701 香港回归纪念日 中共诞辰,"
strTmp = strTmp + "0707 抗日战争纪念日,"
strTmp = strTmp + "0801 建军节,"
strTmp = strTmp + "0815 抗日战争胜利纪念,"
strTmp = strTmp + "0909 毛泽东逝世纪念,"
strTmp = strTmp + "0908 国际扫盲日,"
strTmp = strTmp + "0910 中国教师节,"
strTmp = strTmp + "0927 世界旅游日,"
strTmp = strTmp + "0928 孔子诞辰,"
strTmp = strTmp + "1001*国庆节,"
strTmp = strTmp + "1002*国庆节,"
strTmp = strTmp + "1003*国庆节,"
strTmp = strTmp + "1006 老人节,"
strTmp = strTmp + "1009 世界邮政日,"
strTmp = strTmp + "1014 世界标准日,"
strTmp = strTmp + "1016 世界粮食日,"
strTmp = strTmp + "1024 联合国日,"
strTmp = strTmp + "1120*彝族年,"
strTmp = strTmp + "1121*彝族年,"
strTmp = strTmp + "1122*彝族年,"
strTmp = strTmp + "1112 孙中山诞辰纪念,"
strTmp = strTmp + "1205 国际志愿人员日,"
strTmp = strTmp + "1220 澳门回归纪念,"
strTmp = strTmp + "1225 Christmas Day,"
strTmp = strTmp + "1226 毛泽东诞辰纪念"
sFtv = Split(strTmp, ",")
'农历节日 *表示放假日
strTmp = ""
strTmp = strTmp + "0101*春节,"
strTmp = strTmp + "0102*春节,"
strTmp = strTmp + "0103*春节,"
strTmp = strTmp + "0115 元宵节,"
strTmp = strTmp + "0505 端午节,"
strTmp = strTmp + "0624*火把节,"
strTmp = strTmp + "0625*火把节,"
strTmp = strTmp + "0626*火把节,"
strTmp = strTmp + "0707 七夕情人节,"
strTmp = strTmp + "0715 中元节,"
strTmp = strTmp + "0815 中秋节,"
strTmp = strTmp + "0909 重阳节,"
strTmp = strTmp + "1208 腊八节,"
strTmp = strTmp + "1224 小年,"
strTmp = strTmp + "0100 除夕"
lFtv = Split(strTmp, ",")
'某月的第几个星期几
strTmp = ""
strTmp = strTmp + "0520 母亲节,"
strTmp = strTmp + "0630 父亲节,"
strTmp = strTmp + "0730 被奴役国家周,"
strTmp = strTmp + "1144 Thanksgiving感恩节"
wFtv = Split(strTmp, ",")
End Sub
'传回农历 y年的总天数
Private Function lYearDays(ByVal Y As Integer) As Integer
Dim i, Sum As Double
Sum = 0
For i = 1 To 12
Sum = Sum + lMonthDays(Y, i)
Next i
lYearDays = Sum + LeapDays(Y)
End Function
'传回农历 y年闰月的天数
Private Function LeapDays(ByVal Y As Integer) As Integer
Dim m As Integer
Dim l As Double
m = LeapMonth(Y)
If m = 0 Then
LeapDays = 0
Else
l = LunarInfo(Y - 1900)
'l = LunarInfo(Y - 1900 + 1)
If l < 0 Then l = l * (-1)
l = (l And &H10000)
If l = 0 Then
LeapDays = 29
Else
LeapDays = 30
End If
End If
End Function
'传回农历 y年闰哪个月 1-12 , 没闰传回 0 OK
Private Function LeapMonth(ByVal Y As Integer) As Integer
LeapMonth = 0
If Y >= 1900 Then LeapMonth = (LunarInfo(Y - 1900) And &HF)
End Function
'传回农历 y年m月的总天数 OK-
Private Function lMonthDays(ByVal Y As Integer, ByVal m As Integer) As Integer
If Y < 1900 Then Y = 1900
If (LunarInfo(Y - 1900) And Int(&H10000 / (2 ^ m))) = 0 Then
'If (LunarInfo(Y - 1900 + 1) And Int(&H10000 / (2 ^ m))) = 0 Then
lMonthDays = 29
Else
lMonthDays = 30
End If
End Function
'根据给定的阳历，返回农历的日期
Private Function GetLunar(ByVal SolarDate As Date) As String
Dim DaysOffset As Long
Dim i As Integer
Dim Temp As Long
Dim lyear, lmonth, lday As Integer
DaysOffset = SolarDate - CDate("1900-1-31")
i = 1900
Do While i < 2050 And DaysOffset >= 0
Temp = lYearDays(i)
DaysOffset = DaysOffset - Temp
i = i + 1
Loop
If DaysOffset < 0 Then
DaysOffset = DaysOffset + Temp
i = i - 1
End If
lyear = i
Dim Leap As Integer
Dim IsLeap As Boolean
Leap = LeapMonth(i)
IsLeap = False
i = 1
Do While i < 13 And DaysOffset > 0
If Leap > 0 And i = (Leap + 1) And IsLeap = False Then
i = i - 1
IsLeap = True
Temp = LeapDays(lyear)
Else
Temp = lMonthDays(lyear, i)
End If
If IsLeap And i = (Leap + 1) Then IsLeap = False
DaysOffset = DaysOffset - Temp
i = i + 1
Loop
If DaysOffset = 0 And Leap > 0 And i = Leap + 1 Then
If IsLeap Then
IsLeap = False
Else
IsLeap = True
i = i - 1
End If
End If
If DaysOffset < 0 Then
DaysOffset = DaysOffset + Temp
i = i - 1
End If
lmonth = i
lday = DaysOffset + 1
'返回特殊标志的字符串
If IsLeap Then
'GetLunar = "0000【" & Animal(lyear) & "】" & cyclical(lyear) & "年闰" & Format(lmonth, "00") & "月" & Format(lday, "00") & "日" & GetTerm(SolarDate)
GetLunar = "1" & lyear & Format(lmonth, "00") & Format(lday, "00")
Else
GetLunar = "0" & lyear & Format(lmonth, "00") & Format(lday, "00")
'GetLunar = Format(lmonth, "00") & Format(lday, "00") & "【" & Animal(lyear) & "】" & cyclical(lyear) & "年" & Format(lmonth, "00") & "月" & Format(lday, "00") & "日 " & GetTerm(SolarDate)
End If
End Function
'传回阳历 y年某m月的天数 OK
Private Function SolarDays(ByVal Y As Integer, ByVal m As Integer) As Integer
If m = 2 Then
If (Y Mod 4 = 0 And Y Mod 100 <> 0) Or (Y Mod 400 = 0) Then
SolarDays = 29
Else
SolarDays = 28
End If
Else
SolarDays = SolarMonth(m - 1)
End If
End Function
'某y年的第n个节气的日期(从0小寒起算) OK
Private Function sTerm(ByVal Y, n As Integer) As Date
Dim D1, D2 As Double
D1 = (31556925.9747 * (Y - 1900) + sTermInfo(n) * 60#)
D2 = DateDiff("s", "1970-1-1 0:0", "1900-1-6 2:5") + D1
D1 = D2 / 2
sTerm = DateAdd("s", D2 - D1, DateAdd("s", D1, "1970-1-1 0:0"))
sTerm = Format(sTerm, "yyyy/mm/dd")
End Function
'根据年份返回属象 OK
Private Function Animal(ByVal sYear As Integer) As String
Animal = Animals((sYear - 1900) Mod 12)
End Function
'根据阳历返回其节气，若不是则返回空 OK
Private Function GetTerm(ByVal sDate As Date) As String
Dim Y, m As Integer
Y = Year(sDate)
m = Month(sDate)
GetTerm = ""
If sTerm(Y, m * 2 - 1) = sDate Then
GetTerm = SolarTerm(m * 2 - 1)
ElseIf sTerm(Y, m * 2 - 2) = sDate Then
GetTerm = SolarTerm(m * 2 - 2)
End If
End Function
'根据阳历返回其节日，若不是则返回空 OK
Private Function GetFeast(ByVal sDate As Date) As String
Dim i As Integer
Dim strTmp As String
strTmp = Format(sDate, "MMDD")
For i = LBound(sFtv) To UBound(sFtv)
If Left(sFtv(i), 4) = strTmp Then
GetFeast = Mid(sFtv(i), 5, Len(sFtv(i)) - 4)
Exit Function
End If
Next
GetFeast = ""
End Function
'根据阴历返回其节日，若不是则返回空 OK
Private Function GetLunarFeast(ByVal sDate As String) As String
Dim i As Integer
Dim strTmp As String
strTmp = Right(sDate, 4)
For i = LBound(lFtv) To UBound(lFtv)
If Left(lFtv(i), 4) = strTmp Then
GetLunarFeast = Mid(lFtv(i), 5, Len(lFtv(i)) - 4)
Exit Function
End If
Next
GetLunarFeast = ""
End Function
'根据阴历返回其字符串 OK
Private Function GetLunarString(ByVal sDate As String) As String
Dim i As Integer
Dim strTmp As String
Dim strMonth As String
Dim strDay As String
strMonth = Left(sDate, 2)
strDay = Right(sDate, 2)
If strDay = "01" Then
GetLunarString = nStr1(Val(strMonth)) & "月"
ElseIf strDay = "20" Then
GetLunarString = "二十"
ElseIf strDay = "30" Then
GetLunarString = "三十"
Else
GetLunarString = nStr2(Val(Left(strDay, 1))) & nStr1(Val(Right(strDay, 1)))
End If
End Function
'返回阳历是该月的第几个星期几的字符串，如:0520表示5月份第2个星期日
Private Function GetMonthWeek(ByVal sDate As Date) As String
Dim D0 As Date
D0 = CDate(Year(sDate) & "-" & Month(sDate) & "-1")
GetMonthWeek = Format(Month(sDate), "00") & (Int((Day(sDate) - 1 + Weekday(D0) - 1) / 7) + 1) & Weekday(sDate) - 1
End Function
'天干地支计算 OK
Private Function cyclical(num) As String
cyclical = Gan((num - 1864) Mod 10) + Zhi((num - 1864) Mod 12)
End Function
'获取农历或节日说明
Private Function GetDayString(ByVal sDate As Date, ByRef lngColor As Long) As String
Dim strLunarDate As String
Dim strTmp As String
strTmp = GetTerm(sDate)
If strTmp <> "" Then GetDayString = strTmp: lngColor = vbGreen: Exit Function
strTmp = GetFeast(sDate)
If strTmp <> "" Then GetDayString = strTmp: lngColor = vbBlue: Exit Function
strLunarDate = GetLunar(sDate)
strTmp = GetLunarFeast(Right(strLunarDate, 4))
If strTmp <> "" Then GetDayString = strTmp: lngColor = vbRed: Exit Function
strTmp = GetLunarString(Right(strLunarDate, 4))
lngColor = vbBlack:
GetDayString = strTmp
End Function
因为代码比较长所以帖到blog中来，也欢迎大家提意见
曾经将以前在web上看到的一个挺不错的万年历javascript脚本移植到VB，今天再把它移植到VBA上来
运行效果见http://blog.csdn.net/chewinggum/gallery/image/73261.aspx
和http://blog.csdn.net/chewinggum/gallery/image/73262.aspx
下面是完整的宏代码。可以将下面的代码保存成为.bas文件，并在word的VisualBasic编辑器中导入该文件。然后在空白文档中运行Macro1()宏，就可以按照提示生成月历。年份范围1900~2049
Option Explicit
Dim LunarInfo(0 To 149) As Long
Dim SolarMonth
Dim Gan
Dim Zhi
Dim Animals
Dim SolarTerm
Dim sTermInfo
Dim nStr1
Dim nStr2
Dim nStr3
Dim MonthName
Dim sFtv
Dim lFtv
Dim wFtv
Sub Macro1()
Dim InputYear As Integer '输入年
Dim InputMonth As Integer '输入年
Dim intTableRows As Integer '表格的列数
Dim intMonthDays As Integer '该月的天数
Dim intWeekDay As Integer '星期几
Dim intFirstDayWeek As Integer '第一天是星期几
Dim i As Integer
Initialize '初始化数据
InputYear = CInt(InputBox("输入年如 2005:", , "2005"))
InputMonth = CInt(InputBox("输入月如 09:", , "09"))
'计算表格的列数
intMonthDays = SolarDays(InputYear, InputMonth)
intFirstDayWeek = Weekday(InputYear & "-" & InputMonth & "-1")
intTableRows = (intMonthDays + intFirstDayWeek - 1)
If intTableRows / 7 <> Int(intTableRows / 7) Then
intTableRows = Int(intTableRows / 7) + 1
Else
intTableRows = intTableRows / 7
End If
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=intTableRows * 2 + 2, NumColumns:= _
7, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitWindow
Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
Selection.Tables(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Tables(1).LeftPadding = CentimetersToPoints(0.05)
Selection.Tables(1).RightPadding = CentimetersToPoints(0.05)
Selection.Tables(1).Spacing = 0
'生成表头
Selection.Tables(1).Cell(1, 1).Select
Selection.SelectRow
Selection.Cells.Merge
Selection.Cells.Shading.BackgroundPatternColor = wdColorIndigo
Selection.Font.Size = 15
Selection.Font.Color = wdColorWhite
Selection.TypeText "公元" & InputYear & "年" & InputMonth & "月 "
Selection.Font.Color = wdColorYellow
Selection.TypeText "农历 " & cyclical(InputYear) & Animal(InputYear) & "年"
For i = 1 To 7
If i = 1 Or i = 7 Then
Selection.Tables(1).Cell(2, i).Range.Font.Color = wdColorRed
Else
Selection.Tables(1).Cell(2, i).Range.Font.Color = wdColorBlack
End If
Selection.Tables(1).Cell(2, i).Range.Font.Size = 15
Selection.Tables(1).Cell(2, i).Range.Font.Bold = True
Selection.Tables(1).Cell(2, i).Range.Text = nStr1(i - 1)
Selection.Tables(1).Cell(2, i).Shading.BackgroundPatternColor = wdColorYellow
Next
'生成日历
For i = 1 To intMonthDays
Dim intRow As Integer
Dim strDate As String
intWeekDay = Weekday(InputYear & "-" & InputMonth & "-" & i)
intRow = ((intFirstDayWeek + i - 2) / 7 + 1) * 2 + 1 '计算行位置
Dim strTmp As String
Dim lngColor As Long
strTmp = Trim(GetDayString(CDate((InputYear & "-" & InputMonth & "-" & i)), lngColor))
Selection.Tables(1).Cell(intRow, intWeekDay).Select
If intWeekDay = 1 Or intWeekDay = 7 Then
Selection.Font.Color = wdColorRed
ElseIf Left(strTmp, 1) = "*" Then
Selection.Font.Color = wdColorRed
strTmp = Replace(strTmp, "*", "")
Else
Selection.Font.Color = wdColorBlack
End If
Selection.Font.Size = 22
Selection.Font.Name = "Arial Black"
Selection.Font.Bold = True
Selection.TypeText i
Selection.TypeText Chr(11)
If Len(strTmp) > 5 Then
Selection.Font.Size = 8
Else
Selection.Font.Size = 10
End If
Selection.Font.Name = "宋体"
Selection.Font.Color = lngColor
Selection.TypeText strTmp
Next
'以下部分是为了美化输出，如搂住不需要可以将以下部分完全注释掉
With Selection.Tables(1)
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Borders(wdBorderTop).LineStyle = wdLineStyleNone
.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
.Borders(wdBorderVertical).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
.Borders.Shadow = False
End With
'以下部分是按照搂主要求增加一行
' For i = 1 To intMonthDays
' intWeekDay = Weekday(InputYear & "-" & InputMonth & "-" & i)
' intRow = ((intFirstDayWeek + i - 2) / 7 + 1) * 2 + 2 '计算行位置
' Selection.Tables(1).Cell(intRow, intWeekDay).Select
' Selection.TypeText i
' Next
End Sub
'数据初始化
Private Sub Initialize()
Dim strTmp As String
LunarInfo(0) = &H4BD8
LunarInfo(1) = &H4AE0
LunarInfo(2) = &HA570
LunarInfo(3) = &H54D5
LunarInfo(4) = &HD260
LunarInfo(5) = &HD950
LunarInfo(6) = &H16554
LunarInfo(7) = &H56A0
LunarInfo(8) = &H9AD0
LunarInfo(9) = &H55D2
LunarInfo(10) = &H4AE0
LunarInfo(11) = &HA5B6
LunarInfo(12) = &HA4D0
LunarInfo(13) = &HD250
LunarInfo(14) = &H1D255
LunarInfo(15) = &HB540
LunarInfo(16) = &HD6A0
LunarInfo(17) = &HADA2
LunarInfo(18) = &H95B0
LunarInfo(19) = &H14977
LunarInfo(20) = &H4970
LunarInfo(21) = &HA4B0
LunarInfo(22) = &HB4B5
LunarInfo(23) = &H6A50
LunarInfo(24) = &H6D40
LunarInfo(25) = &H1AB54
LunarInfo(26) = &H2B60
LunarInfo(27) = &H9570
LunarInfo(28) = &H52F2
LunarInfo(29) = &H4970
LunarInfo(30) = &H6566
LunarInfo(31) = &HD4A0
LunarInfo(32) = &HEA50
LunarInfo(33) = &H6E95
LunarInfo(34) = &H5AD0
LunarInfo(35) = &H2B60
LunarInfo(36) = &H186E3
LunarInfo(37) = &H92E0
LunarInfo(38) = &H1C8D7
LunarInfo(39) = &HC950
LunarInfo(40) = &HD4A0
LunarInfo(41) = &H1D8A6
LunarInfo(42) = &HB550
LunarInfo(43) = &H56A0
LunarInfo(44) = &H1A5B4
LunarInfo(45) = &H25D0
LunarInfo(46) = &H92D0
LunarInfo(47) = &HD2B2
LunarInfo(48) = &HA950
LunarInfo(49) = &HB557
LunarInfo(50) = &H6CA0
LunarInfo(51) = &HB550
LunarInfo(52) = &H15355
LunarInfo(53) = &H4DA0
LunarInfo(54) = &HA5D0
LunarInfo(55) = &H14573
LunarInfo(56) = &H52D0
LunarInfo(57) = &HA9A8
LunarInfo(58) = &HE950
LunarInfo(59) = &H6AA0
LunarInfo(60) = &HAEA6
LunarInfo(61) = &HAB50
LunarInfo(62) = &H4B60
LunarInfo(63) = &HAAE4
LunarInfo(64) = &HA570
LunarInfo(65) = &H5260
LunarInfo(66) = &HF263
LunarInfo(67) = &HD950
LunarInfo(68) = &H5B57
LunarInfo(69) = &H56A0
LunarInfo(70) = &H96D0
LunarInfo(71) = &H4DD5
LunarInfo(72) = &H4AD0
LunarInfo(73) = &HA4D0
LunarInfo(74) = &HD4D4
LunarInfo(75) = &HD250
LunarInfo(76) = &HD558
LunarInfo(77) = &HB540
LunarInfo(78) = &HB5A0
LunarInfo(79) = &H195A6
LunarInfo(80) = &H95B0
LunarInfo(81) = &H49B0
LunarInfo(82) = &HA974
LunarInfo(83) = &HA4B0
LunarInfo(84) = &HB27A
LunarInfo(85) = &H6A50
LunarInfo(86) = &H6D40
LunarInfo(87) = &HAF46
LunarInfo(88) = &HAB60
LunarInfo(89) = &H9570
LunarInfo(90) = &H4AF5
LunarInfo(91) = &H4970
LunarInfo(92) = &H64B0
LunarInfo(93) = &H74A3
LunarInfo(94) = &HEA50
LunarInfo(95) = &H6B58
LunarInfo(96) = &H55C0
LunarInfo(97) = &HAB60
LunarInfo(98) = &H96D5
LunarInfo(99) = &H92E0
LunarInfo(100) = &HC960
LunarInfo(101) = &HD954
LunarInfo(102) = &HD4A0
LunarInfo(103) = &HDA50
LunarInfo(104) = &H7552
LunarInfo(105) = &H56A0
LunarInfo(106) = &HABB7
LunarInfo(107) = &H25D0
LunarInfo(108) = &H92D0
LunarInfo(109) = &HCAB5
LunarInfo(110) = &HA950
LunarInfo(111) = &HB4A0
LunarInfo(112) = &HBAA4
LunarInfo(113) = &HAD50
LunarInfo(114) = &H55D9
LunarInfo(115) = &H4BA0
LunarInfo(116) = &HA5B0
LunarInfo(117) = &H15176
LunarInfo(118) = &H52B0
LunarInfo(119) = &HA930
LunarInfo(120) = &H7954
LunarInfo(121) = &H6AA0
LunarInfo(122) = &HAD50
LunarInfo(123) = &H5B52
LunarInfo(124) = &H4B60
LunarInfo(125) = &HA6E6
LunarInfo(126) = &HA4E0
LunarInfo(127) = &HD260
LunarInfo(128) = &HEA65
LunarInfo(129) = &HD530
LunarInfo(130) = &H5AA0
LunarInfo(131) = &H76A3
LunarInfo(132) = &H96D0
LunarInfo(133) = &H4BD7
LunarInfo(134) = &H4AD0
LunarInfo(135) = &HA4D0
LunarInfo(136) = &H1D0B6
LunarInfo(137) = &HD250
LunarInfo(138) = &HD520
LunarInfo(139) = &HDD45
LunarInfo(140) = &HB5A0
LunarInfo(141) = &H56D0
LunarInfo(142) = &H55B2
LunarInfo(143) = &H49B0
LunarInfo(144) = &HA577
LunarInfo(145) = &HA4B0
LunarInfo(146) = &HAA50
LunarInfo(147) = &H1B255
LunarInfo(148) = &H6D20
LunarInfo(149) = &HADA0
SolarMonth = Array(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
Gan = Array("甲", "乙", "丙", "丁", "戊", "己", "庚", "辛", "壬", "癸")
Zhi = Array("子", "丑", "寅", "卯", "辰", "巳", "午", "未", "申", "酉", "戌", "亥")
Animals = Array("鼠", "牛", "虎", "兔", "龙", "蛇", "马", "羊", "猴", "鸡", "狗", "猪")
SolarTerm = Array("小寒", "大寒", "立春", "雨水", "惊蛰", "春分", "清明", "谷雨", "立夏", "小满", "芒种", "夏至", "小暑", "大暑", "立秋", "处暑", "白露", "秋分", "寒露", "霜降", "立冬", "小雪", "大雪", "冬至")
sTermInfo = Array(0, 21208, 42467, 63836, 85337, 107014, 128867, 150921, 173149, 195551, 218072, 240693, 263343, 285989, 308563, 331033, 353350, 375494, 397447, 419210, 440795, 462224, 483532, 504758)
nStr1 = Array("日", "一", "二", "三", "四", "五", "六", "七", "八", "九", "十", "十一", "十二")
nStr2 = Array("初", "十", "廿", "卅", " ")
MonthName = Array("JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC")
'国历节日 *表示放假日
strTmp = ""
strTmp = strTmp + "0101*元旦,"
strTmp = strTmp + "0214 情人节,"
strTmp = strTmp + "0305 学雷锋纪念日,"
strTmp = strTmp + "0308 妇女节,"
strTmp = strTmp + "0312 植树节,"
strTmp = strTmp + "0315 消费者权益日,"
strTmp = strTmp + "0401 愚人节,"
strTmp = strTmp + "0407 世界卫生日,"
strTmp = strTmp + "0422 世界地球日,"
strTmp = strTmp + "0501*劳动节,"
strTmp = strTmp + "0502*劳动节,"
strTmp = strTmp + "0503*劳动节,"
strTmp = strTmp + "0504 青年节,"
strTmp = strTmp + "0508 世界红十字日,"
strTmp = strTmp + "0512 国际护士节,"
strTmp = strTmp + "0515 国际家庭日,"
strTmp = strTmp + "0517 国际电信日,"
strTmp = strTmp + "0601 国际儿童节,"
strTmp = strTmp + "0605 世界环境保护日,"
strTmp = strTmp + "0606 全国爱眼日,"
strTmp = strTmp + "0609 口香糖的结婚纪念日,"
strTmp = strTmp + "0625 全国土地日,"
strTmp = strTmp + "0626 国际禁毒日,"
strTmp = strTmp + "0701 香港回归纪念日 中共诞辰,"
strTmp = strTmp + "0707 抗日战争纪念日,"
strTmp = strTmp + "0801 建军节,"
strTmp = strTmp + "0815 抗日战争胜利纪念,"
strTmp = strTmp + "0909 毛泽东逝世纪念,"
strTmp = strTmp + "0908 国际扫盲日,"
strTmp = strTmp + "0910 中国教师节,"
strTmp = strTmp + "0927 世界旅游日,"
strTmp = strTmp + "0928 孔子诞辰,"
strTmp = strTmp + "1001*国庆节,"
strTmp = strTmp + "1002*国庆节,"
strTmp = strTmp + "1003*国庆节,"
strTmp = strTmp + "1006 老人节,"
strTmp = strTmp + "1009 世界邮政日,"
strTmp = strTmp + "1014 世界标准日,"
strTmp = strTmp + "1016 世界粮食日,"
strTmp = strTmp + "1024 联合国日,"
strTmp = strTmp + "1120*彝族年,"
strTmp = strTmp + "1121*彝族年,"
strTmp = strTmp + "1122*彝族年,"
strTmp = strTmp + "1112 孙中山诞辰纪念,"
strTmp = strTmp + "1205 国际志愿人员日,"
strTmp = strTmp + "1220 澳门回归纪念,"
strTmp = strTmp + "1225 Christmas Day,"
strTmp = strTmp + "1226 毛泽东诞辰纪念"
sFtv = Split(strTmp, ",")
'农历节日 *表示放假日
strTmp = ""
strTmp = strTmp + "0101*春节,"
strTmp = strTmp + "0102*春节,"
strTmp = strTmp + "0103*春节,"
strTmp = strTmp + "0115 元宵节,"
strTmp = strTmp + "0505 端午节,"
strTmp = strTmp + "0624*火把节,"
strTmp = strTmp + "0625*火把节,"
strTmp = strTmp + "0626*火把节,"
strTmp = strTmp + "0707 七夕情人节,"
strTmp = strTmp + "0715 中元节,"
strTmp = strTmp + "0815 中秋节,"
strTmp = strTmp + "0909 重阳节,"
strTmp = strTmp + "1208 腊八节,"
strTmp = strTmp + "1224 小年,"
strTmp = strTmp + "0100 除夕"
lFtv = Split(strTmp, ",")
'某月的第几个星期几
strTmp = ""
strTmp = strTmp + "0520 母亲节,"
strTmp = strTmp + "0630 父亲节,"
strTmp = strTmp + "0730 被奴役国家周,"
strTmp = strTmp + "1144 Thanksgiving感恩节"
wFtv = Split(strTmp, ",")
End Sub
'传回农历 y年的总天数
Private Function lYearDays(ByVal Y As Integer) As Integer
Dim i, Sum As Double
Sum = 0
For i = 1 To 12
Sum = Sum + lMonthDays(Y, i)
Next i
lYearDays = Sum + LeapDays(Y)
End Function
'传回农历 y年闰月的天数
Private Function LeapDays(ByVal Y As Integer) As Integer
Dim m As Integer
Dim l As Double
m = LeapMonth(Y)
If m = 0 Then
LeapDays = 0
Else
l = LunarInfo(Y - 1900)
'l = LunarInfo(Y - 1900 + 1)
If l < 0 Then l = l * (-1)
l = (l And &H10000)
If l = 0 Then
LeapDays = 29
Else
LeapDays = 30
End If
End If
End Function
'传回农历 y年闰哪个月 1-12 , 没闰传回 0 OK
Private Function LeapMonth(ByVal Y As Integer) As Integer
LeapMonth = 0
If Y >= 1900 Then LeapMonth = (LunarInfo(Y - 1900) And &HF)
End Function
'传回农历 y年m月的总天数 OK-
Private Function lMonthDays(ByVal Y As Integer, ByVal m As Integer) As Integer
If Y < 1900 Then Y = 1900
If (LunarInfo(Y - 1900) And Int(&H10000 / (2 ^ m))) = 0 Then
'If (LunarInfo(Y - 1900 + 1) And Int(&H10000 / (2 ^ m))) = 0 Then
lMonthDays = 29
Else
lMonthDays = 30
End If
End Function
'根据给定的阳历，返回农历的日期
Private Function GetLunar(ByVal SolarDate As Date) As String
Dim DaysOffset As Long
Dim i As Integer
Dim Temp As Long
Dim lyear, lmonth, lday As Integer
DaysOffset = SolarDate - CDate("1900-1-31")
i = 1900
Do While i < 2050 And DaysOffset >= 0
Temp = lYearDays(i)
DaysOffset = DaysOffset - Temp
i = i + 1
Loop
If DaysOffset < 0 Then
DaysOffset = DaysOffset + Temp
i = i - 1
End If
lyear = i
Dim Leap As Integer
Dim IsLeap As Boolean
Leap = LeapMonth(i)
IsLeap = False
i = 1
Do While i < 13 And DaysOffset > 0
If Leap > 0 And i = (Leap + 1) And IsLeap = False Then
i = i - 1
IsLeap = True
Temp = LeapDays(lyear)
Else
Temp = lMonthDays(lyear, i)
End If
If IsLeap And i = (Leap + 1) Then IsLeap = False
DaysOffset = DaysOffset - Temp
i = i + 1
Loop
If DaysOffset = 0 And Leap > 0 And i = Leap + 1 Then
If IsLeap Then
IsLeap = False
Else
IsLeap = True
i = i - 1
End If
End If
If DaysOffset < 0 Then
DaysOffset = DaysOffset + Temp
i = i - 1
End If
lmonth = i
lday = DaysOffset + 1
'返回特殊标志的字符串
If IsLeap Then
'GetLunar = "0000【" & Animal(lyear) & "】" & cyclical(lyear) & "年闰" & Format(lmonth, "00") & "月" & Format(lday, "00") & "日" & GetTerm(SolarDate)
GetLunar = "1" & lyear & Format(lmonth, "00") & Format(lday, "00")
Else
GetLunar = "0" & lyear & Format(lmonth, "00") & Format(lday, "00")
'GetLunar = Format(lmonth, "00") & Format(lday, "00") & "【" & Animal(lyear) & "】" & cyclical(lyear) & "年" & Format(lmonth, "00") & "月" & Format(lday, "00") & "日 " & GetTerm(SolarDate)
End If
End Function
'传回阳历 y年某m月的天数 OK
Private Function SolarDays(ByVal Y As Integer, ByVal m As Integer) As Integer
If m = 2 Then
If (Y Mod 4 = 0 And Y Mod 100 <> 0) Or (Y Mod 400 = 0) Then
SolarDays = 29
Else
SolarDays = 28
End If
Else
SolarDays = SolarMonth(m - 1)
End If
End Function
'某y年的第n个节气的日期(从0小寒起算) OK
Private Function sTerm(ByVal Y, n As Integer) As Date
Dim D1, D2 As Double
D1 = (31556925.9747 * (Y - 1900) + sTermInfo(n) * 60#)
D2 = DateDiff("s", "1970-1-1 0:0", "1900-1-6 2:5") + D1
D1 = D2 / 2
sTerm = DateAdd("s", D2 - D1, DateAdd("s", D1, "1970-1-1 0:0"))
sTerm = Format(sTerm, "yyyy/mm/dd")
End Function
'根据年份返回属象 OK
Private Function Animal(ByVal sYear As Integer) As String
Animal = Animals((sYear - 1900) Mod 12)
End Function
'根据阳历返回其节气，若不是则返回空 OK
Private Function GetTerm(ByVal sDate As Date) As String
Dim Y, m As Integer
Y = Year(sDate)
m = Month(sDate)
GetTerm = ""
If sTerm(Y, m * 2 - 1) = sDate Then
GetTerm = SolarTerm(m * 2 - 1)
ElseIf sTerm(Y, m * 2 - 2) = sDate Then
GetTerm = SolarTerm(m * 2 - 2)
End If
End Function
'根据阳历返回其节日，若不是则返回空 OK
Private Function GetFeast(ByVal sDate As Date) As String
Dim i As Integer
Dim strTmp As String
strTmp = Format(sDate, "MMDD")
For i = LBound(sFtv) To UBound(sFtv)
If Left(sFtv(i), 4) = strTmp Then
GetFeast = Mid(sFtv(i), 5, Len(sFtv(i)) - 4)
Exit Function
End If
Next
GetFeast = ""
End Function
'根据阴历返回其节日，若不是则返回空 OK
Private Function GetLunarFeast(ByVal sDate As String) As String
Dim i As Integer
Dim strTmp As String
strTmp = Right(sDate, 4)
For i = LBound(lFtv) To UBound(lFtv)
If Left(lFtv(i), 4) = strTmp Then
GetLunarFeast = Mid(lFtv(i), 5, Len(lFtv(i)) - 4)
Exit Function
End If
Next
GetLunarFeast = ""
End Function
'根据阴历返回其字符串 OK
Private Function GetLunarString(ByVal sDate As String) As String
Dim i As Integer
Dim strTmp As String
Dim strMonth As String
Dim strDay As String
strMonth = Left(sDate, 2)
strDay = Right(sDate, 2)
If strDay = "01" Then
GetLunarString = nStr1(Val(strMonth)) & "月"
ElseIf strDay = "20" Then
GetLunarString = "二十"
ElseIf strDay = "30" Then
GetLunarString = "三十"
Else
GetLunarString = nStr2(Val(Left(strDay, 1))) & nStr1(Val(Right(strDay, 1)))
End If
End Function
'返回阳历是该月的第几个星期几的字符串，如:0520表示5月份第2个星期日
Private Function GetMonthWeek(ByVal sDate As Date) As String
Dim D0 As Date
D0 = CDate(Year(sDate) & "-" & Month(sDate) & "-1")
GetMonthWeek = Format(Month(sDate), "00") & (Int((Day(sDate) - 1 + Weekday(D0) - 1) / 7) + 1) & Weekday(sDate) - 1
End Function
'天干地支计算 OK
Private Function cyclical(num) As String
cyclical = Gan((num - 1864) Mod 10) + Zhi((num - 1864) Mod 12)
End Function
'获取农历或节日说明
Private Function GetDayString(ByVal sDate As Date, ByRef lngColor As Long) As String
Dim strLunarDate As String
Dim strTmp As String
strTmp = GetTerm(sDate)
If strTmp <> "" Then GetDayString = strTmp: lngColor = vbGreen: Exit Function
strTmp = GetFeast(sDate)
If strTmp <> "" Then GetDayString = strTmp: lngColor = vbBlue: Exit Function
strLunarDate = GetLunar(sDate)
strTmp = GetLunarFeast(Right(strLunarDate, 4))
If strTmp <> "" Then GetDayString = strTmp: lngColor = vbRed: Exit Function
strTmp = GetLunarString(Right(strLunarDate, 4))
lngColor = vbBlack:
GetDayString = strTmp
End Function
内容来自用户分享和网络整理，不保证内容的准确性，如有侵权内容，可联系管理员处理 
相关文章推荐
- 【CSDN常见问题解答】Web上传图片生成指定大小图片
- 关于phpword生成word所出现的一个比较常见的问题。
- 关于csdn论坛将1-20 的数字乱序,解答(2)
- 关于csdn论坛登录的问题!
- 关于csdn论坛将1-20 的数字乱序,我的个人解答
- 关于CSDN博客文章个数不更新的相关问题解答
- 关于用html语言生成word格式文档的视图问题
- #菜鸟新手EclipseJavaEE&MySQL&Tomcat#关于一个Eclipse中登陆界面通过连接MySQL数据库进行验证的小体验(感谢qq群友引燃的解答让我解决这个小问题)
- 关于tinker自动生成application失败的问题
- 关于Freemarker生成静态html文件及中文乱码的问题
- 关于【源文件与模块生成时的文件不同】问题的解决
- Word中关于Table的alt text的编程问题
- 【转】关于“手动重新生成注册表性能计数器”的问题
- 关于数组以及函数的一些问题与解答
- 【CSDN常见问题解答】Java多种数据库连接
- 完美解决关于php gd生成中文字符乱码的问题
- 关于csdn博客的一个小问题
- 关于java调用了windows的api函数的问题解答
- 关于csdn博客的一个小问题
- 关于指针的十个问题的解答