Foxtable(狐表) → 用户栏目 → 专家坐堂 → [讨论]农历日历代码完善


  共有6016人关注过本帖树形打印复制链接

主题：[讨论]农历日历代码完善
帅哥哟，离线，有人找我吗？
thz706
 小大  1楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：童狐 帖子：261 积分：2017 威望：0 精华：0 注册：2017/11/21 15:01:00 		[讨论]农历日历代码完善  发帖心情 Post By：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编辑过]
 回到顶部
帅哥，在线噢！
有点蓝
 小大  2楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：超级版主 帖子：110572 积分：562750 威望：0 精华：9 注册：2015/6/24 9:21:00 		  发帖心情 Post By：2020/6/11 16:25:00 [只看该作者]

多谢分享。随便测试了几个日期，是准的

 回到顶部
帅哥哟，离线，有人找我吗？
873773115
 小大  3楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：小狐 帖子：314 积分：2881 威望：0 精华：0 注册：2017/11/5 13:39:00 		  发帖心情 Post By：2021/8/26 16:46:00 [只看该作者]

感谢大佬！

 回到顶部
帅哥哟，离线，有人找我吗？
rongping
 小大  4楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：小狐 帖子：372 积分：3193 威望：0 精华：0 注册：2018/3/15 16:46:00 		  发帖心情 Post By：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变量。 以及可以返回节气的农历日。
 回到顶部
帅哥，在线噢！
cd_tdh
 小大  5楼 | QQ | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：狐精 帖子：3205 积分：21299 威望：0 精华：0 注册：2016/3/28 16:57:00 		  发帖心情 Post By：2023/4/7 8:33:00 [只看该作者]

怎么用啊？

 回到顶部
RSS2.0 | Xhtml无图版 | Xslt无图版 Copyright © 2000 - 2018 foxtable.com Tel: 4000-810-820 粤ICP备11091905号
   Powered By Dvbbs Version 8.3.0
页面执行时间 0.05078 秒, 4 次数据查询