[FUNC]纠正公农历转换的VB代码

前端之家收集整理的这篇文章主要介绍了[FUNC]纠正公农历转换的VB代码前端之家小编觉得挺不错的,现在分享给大家,也给大家做个参考。

VBA脚本参考


  1. 'Overall Correction by VBAdvisor on 7/July/2007
  2. 'I will keep update once I catch any more mistakes.
  3. '1955-5-21 mistake is due to wrong initial value 457037C,change to 457137C
  4. '1989-8-1 mistake is due to wrong initial value 93700CE,change to 95700CE
  5. '2013-6-8 mistake is due to wrong initial value B5500D2,change to AD500D2
  6. '1916-3-1 mistake is due to wrong initial value 56A00CC,change to D6A00CB
  7. '1920-12-1 mistake is due to wrong initial value 49B00DC,change to 49700DC
  8. '2025-5-1 mistake is due to wrong initial value 96E0681,change to A6E0681
  9. '2033-9-1 mistake is due to wrong initial value 4AB0B83,change to 4AF0B83
  10. 'Lunar date 1915 has an invalid initial value B5500D6,change to B5400D6
  11. 'Lunar date 2065 has an invalid initial value DA400CD,change to DA500CD
  12. 'Lunar date 2068 has an invalid initial value A6C00CB,change to A6D00CB 2069-1-22
  13. 'Lunar date 2079-1-21 has an invalid initial value 52B00CA,change to 62B00CA
  14. 'Lunar date 2078 has an invalid initial value A5A00D4,change to A5B00D4
  15.  
  16. '农历常量(1899~2100,共202年)
  17. Private Const LunarTable = "AB500D2,4BD0883," _
  18. & "4AE00DB,A5700D0,54D0581,D2600D8,D9500CC,655147D,56A00D5,9AD00CA,55D027A,4AE00D2," _
  19. & "A5B0682,A4D00DA,D2500CE,D25157E,B5400D6,D6A00CB,ADA027B,95B00D3,49717C9,49700DC," _
  20. & "A4B00D0,B4B0580,6A500D8,6D400CD,AB5147C,2B600D5,95700CA,52F027B,49700D2,6560682," _
  21. & "D4A00D9,EA500CE,6A9157E,5AD00D6,2B600CC,86E137C,92E00D3,C8D1783,C9500DB,D4A00D0," _
  22. & "D8A167F,B5500D7,56A00CD,A5B147D,25D00D5,92D00CA,D2B027A,A9500D2,B550781,6CA00D9," _
  23. & "B5500CE,535157F,4DA00D6,A5B00CB,457137C,52B00D4,A9A0883,E9500DA,6AA00D0,AEA0680," _
  24. & "AB500D7,4B600CD,AAE047D,A5700D5,52600CA,F260379,D9500D1,5B50782,56A00D9,96D00CE," _
  25. & "4DD057F,4AD00D7,A4D00CB,D4D047B,D2500D3,D550883,B5400DA,B6A00CF,95A1680,95B00D8," _
  26. & "49B00CD,A97047D,A4B00D5,B270ACA,6A500DC,6D400D1,AF40681,AB600D9,95700CE,4AF057F," _
  27. & "49700D7,64B00CC,74A037B,EA500D2,6B50883,5AC00DB,AB600CF,96D0580,92E00D8,C9600CD," _
  28. & "D95047C,D4A00D4,DA500C9,755027A,56A00D1,ABB0781,25D00DA,92D00CF,CAB057E,A9500D6," _
  29. & "B4A00CB,BAA047B,AD500D2,55D0983,4BA00DB,A5B00D0,5171680,52B00D8,A9300CD,795047D," _
  30. & "6AA00D4,AD500C9,5B5027A,4B600D2,A6E0681,A4E00D9,D2600CE,EA6057E,D5300D5,5AA00CB," _
  31. & "76A037B,96D00D3,4AF0B83,4AD00DB,A4D00D0,D0B1680,D2500D7,D5200CC,DD4057C,B5A00D4," _
  32. & "56D00C9,55B027A,49B00D2,A570782,A4B00D9,AA500CE,B25157E,6D200D6,ADA00CA,4B6137B," _
  33. & "93700D3,49F08C9,49700DB,64B00D0,68A1680,EA500D7,6AA00CC,A6C147C,AAE00D4,92E00CA," _
  34. & "D2E0379,C9600D1,D550781,D4A00D9,DA500CD,5D5057E,56A00D6,A6D00CB,55D047B,52D00D3," _
  35. & "A9B0883,A9500DB,B4A00CF,B6A067F,AD500D7,55A00CD,ABA047C,A5B00D4,62B00CA,B27037A," _
  36. & "69300D1,7330781,6AA00D9,AD500CE,4B5157E,4B600D6,A5700CB,54E047C,D1600D2,E960882," _
  37. & "D5200DA,DAA00CF,6AA167F,56D00D7,4AE00CD,A9D047D,A2D00D4,D1500C9,F250279,D5200D1"

