在access中增加農曆支援模組. (轉)

在access中增加農曆支援模組. (轉)[@more@]

在access中增加農曆支援模組.

---

新建模組,複製下面兩個. glgetnl(),strnl()

在查詢中使用: glgetnl(born) as nlborn from empolyee where glgetnl(born)>"05012" order by glgetnl(born)

上面的查詢返回農曆生日大於五月十二員工列表,並按農曆生日排序.

(宣告:這兩個函式不是從零開始寫的,是修改了網上不知道誰的程式碼而來的.
到輸入關鍵字農曆可以找到這篇文章的多處引用

本來是想在中直接的,後來想到放到中,但在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
  L 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