在access中增加农历支持模块.
新建模块,复制下面两个函数. glgetnl(),strnl()
在查询中使用: select glgetnl(born) as nlborn from empolyee where glgetnl(born)>"05012" order by glgetnl(born)
上面的查询返回农历生日大于五月十二员工列表,并按农历生日排序.
(声明:这两个函数不是从零开始写的,是修改了网上不知道谁的程序代码而来的.到google输入关键字vb 农历可以找到这篇文章的多处引用
本来是想在ASP中直接调用的,后来想到放到数据库中,但在Access中可以使用,在ASP中使用ADO无法调用.在调试中发现原数据中的1998农历闰月为小月而不是原代码中的大月,另修改了求干支算法.也没去和原作者联系,见谅.)
'输入date, 返回"mmlddyyyy" mm: 月份; l: 1,闰月,0,平常月; dd: 日; yyyy年份Function glgetnl(ByVal gldate) Dim daList(111) '1900 to 1909 daList(0) = "010010110110180131" daList(1) = "010010101110000219" daList(2) = "101001010111000208" daList(3) = "010100100110150129" daList(4) = "110100100110000216" daList(5) = "110110010101000204" daList(6) = "011010101010140125" daList(7) = "010101101010000213" daList(8) = "100110101101000202" daList(9) = "010010101110120122" daList(10) = "010010101110000210" daList(11) = "101001001101160130" daList(12) = "101001001101000218" daList(13) = "110100100101000206" daList(14) = "110101010100150126" daList(15) = "101101010101000214" daList(16) = "010101101010000204" daList(17) = "100101101101020123" daList(18) = "100101011011000211" daList(19) = "010010011011170201" daList(20) = "010010011011000220" daList(21) = "101001001011000208" daList(22) = "101100100101150128" daList(23) = "011010100101000216" daList(24) = "011011010100000205" daList(25) = "101011011010140124" daList(26) = "001010110110000213" daList(27) = "100101010111000202" daList(28) = "010010010111120123" daList(29) = "010010010111000210" daList(30) = "011001001011060130" daList(31) = "110101001010000217" daList(32) = "111010100101000206" daList(33) = "011011010100150126" daList(34) = "010110101101000214" daList(35) = "001010110110000204" daList(36) = "100100110111030124" daList(37) = "100100101110000211" daList(38) = "110010010110170131" daList(39) = "110010010101000219" daList(40) = "110101001010000208" daList(41) = "110110100101060127" daList(42) = "101101010101000215" daList(43) = "010101101010000205" daList(44) = "101010101101140125" daList(45) = "001001011101000213" daList(46) = "100100101101000202" daList(47) = "110010010101120122" daList(48) = "101010010101000210" daList(49) = "101101001010170129" daList(50) = "011011001010000217" daList(51) = "101101010101000206" daList(52) = "010101011010150127" daList(53) = "010011011010000214" daList(54) = "101001011011000203" daList(55) = "010100101011130124" daList(56) = "010100101011000212" daList(57) = "101010010101080131" daList(58) = "111010010101000218" daList(59) = "011010101010000208" daList(60) = "101011010101060128" daList(61) = "101010110101000215" daList(62) = "010010110110000205" daList(63) = "101001010111040125" daList(64) = "101001010111000213" daList(65) = "010100100110000202" daList(66) = "111010010011030121" daList(67) = "110110010101000209" daList(68) = "010110101010170130" daList(69) = "010101101010000217" daList(70) = "100101101101000206" daList(71) = "010010101110150127" daList(72) = "010010101101000215" daList(73) = "101001001101000203" daList(74) = "110100100110140123" daList(75) = "110100100101000211" daList(76) = "110101010010180131" daList(77) = "101101010100000218" daList(78) = "101101101010000207" daList(79) = "100101101101060128" daList(80) = "100101011011000216" daList(81) = "010010011011000205" daList(82) = "101001001011140125" daList(83) = "101001001011000213" daList(84) = "1011001001011A0202" daList(85) = "011010100101000220" daList(86) = "011011010100000209" daList(87) = "101011011010060129" daList(88) = "101010110110000217" daList(89) = "100100110111000206" daList(90) = "010010010111150127" daList(91) = "010010010111000215" daList(92) = "011001001011000204" daList(93) = "011010100101030123" daList(94) = "111010100101000210" daList(95) = "011010110010180131" daList(96) = "010110101100000219" daList(97) = "101010110110000207" daList(98) = "100100110110050128" daList(99) = "100100101110000216" daList(100) = "110010010110000205" daList(101) = "110101001010140124" daList(102) = "110101001010000212" daList(103) = "110110100101000201" daList(104) = "010110101010120122" daList(105) = "010101101010000209" daList(106) = "101010101101170129" daList(107) = "001001011101000218" daList(108) = "100100101101000207" daList(109) = "110010010101150126" daList(110) = "101010010101000214" daList(111) = "101101001010000214" On Error Resume Next Dim conDate As Date Dim tYear, AddMonth, AddDay, AddYear, getDay, i As Integer Dim RunYue As Boolean tYear = Year(gldate) If tYear > 2010 Or tYear < 1901 Then glgetnl = " " Exit Function '如果不是有效有日期，退出 End If RunYue = False AddYear = tYear Do AddMonth = CInt(Mid(daList(AddYear - 1900), 15, 2)) AddDay = CInt(Mid(daList(AddYear - 1900), 17, 2)) conDate = DateSerial(AddYear, AddMonth, AddDay) getDay = DateDiff("d", conDate, gldate) If getDay < 0 Then AddYear = AddYear - 1 Loop While getDay < 0 AddDay = 1 AddMonth = 1 For i = 1 To getDay AddDay = AddDay + 1 If AddDay = 30 + CInt(Mid(daList(AddYear - 1900), AddMonth, 1)) Or (RunYue And AddDay = 30 + CInt(Mid(daList(AddYear - 1900), 13, 1))) Then If RunYue = False And AddMonth = CInt("&H" & Mid(daList(AddYear - 1900), 14, 1)) Then RunYue = True Else RunYue = False AddMonth = AddMonth + 1 End If AddDay = 1 End If Next glgetnl = IIf(AddMonth > 9, CStr(AddMonth), "0" + CStr(AddMonth)) + IIf(RunYue, "1", "0") + IIf(AddDay > 9, CStr(AddDay), "0" + CStr(AddDay)) + CStr(AddYear)End Function
' 输入sNl="mmlddyyyy" mm: 月份; l: 1,闰月,0,平常月; dd: 日; yyyy年份' 函数返回"XX月XX", 属相存入sShuXinag, 干支记年存入sYear
Function strnl(ByVal sNl, ByRef sShuXiang, ByRef sYear) Dim lnl_md, lnl_cm, lnl_tiangan, lnl_dizhi, lnl_shu lnl_md = "初一初二初三初四初五初六初七初八初九初十十一十二十三十四十五十六十七十八十九二十廿一廿二廿三廿四廿五廿六廿七廿八廿九三十" lnl_cm = "正二三四五六七八九十寒腊" lnl_tiangan = "甲乙丙丁戊已庚辛壬癸" lnl_dizhi = "子丑寅卯辰巳午未申酉戌亥" lnl_shu = "鼠牛虎兔龙蛇马羊猴鸡狗猪" On Error Resume Next Dim iy, im, id, isLeap im = CInt(Left(sNl, 2)) isLeap = CInt(Mid(sNl, 3, 1)) id = CInt(Mid(sNl, 4, 2)) iy = CInt(Right(sNl, 4)) strnl = Mid(lnl_cm, im, 1) & "月" & Mid(lnl_md, (id - 1) * 2 + 1, 2) If isLeap > 0 Then strnl = "闰" & strnl iy = iy - 4 sShuXiang = Mid(lnl_shu, (iy Mod 12) + 1, 1) sYear = Mid(lnl_tiangan, (iy Mod 10) + 1, 1) & Mid(lnl_dizhi, (iy Mod 12) + 1, 1)End Function