AutoHotkey移植公历转农历函数代码如下(作者:海盗):

  1. /*
  2. 公历转农历:
  3. 输入公历,输出农历
  4. 农历(天干地支属相日期):=Date_GetLunarDate(公历日期 YYYYMMDD)
  5. */
  6. Date_GetLunarDate(Gregorian)
  7. {
  8. ;1899年~2100年农历数据
  9. ;前三位,Hex,转Bin,表示当年月份,1为大月,0为小月
  10. ;第四位,Dec,表示闰月天数,1为大月30天,0为小月29
  11. ;第五位,Hex,转Dec,表示是否闰月,0为不闰,否则为闰月月份
  12. ;倒数第三位是农历闰几月,直接读取。
  13. ;倒数第四位也即正数第四位,是闰月天数,1为大 30天, 0为小29天。
  14. ;举例2017年的5171680的前3517,转成二进制010100010111,表示当年1-12月大小情况。第56,第41 表示2017年闰六月 大。
  15. ;测试用例:20170920 输出八月初一
  16. ;测试用例:20330828 输出八月初四
  17. ;农历常量(1899~2100,共202年)
  18. ;I will keep update once I catch any more mistakes.
  19. ;1955-5-21 mistake is due to wrong initial value 457037C,change to 457137C
  20. ;1989-8-1 mistake is due to wrong initial value 93700CE,change to 95700CE
  21. ;2013-6-8 mistake is due to wrong initial value B5500D2,change to AD500D2
  22.  
  23. ;1916-3-1 mistake is due to wrong initial value 56A00CC,change to D6A00CB
  24. ;1920-12-1 mistake is due to wrong initial value 49B00DC,change to 49700DC
  25. ;2025-5-1 mistake is due to wrong initial value 96E0681,change to A6E0681
  26. ;2033-9-1 mistake is due to wrong initial value 4AB0B83,change to 4AF0B83
  27. ;Lunar date 1915 has an invalid initial value B5500D6,change to B5400D6
  28. ;Lunar date 2065 has an invalid initial value DA400CD,change to DA500CD
  29. ;Lunar date 2068 has an invalid initial value A6C00CB,change to A6D00CB 2069-1-22
  30. ;Lunar date 2079-1-21 has an invalid initial value 52B00CA,change to 62B00CA
  31. ;Lunar date 2078 has an invalid initial value A5A00D4,change to A5B00D4
  32.  
  33. LunarData=
  34. (LTrim Join
  35. AB500D2,4AE00DB,A5B0682,A4B00D0,D8A167F,B5500CE,AB500D7,4DD057F,49B00CD,49700D7,D95047C,B4A00CB,6AA00D4,76A037B,56D00C9,93700D3,D2E0379,A9B0883,69300D1,D5200DA,D5200D1
  36. )
  37.  
  38. ;分解公历年月日
  39. StringLeft,Year,Gregorian,4
  40. StringMid,Month,5,2
  41. StringRight,Day,2
  42. if (Year>2100 Or Year<1900)
  43. {
  44. errorinfo=无效日期
  45. return,errorinfo
  46. }
  47.  
  48. ;获取两年内的农历数据
  49. Pos:=(Year-1900)*8+1
  50. StringMid,Data0,LunarData,%Pos%,7
  51. Pos+=8
  52. StringMid,Data1,7
  53.  
  54. ;判断农历年份
  55. Analyze(Data1,MonthInfo,LeapInfo,Leap,Newyear)
  56. Date1=%Year%%Newyear%
  57.  
  58. Date2:=Gregorian
  59. EnvSub,Date2,%Date1%,Days
  60. If Date2<0 ;和当年农历新年相差的天数
  61. {
  62. Analyze(Data0,Newyear)
  63. Year-=1
  64. Date1=%Year%%Newyear%
  65. Date2:=Gregorian
  66. EnvSub,Days
  67. }
  68. ;计算农历日期
  69. Date2+=1
  70. LYear:=Year ;农历年份,就是上面计算后的值
  71. if Leap ;有闰月
  72. {
  73. StringLeft,p1,%Leap%
  74. StringTrimLeft,p2,%Leap%
  75. thisMonthInfo:=p1 . LeapInfo . p2
  76. }
  77. Else
  78. thisMonthInfo:=MonthInfo
  79. loop,13
  80. {
  81. StringMid,thisMonth,thisMonthInfo,%A_index%,1
  82. thisDays:=29+thisMonth
  83. if Date2>%thisDays%
  84. Date2:=Date2-thisDays
  85. Else
  86. {
  87. if leap
  88. {
  89. If leap>%a_index%
  90. LMonth:=A_index
  91. Else
  92. LMonth:=A_index-1
  93. }
  94. Else
  95. LMonth:=A_index
  96. LDay:=Date2
  97. Break
  98. }
  99. }
  100. LDate=%LYear%年%LMonth%月%LDay% ;完成
  101. ;转换成习惯性叫法
  102. Tiangan=甲,乙,丙,丁,戊,已,庚,辛,壬,癸
  103. Dizhi=子,丑,寅,卯,辰,巳,午,未,申,酉,戌,亥
  104. Shengxiao=鼠,牛,虎,兔,龙,蛇,马,羊,猴,鸡,狗,猪
  105. loop,Parse,Tiangan,`,Tiangan%a_index%:=A_LoopField
  106. loop,Dizhi,Dizhi%a_index%:=A_LoopField
  107. loop,Shengxiao,Shengxiao%a_index%:=A_LoopField
  108. Order1:=Mod((LYear-4),10)+1
  109. Order2:=Mod((LYear-4),12)+1
  110. LYear:=Tiangan%Order1% . Dizhi%Order2% . "(" . Shengxiao%Order2% . ")"
  111.  
  112. _monthStr=正,二,三,四,五,六,七,八,九,十,冬,腊
  113. loop,_monthStr,_monthStr%A_index%:=A_LoopField
  114. LMonth:=_monthStr%LMonth%
  115.  
  116. _dayStr=初一,初二,初三,初四,初五,初六,初七,初八,初九,初十,十一,十二,十三,十四,十五,十六,十七,十八,十九,二十,廿一,廿二,廿三,廿四,廿五,廿六,廿七,廿八,廿九,三十
  117. loop,_dayStr,_dayStr%A_index%:=A_LoopField
  118. LDay:=_dayStr%LDay%
  119.  
  120. LDate=%LYear%年%LMonth%月%LDay%
  121. Return,LDate
  122. }
  123. ;分析农历数据的函数 按上面所示规则分析
  124. ;4个回参分别对应四项
  125. Analyze(Data,ByRef rtn1,ByRef rtn2,ByRef rtn3,ByRef rtn4)
  126. {
  127. ;rtn1
  128. StringLeft,Data,3
  129. rtn1:=ToBase("0x" . Month,2)
  130. ;517返回10100010111但期望010100010111
  131. ;~ 补足12位的做法:
  132. rtn1:=SubStr("000000000000" . rtn1,-11)
  133.  
  134. ;rtn2
  135. StringMid,rtn2,4,1
  136.  
  137. ;rtn3
  138. StringMid,leap,1
  139. rtn3:=leap<10?leap:ToBase("0x" . leap,10)
  140.  
  141. ;rtn4
  142. StringRight,Newyear,2
  143. rtn4:=ToBase("0x" . newyear,10)
  144. rtn4:=SubStr("0000" . rtn4,-3)
  145. }
  146.  
  147. ;进制转换
  148. ;第一个参数输入数字,0x开头为16进制,无前缀为10进制
  149. ;第二个参数是 目的进制
  150. ToBase(n,b){
  151. return (n < b ? "" : ToBase(n//b,b)) . ((d:=Mod(n,b)) < 10 ? d : Chr(d+55))
  152. }

猜你在找的VB相关文章