-- 作者:thz706
-- 发布时间:2020/6/11 16:10:00
-- [讨论]农历日历代码完善
\'对论坛中的农历日历做了修正和完善。
\'譬如,2020-6-11,原代码显示为闰五月,其实是闰四月。又如,原代码2020-1-1,是庚子年腊月初七,其实是乙亥年腊月初七。 若有错误,还请指出和谅解。
Dim d As Date = args(0)
Dim out As String Dim str,str1 As String Dim
y,m,d1 As Integer y = d.year m = d.Month d1 = d.day
\'天干地支农历年 Dim y1 As String = d.Year
\'\'\'\'修正y1 Dim nstart As New Lunar(d.Year,1,1,False) Dim td1 As Date = nstart.SolarDate If d < td1 Then y1 = y1 -1 End If
Dim Tg As String = "庚|辛|壬|癸|甲|乙|丙|丁|戊|己" Dim Tgs() As String Tgs =
Tg.split("|") Dim Dz As String = "申|酉|戌|亥|子|丑|寅|卯|辰|巳|午|未" Dim Dzs() As
String Dzs = DZ.split("|") Dim Sx As String =
"猴|鸡|狗|猪|鼠|牛|虎|兔|龙|蛇|马|羊|" Dim Sxs() As String Sxs =
Sx.split("|") \'农历月日 Dim nl As New Lunar(d) Dim Month As String =
"正|二|三|四|五|六|七|八|九|十|冬|腊" Dim Months() As String Months =
Month.split("|")
If nl.IsLeapYear Then If nl.LeapMonth = nl.Month Then str =
"闰" & Months(nl.LeapMonth -2) ElseIf nl.Month < nl.LeapMonth
Then str = Months(nl.Month - 1 ) Else str =
Months(nl.Month -2) End If Else str = Months(nl.Month -1) End
If
Dim Multi As String = "|初一|初二|初三|初四|初五|初六|初七|初八|初九|初十|十一|十二|十三|十四|" Multi
= Multi & "十五|十六|十七|十八|十九|廿十|廿一|廿二|廿三|廿四|廿五|廿六|廿七|廿八|廿九|卅十" Dim Values()
As String Values = Multi.split("|")
\'二十四节气 Dim Jq As String =
"|小寒|大寒|立春|雨水|惊蛰|春分|清明|谷雨|立夏|小满|芒种|夏至|小暑|大暑|立秋|处暑|白露|秋分|寒露|霜降|立冬|小雪|大雪|冬至" Dim
Jqs() As String Jqs = Jq.split("|") Select Case m Case 1
If d1<15 Then str1 =
int(y*0.2422+iif(y<2000,5.93,6.0055)+iif(y=1982,1,0)-iif(y=2019,1,0)-int((y-1)/4)+int((y-1)/100)-int((y-1)/400)*iif(y>0,1,0))
Else str1 =
int(y*0.2422+iif(y<2000,20.66,20.72)+iif(y=2082,1,0)-int((y-1)/4)+int((y-1)/100)-int((y-1)/400)*iif(y>0,1,0))
End If Case 2 If d1<15 Then str1 =
int(1211/5000*y+(1593+20*int(y/1900)+20*int(y/1980)+20*int(y/2100)+20*int(y/2220))/365)-int((y-1)/4)+int((y-1)/100)-int((y-1)/400)+int((y-1)/3200)
Else str1 =
int(0.2422*y+iif(y>2000,19.32,19.28)+iif(y=2026,-1,0)+iif(y=1923,-1,0))-int((y-1)/4)+int((y-1)/100)-int((y-1)/400)*iif(y>0,1,0)
End If Case 3 If d1<15 Then str1 =
int(0.2422*y+iif(y>1978,6.232,6.186))-int(y/4)+int(y/100)-int(y/400)*iif(y>0,1,0)
Else str1 =
int(y*0.2422+21.2477)-int(y/4)+int(y/100)-int(y/400)+IIF(y=2084,1,0)
End If Case 4 If d1<15 Then str1 =
int(y*0.2422+5.41)-int(y/4)+int(y/100)-int(y/400) Else
str1 =
int(y*0.2422+iif(y<2000,20.708,20.7))-int(y/4)+int(y/100)-int(y/400)
End If Case 5 If d1<15 Then str1 =
int(y*0.2422+iif(y<2000,6.138,6.12))+iif(y=1911,1,0)-int(y/4)+int(y/100)-int(y/400)
Else str1 =
int(y*0.2422+iif(y<2000,21.68,21.64))+iif(y=2008,1,0)-int(y/4)+int(y/100)-int(y/400)
End If Case 6 If d1<15 Then str1 =
int(y*0.2422+iif(y<2000,6.32,6.278))+iif(y=1902,1,0)-int(y/4)+int(y/100)-int(y/400)
Else str1 =
int(y*0.2422+iif(y<2000,22.02,21.97))+iif(y=1928,1,0)-int(y/4)+int(y/100)-int(y/400)
End If Case 7 If d1<15 Then str1 =
int(y*0.2422+iif(y<2000,7.748,7.708))+iif(y=1925,1,0)+iif(y=2016,1,0)-int(y/4)+int(y/100)-int(y/400)
Else str1 =
int(y*0.2422+iif(y<2000,23.47,23.43))+iif(y=1922,1,0)-int(y/4)+int(y/100)-int(y/400)
End If Case 8 If d1<15 Then str1 =
int(y*0.2422+iif(y<
2000,8.17,8.1))+iif(y<2002,1,0)-int(y/4)+int(y/100)-int(y/400)
Else str1 =
int(y*0.2422+iif(y<2000,23.77,23.73))-int(y/4)+int(y/100)-int(y/400)
End If Case 9 If d1<15 Then str1 =
int(y*0.2422+iif(y<2000,8.26,8.246))+iif(y=1927,1,0)-int(y/4)+int(y/100)-int(y/400)
Else str1 =
int(y*0.2422+23.6459)-int(y/4)+int(y/100)-int(y/400)+iif(y=1942,1,0)
End If Case 10 If d1<15 Then str1 =
int(y*0.2422+8.918)-int(y/4)+int(y/100)-int(y/400)
Else str1 =
int(y*0.2422+24.038)+iif(y=2089,1,0)-int(y/4)+int(y/100)-int(y/400)
End If Case 11 If d1<15 Then str1 =
int(y*0.2422+8.038)+iif(y=2089,1,0)-int(y/4)+int(y/100)-int(y/400)
Else str1 =
int(y*0.2422+iif(y<2000,22.9,22.96))+iif(y=1978,1,0)-int(y/4)+int(y/100)-int(y/400)
End If Case 12 If d1<15 Then str1 =
int(y*0.2422+iif(y<2000,7.72,7.78))+iif(y=1954,1,0)-int(y/4)+int(y/100)-int(y/400)
Else str1 =
int(y*0.2422+iif(y<2000,22.48,22.54))+iif(y=1918,-1,0)+iif(y=2021,-1,0)-int(y/4)+int(y/100)-int(y/400)
End If End Select If d1 = str1 Then out = Tgs(y1.SubString(3))
& Dzs(y1 Mod 12) & "年【" & Sxs(y1 Mod 12) & "年】 " & str &
"月" & Jqs(m*2-iif(d1<15,1,0)) Else out = Tgs(y1.SubString(3))
& Dzs(y1 Mod 12) & "年【" & Sxs(y1 Mod 12) & "年】 " & str &
"月" & Values(nl.Day) End If
Return out
[此贴子已经被作者于2020/6/11 16:21:17编辑过]
|
-- 作者:rongping
-- 发布时间:2022/5/10 21:41:00
--
以下是引用thz706在2020/6/11 16:10:00的发言:
\'对论坛中的农历日历做了修正和完善。
\'譬如,2020-6-11,原代码显示为闰五月,其实是闰四月。又如,原代码2020-1-1,是庚子年腊月初七,其实是乙亥年腊月初七。
若有错误,还请指出和谅解。
Dim d As Date = args(0)
Dim out As String
Dim str,str1 As String Dim y,m,d1 As Integer y = d.year m = d.Month d1 = d.day
\'天干地支农历年 Dim y1 As String = d.Year
\'\'\'\'修正y1 Dim nstart As New Lunar(d.Year,1,1,False) Dim td1 As Date = nstart.SolarDate If d < td1 Then y1 = y1 -1 End If
Dim Tg As String = "庚|辛|壬|癸|甲|乙|丙|丁|戊|己" Dim Tgs() As String Tgs = Tg.split("|") Dim Dz As String = "申|酉|戌|亥|子|丑|寅|卯|辰|巳|午|未" Dim Dzs() As String Dzs = DZ.split("|") Dim Sx As String = "猴|鸡|狗|猪|鼠|牛|虎|兔|龙|蛇|马|羊|" Dim Sxs() As String Sxs = Sx.split("|") \'农历月日 Dim nl As New Lunar(d) Dim Month As String = "正|二|三|四|五|六|七|八|九|十|冬|腊" Dim Months() As String Months = Month.split("|")
If nl.IsLeapYear Then If nl.LeapMonth = nl.Month Then str = "闰" & Months(nl.LeapMonth -2) ElseIf nl.Month < nl.LeapMonth Then str = Months(nl.Month - 1 ) Else str = Months(nl.Month -2) End If Else str = Months(nl.Month -1) End If
Dim Multi As String = "|初一|初二|初三|初四|初五|初六|初七|初八|初九|初十|十一|十二|十三|十四|" Multi = Multi & "十五|十六|十七|十八|十九|廿十|廿一|廿二|廿三|廿四|廿五|廿六|廿七|廿八|廿九|卅十" Dim Values() As String Values = Multi.split("|")
\'二十四节气 Dim Jq As String = "|小寒|大寒|立春|雨水|惊蛰|春分|清明|谷雨|立夏|小满|芒种|夏至|小暑|大暑|立秋|处暑|白露|秋分|寒露|霜降|立冬|小雪|大雪|冬至" Dim Jqs() As String Jqs = Jq.split("|") Select Case m Case 1 If d1<15 Then str1 = int(y*0.2422+iif(y<2000,5.93,6.0055)+iif(y=1982,1,0)-iif(y=2019,1,0)-int((y-1)/4)+int((y-1)/100)-int((y-1)/400)*iif(y>0,1,0)) Else str1 = int(y*0.2422+iif(y<2000,20.66,20.72)+iif(y=2082,1,0)-int((y-1)/4)+int((y-1)/100)-int((y-1)/400)*iif(y>0,1,0)) End If Case 2 If d1<15 Then str1 = int(1211/5000*y+(1593+20*int(y/1900)+20*int(y/1980)+20*int(y/2100)+20*int(y/2220))/365)-int((y-1)/4)+int((y-1)/100)-int((y-1)/400)+int((y-1)/3200) Else str1 = int(0.2422*y+iif(y>2000,19.32,19.28)+iif(y=2026,-1,0)+iif(y=1923,-1,0))-int((y-1)/4)+int((y-1)/100)-int((y-1)/400)*iif(y>0,1,0) End If Case 3 If d1<15 Then str1 = int(0.2422*y+iif(y>1978,6.232,6.186))-int(y/4)+int(y/100)-int(y/400)*iif(y>0,1,0) Else str1 = int(y*0.2422+21.2477)-int(y/4)+int(y/100)-int(y/400)+IIF(y=2084,1,0) End If Case 4 If d1<15 Then str1 = int(y*0.2422+5.41)-int(y/4)+int(y/100)-int(y/400) Else str1 = int(y*0.2422+iif(y<2000,20.708,20.7))-int(y/4)+int(y/100)-int(y/400) End If Case 5 If d1<15 Then str1 = int(y*0.2422+iif(y<2000,6.138,6.12))+iif(y=1911,1,0)-int(y/4)+int(y/100)-int(y/400) Else str1 = int(y*0.2422+iif(y<2000,21.68,21.64))+iif(y=2008,1,0)-int(y/4)+int(y/100)-int(y/400) End If Case 6 If d1<15 Then str1 = int(y*0.2422+iif(y<2000,6.32,6.278))+iif(y=1902,1,0)-int(y/4)+int(y/100)-int(y/400) Else str1 = int(y*0.2422+iif(y<2000,22.02,21.97))+iif(y=1928,1,0)-int(y/4)+int(y/100)-int(y/400) End If Case 7 If d1<15 Then str1 = int(y*0.2422+iif(y<2000,7.748,7.708))+iif(y=1925,1,0)+iif(y=2016,1,0)-int(y/4)+int(y/100)-int(y/400) Else str1 = int(y*0.2422+iif(y<2000,23.47,23.43))+iif(y=1922,1,0)-int(y/4)+int(y/100)-int(y/400) End If Case 8 If d1<15 Then str1 = int(y*0.2422+iif(y< 2000,8.17,8.1))+iif(y<2002,1,0)-int(y/4)+int(y/100)-int(y/400) Else str1 = int(y*0.2422+iif(y<2000,23.77,23.73))-int(y/4)+int(y/100)-int(y/400) End If Case 9 If d1<15 Then str1 = int(y*0.2422+iif(y<2000,8.26,8.246))+iif(y=1927,1,0)-int(y/4)+int(y/100)-int(y/400) Else str1 = int(y*0.2422+23.6459)-int(y/4)+int(y/100)-int(y/400)+iif(y=1942,1,0) End If Case 10 If d1<15 Then str1 = int(y*0.2422+8.918)-int(y/4)+int(y/100)-int(y/400) Else str1 = int(y*0.2422+24.038)+iif(y=2089,1,0)-int(y/4)+int(y/100)-int(y/400) End If Case 11 If d1<15 Then str1 = int(y*0.2422+8.038)+iif(y=2089,1,0)-int(y/4)+int(y/100)-int(y/400) Else str1 = int(y*0.2422+iif(y<2000,22.9,22.96))+iif(y=1978,1,0)-int(y/4)+int(y/100)-int(y/400) End If Case 12 If d1<15 Then str1 = int(y*0.2422+iif(y<2000,7.72,7.78))+iif(y=1954,1,0)-int(y/4)+int(y/100)-int(y/400) Else str1 = int(y*0.2422+iif(y<2000,22.48,22.54))+iif(y=1918,-1,0)+iif(y=2021,-1,0)-int(y/4)+int(y/100)-int(y/400) End If End Select If d1 = str1 Then out = Tgs(y1.SubString(3)) & Dzs(y1 Mod 12) & "年【" & Sxs(y1 Mod 12) & "年】 " & str & "月" & Jqs(m*2-iif(d1<15,1,0)) Else out = Tgs(y1.SubString(3)) & Dzs(y1 Mod 12) & "年【" & Sxs(y1 Mod 12) & "年】 " & str & "月" & Values(nl.Day) End If
Return out
[此贴子已经被作者于2020/6/11 16:21:17编辑过] 问一下,您这个函数能不能帮忙改一下,可以返回农历年,农历月,农历日,是integer变量。 以及可以返回节气的农历日。
|