Option Explicit
Dim DayName(30) As String '農歷的所有日期 如初壹
Dim MovthName(12) As String '月份名稱
Dim NongliData(99) As Long '農歷數據
Dim TianGan(9) As String '天幹名稱
Dim DiZhi(11) As String '地支名稱
Dim ShuXiang(11) As String '屬相名稱
Dim MonthAdd(11) As Long '公歷每月前面的天數
'SetDayName 給農歷的給值
Private Sub SetDayName()
Dim li_i As Long
DayName(0) = "*"
For li_i = 1 To 30
DayName(li_i) = Choose(li_i \ 10 + 1, "", "十", "二十", "三十") & _
Mid(" 壹二三四五六七八九", li_i Mod 10 + 2, 1) ' 數組的值為大寫數值
Next
'在壹至十前面加上初字.在二十壹至二十九前面加上廿.以更符合人們的習慣
For li_i = 1 To 10 '在壹至十的前面加上壹個初字
DayName(li_i) = "初" & DayName(li_i)
Next
For li_i = 21 To 29 '用廿字替換二十兩字
DayName(li_i) = "廿" & Mid(DayName(li_i), 3, 1)
Next
End Sub
Private Sub SetMovthName() '月份的名稱
Dim li_i As Long
MovthName(0) = "*"
For li_i = 1 To 12
MovthName(li_i) = Choose(li_i \ 10 + 1, "", "十") & Mid(" 壹二三四五六七八九", li_i Mod 10 + 2, 1)
Next
End Sub
Private Sub SetTinaGan()
TianGan(0) = "甲"
TianGan(1) = "乙"
TianGan(2) = "丙"
TianGan(3) = "丁"
TianGan(4) = "戊"
TianGan(5) = "己"
TianGan(6) = "庚"
TianGan(7) = "辛"
TianGan(8) = "壬"
TianGan(9) = "癸"
End Sub
Private Sub SetDiZhi()
DiZhi(0) = "子"
DiZhi(1) = "醜"
DiZhi(2) = "寅"
DiZhi(3) = "卯"
DiZhi(4) = "辰"
DiZhi(5) = "巳"
DiZhi(6) = "午"
DiZhi(7) = "未"
DiZhi(8) = "申"
DiZhi(9) = "酉"
DiZhi(10) = "戌"
DiZhi(11) = "亥"
End Sub
Private Sub Setshuxiang()
ShuXiang(0) = "鼠"
ShuXiang(1) = "牛"
ShuXiang(2) = "虎"
ShuXiang(3) = "兔"
ShuXiang(4) = "龍"
ShuXiang(5) = "蛇"
ShuXiang(6) = "馬"
ShuXiang(7) = "羊"
ShuXiang(8) = "猴"
ShuXiang(9) = "雞"
ShuXiang(10) = "狗"
ShuXiang(11) = "豬"
End Sub
Private Sub SetMonthAdd() '公歷每月前面的天數
MonthAdd(0) = 0
MonthAdd(1) = 31
MonthAdd(2) = 59
MonthAdd(3) = 90
MonthAdd(4) = 120
MonthAdd(5) = 151
MonthAdd(6) = 181
MonthAdd(7) = 212
MonthAdd(8) = 243
MonthAdd(9) = 273
MonthAdd(10) = 304
MonthAdd(11) = 334
End Sub
Private Sub SetNongliData()
'農歷數據
NongliData(0) = 2635
NongliData(1) = 333387
NongliData(2) = 1701
NongliData(3) = 1748
NongliData(4) = 267701
NongliData(5) = 694
NongliData(6) = 2391
NongliData(7) = 133423
NongliData(8) = 1175
NongliData(9) = 396438
NongliData(10) = 3402
NongliData(11) = 3749
NongliData(12) = 331177
NongliData(13) = 1453
NongliData(14) = 694
NongliData(15) = 201326
NongliData(16) = 2350
NongliData(17) = 465197
NongliData(18) = 3221
NongliData(19) = 3402
NongliData(20) = 400202
NongliData(21) = 2901
NongliData(22) = 1386
NongliData(23) = 267611
NongliData(24) = 605
NongliData(25) = 2349
NongliData(26) = 137515
NongliData(27) = 2709
NongliData(28) = 464533
NongliData(29) = 1738
NongliData(30) = 2901
NongliData(31) = 330421
NongliData(32) = 1242
NongliData(33) = 2651
NongliData(34) = 199255
NongliData(35) = 1323
NongliData(36) = 529706
NongliData(37) = 3733
NongliData(38) = 1706
NongliData(39) = 398762
NongliData(40) = 2741
NongliData(41) = 1206
NongliData(42) = 267438
NongliData(43) = 2647
NongliData(44) = 1318
NongliData(45) = 204070
NongliData(46) = 3477
NongliData(47) = 461653
NongliData(48) = 1386
NongliData(49) = 2413
NongliData(50) = 330077
NongliData(51) = 1197
NongliData(52) = 2637
NongliData(53) = 268877
NongliData(54) = 3365
NongliData(55) = 531109
NongliData(56) = 2900
NongliData(57) = 2922
NongliData(58) = 398042
NongliData(59) = 2395
NongliData(60) = 1179
NongliData(61) = 267415
NongliData(62) = 2635
NongliData(63) = 661067
NongliData(64) = 1701
NongliData(65) = 1748
NongliData(66) = 398772
NongliData(67) = 2742
NongliData(68) = 2391
NongliData(69) = 330031
NongliData(70) = 1175
NongliData(71) = 1611
NongliData(72) = 200010
NongliData(73) = 3749
NongliData(74) = 527717
NongliData(75) = 1452
NongliData(76) = 2742
NongliData(77) = 332397
NongliData(78) = 2350
NongliData(79) = 3222
NongliData(80) = 268949
NongliData(81) = 3402
NongliData(82) = 3493
NongliData(83) = 133973
NongliData(84) = 1386
NongliData(85) = 464219
NongliData(86) = 605
NongliData(87) = 2349
NongliData(88) = 334123
NongliData(89) = 2709
NongliData(90) = 2890
NongliData(91) = 267946
NongliData(92) = 2773
NongliData(93) = 592565
NongliData(94) = 1210
NongliData(95) = 2651
NongliData(96) = 395863
NongliData(97) = 1323
NongliData(98) = 2707
NongliData(99) = 265877
End Sub
Private Function l(ByVal Data As String) As String '返回閏月 每個月的天數
Dim ll_Year As Long
Dim ll_Movth As Long
Dim ll_Day As Long
Dim ll_TheDate As Long
Dim ll_isEnd As Long
Dim ll_m As Long
Dim ll_k As Long
Dim ll_n As Long
Dim bit As Long
Dim i As Long
Dim ls_DataNow As String
Dim ls_conn As String
ls_DataNow = Data
ll_Year = Year(ls_DataNow)
ll_Movth = Month(ls_DataNow)
ll_Day = Day(ls_DataNow)
'生成當前公歷年、月、日 ==> ls_conn
ls_conn = CStr(ll_Year) & "年"
ls_conn = ls_conn & IIf(ll_Movth < 10, "0" & CStr(ll_Movth) & "月", CStr(ll_Movth) & "月")
ls_conn = ls_conn & IIf(ll_Day < 10, "0" & CStr(ll_Day) & "日", CStr(ll_Day) & "日")
'計算到初始時間1921年2月8日的天數：1921-2-8(正月初壹)
ll_TheDate = (ll_Year - 1921) * 365 + Int((ll_Year - 1921) / 4) + ll_Day + MonthAdd(ll_Movth - 1) - 38
If ((ll_Year Mod 4) = 0 And ll_Movth > 2) Then ll_TheDate = ll_TheDate + 1
'計算農歷天幹、地支、月、日
ll_isEnd = 0
ll_m = 0
Do
ll_k = IIf(NongliData(ll_m) < 4095, 11, 12)
ll_n = ll_k
Do
If (ll_n < 0) Then Exit Do
bit = NongliData(ll_m) '獲取NongliData(ll_m)的第n個二進制位的值
'MsgBox bit
For i = 1 To ll_n Step 1
bit = Int(bit / 2)
Next
bit = bit Mod 2
If (ll_TheDate <= 29 + bit) Then
ll_isEnd = 1
Exit Do
End If
ll_TheDate = ll_TheDate - 29 - bit
ll_n = ll_n - 1
Loop
If (ll_isEnd = 1) Then Exit Do
ll_m = ll_m + 1
Loop
ll_Year = 1921 + ll_m
ll_Movth = ll_k - ll_n + 1
ll_Day = ll_TheDate
If (ll_k = 12) Then
If (ll_Movth = (Int(NongliData(ll_m) / 65536) + 1)) Then
ll_Movth = 1 - ll_Movth
ElseIf (ll_Movth > (Int(NongliData(ll_m) / 65536) + 1)) Then
ll_Movth = ll_Movth - 1
End If
End If
If (ll_Movth < 1) Then
l = ll_Year & "-" & Abs(ll_Movth) & "-" & ll_Day & "-" & "1" '閏月標誌
Else
l = ll_Year & "-" & Abs(ll_Movth) & "-" & ll_Day & "-" & "0"
End If
End Function
Public Function GetLunarData(ByVal Data As String) As String
Dim ls_NongliDayStr As String
Dim ll_data() As String
If IsDate(Data) Then
ll_data = Split(l(Data), "-")
ls_NongliDayStr = ll_data(0) & "年"
If (CInt(ll_data(3)) = 1) Then '生成農歷月、日 ==> NongliDayStr
ls_NongliDayStr = ls_NongliDayStr & "閏" & MovthName(CInt(ll_data(1)))
Else
ls_NongliDayStr = ls_NongliDayStr & MovthName(CInt(ll_data(1)))
End If
ls_NongliDayStr = ls_NongliDayStr & "月"
ls_NongliDayStr = ls_NongliDayStr & DayName(CInt(ll_data(2)))
GetLunarData = ls_NongliDayStr
Else
GetLunarData = ""
End If
Erase ll_data
End Function
'函數名:getTianGan
'輸入參數
' ----Data 為壹個日期
'輸出參數:
' -----返回壹個天幹地支的名稱
'功能: 取得指定年份的天幹地支名稱
'編寫日期:2006 12 24
'最後修改日期:2006 12 24
'作者: 楊瑞
Public Function getTianGan(ByVal Data As String) As String '生成農歷天幹、地支、屬相 ==> NongliStr
Dim ls_NongliStr As String
Dim ll_data() As String
If IsDate(Data) Then
ll_data = Split(l(Data), "-") '"農歷" &
ls_NongliStr = TianGan(((CInt(ll_data(0)) - 4) Mod 60) Mod 10) & DiZhi(((CInt(ll_data(0)) - 4) Mod 60) Mod 12) & "年"
ls_NongliStr = ls_NongliStr & "(" & ShuXiang(((CInt(ll_data(0)) - 4) Mod 60) Mod 12) & ")"
getTianGan = ls_NongliStr
Else
getTianGan = ""
End If
Erase ll_data
End Function
'函數名:GetWeekNmae
'輸入參數
' ----Data 為壹個日期
'輸出參數:
' -----如果日期輸入不合法則返回為空.否則返回星期名稱
'功能: 取得日期的星期名稱
'編寫日期:2006 12 23
'最後修改日期:2006 12 23
'作者: 楊瑞
Public Function getWeekName(ByVal Data As String) As String
Dim ls_WeekName As String
If IsDate(Data) Then
ls_WeekName = WeekdayName(Weekday(Data))
getWeekName = ls_WeekName
Else
getWeekName = ""
End If
End Function
'函數名 readData
'輸入參數: ---- Data 字符型 是從每年的 1月1日開始推算
'---- Lunar 字符型 為壹個將陰歷的日期轉換成中文字符串
'返回值: 為壹個陽歷組成的字符串
'編程思想:從每年的1月1日開始推算至到12月31日.每次的返回值與傳入的Lunar值想比較.如查兩都相等
' 則表明該陰歷對應的日期為找到
'編寫日期:2006 12 23
'最後修改日期:2006 12 23
'作者: 楊瑞
Private Function readData(ByVal Data As String, ByVal Lunar As String) As String
Dim li_i As Long, li_j As Long
Dim l_day() As String, ll_count As Long
Dim ls_DataTime As String
Dim ls_newdata As String
l_day = Split(Data, "-")
For li_i = 1 To 12
ll_count = 0
If li_i = 1 Or li_i = 3 Or li_i = 5 Or li_i = 7 Or li_i = 9 Or li_i = 10 Or li_i = 12 Then '如果月大就為31天
ll_count = 31
ElseIf li_i = 2 And bissextile(l_day(0)) Then '閏年就為 29 天
ll_count = 29
ElseIf li_i = 2 And bissextile(l_day(0)) = False Then '閏年就為 28 天
ll_count = 28
Else
ll_count = 30 '月小為30天
End If
For li_j = 1 To ll_count '從每個月的1號開始循環至每個月的月末
ls_DataTime = DateSerial(l_day(0), li_i, li_j)
ls_newdata = GetLunarData(ls_DataTime)
If Trim(ls_newdata) = Trim(Lunar) Then '判斷該陽歷的所返回值陰歷是否與 Lunar 值相等
readData = ls_DataTime
Exit Function
End If
Next
Next
Erase l_day()
End Function
Private Function bissextile(ByVal Data As String) As Boolean '判斷是否是閏年
Dim lb_fag As Boolean
lb_fag = False
If Data Mod 400 = 0 Or (Data Mod 4 = 0 And Data Mod 100 <> 0) Then
lb_fag = True
Else
lb_fag = False
End If
bissextile = lb_fag
End Function
'函數名: rgetLunarData
'輸入參數: Data 字符型
'返回值: 字符串
'功能: 取得陰歷所對應的陽歷
'作者:楊瑞
'完成時間:2006 12 26
'最後修改時間 2006 12 26
Public Function rgetLunarData(ByVal Data As String) As String
Dim l_day() As String
Dim ls_data As String 'ls_data 字符型 用來保存生成傳入陰歷所生成的中文字符串
Dim ls_newdata As String
If Not IsDate(Data) Then
rgetLunarData = ""
Exit Function
End If
ls_newdata = ""
l_day = Split(Data, "-")
ls_data = l_day(0) & "年" & MovthName(l_day(1)) & "月" & DayName(l_day(2))
ls_newdata = readData(Data, ls_data)
If Len(ls_newdata) = 0 Then '如果readData的返回值為空.表明是該陰歷所對應的陽歷在下壹年.不在當年
ls_newdata = readData(DateSerial(l_day(0) + 1, 1, 1), ls_data)
'DateSerial(l_day(0) + 1, 1, 1) 生成下壹年作為參數
rgetLunarData = ls_newdata
Else
rgetLunarData = ls_newdata
End If
Erase l_day()
End Function
Private Sub Class_Initialize()
Call SetDayName
Call SetMovthName
Call SetTinaGan
Call SetDiZhi
Call Setshuxiang
Call SetNongliData
Call SetMonthAdd
End Sub
Private Sub Class_Terminate()
End Sub
窗體加入2個按鈕壹個文本框
窗體代碼：
Private Sub Command1_Click()
Dim a As New Data
Dim s As String
s = a.GetLunarData(Trim(Me.Text1.Text))
Dim b As New Data
MsgBox s
End Sub
Private Sub Command2_Click()
Dim a As New Data
Dim s As String
s = a.rgetLunarData(Me.Text1.Text)
MsgBox s
End Sub
Private Function b(ByVal Data As String) As Boolean
If Data Mod 400 = 0 Or (Data Mod 4 = 0 And Data Mod 100 <> 0) Then
MsgBox "sadf"
End If
End Function
Private Sub ab(ByVal Data As String)
Dim ls_date() As String
ls_date = Split(Date, "-") '生成壹個數組
MsgBox ls_date(0)
If ls_date(0) Mod 4 = 0 And ls_date(0) Mod 100 <> 0 Or ls_date(0) Mod 400 = 0 Then
MsgBox "要"
Else
MsgBox "不"
End If
MsgBox "2002 mod 4=" & 2002 Mod 4
MsgBox "2002 mod 400=" & 2002 Mod 400
MsgBox "2002 mod 100=" & 2002 Mod 100
End Sub
Private Sub Form_Load()
Me.Text1.Text = Date
End Sub