[SIZE=-0]Thủ thuật:
Đổi Dương lịch ra Âm lịch
Giới thiệu:
Đổi ngày tháng năm Dương lịch thành ngày tháng năm Âm lịch.
Ví dụ:
Public Lday, Lmonth As Byte, Lyear As Integer, isLeap, LunarInfo
Sub LNI()
LunarInfo = Array( _
&H3C4BD8, &H624AE0, &H4CA570, &H3854D5, &H5CD260, &H44D950, &H315554, &H5656A0, &H409AD0, &H2A55D2, &H504AE0, &H3AA5B6, &H60A4D0, &H48D250, &H33D255, &H58B540, &H42D6A0, &H2CADA2, &H5295B0, &H3F4977, _
&H644970, &H4CA4B0, &H36B4B5, &H5C6A50, &H466D40, &H2FAB54, &H562B60, &H409570, &H2C52F2, &H504970, &H3A6566, &H5ED4A0, &H48EA50, &H336A95, &H585AD0, &H442B60, &H2F86E3, &H5292E0, &H3DC8D7, &H62C950, _
&H4CD4A0, &H35D8A6, &H5AB550, &H4656A0, &H31A5B4, &H5625D0, &H4092D0, &H2AD2B2, &H50A950, &H38B557, &H5E6CA0, &H48B550, &H355355, &H584DA0, &H42A5B0, &H2F4573, &H5452B0, &H3CA9A8, &H60E950, &H4C6AA0, _
&H36AEA6, &H5AAB50, &H464B60, &H30AAE4, &H56A570, &H405260, &H28F263, &H4ED940, &H38DB47, &H5CD6A0, &H4896D0, &H344DD5, &H5A4AD0, &H42A4D0, &H2CD4B4, &H52B250, &H3CD558, &H60B540, &H4AB5A0, &H3755A6, _
&H5C95B0, &H4649B0, &H30A974, &H56A4B0, &H40AA50, &H29AA52, &H4E6D20, &H39AD47, &H5EAB60, &H489370, &H344AF5, &H5A4970, &H4464B0, &H2C74A3, &H50EA50, &H3D6A58, &H6256A0, &H4AAAD0, &H3696D5, &H5C92E0, _
&H46C960, &H2ED954, &H54D4A0, &H3EDA50, &H2A7552, &H4E56A0, &H38A7A7, &H5EA5D0, &H4A92B0, &H32AAB5, &H58A950, &H42B4A0, &H2CBAA4, &H50AD50, &H3C55D9, &H624BA0, &H4CA5B0, &H375176, &H5C5270, &H466930, _
&H307934, &H546AA0, &H3EAD50, &H2A5B52, &H504B60, &H38A6E6, &H5EA4E0, &H48D260, &H32EA65, &H56D520, &H40DAA0, &H2D56A3, &H5256D0, &H3C4AFB, &H6249D0, &H4CA4D0, &H37D0B6, &H5AB250, &H44B520, &H2EDD25, _
&H54B5A0, &H3E55D0, &H2A55B2, &H5049B0, &H3AA577, &H5EA4B0, &H48AA50, &H33B255, &H586D20, &H40AD60, &H2D4B63, &H525370, &H3E49E8, &H60C970, &H4C54B0, &H3768A6, &H5ADA50, &H445AA0, &H2FA6A4, &H54AAD0, _
&H4052E0, &H28D2E3, &H4EC950, &H38D557, &H5ED4A0, &H46D950, &H325D55, &H5856A0, &H42A6D0, &H2C55D4, &H5252B0, &H3CA9B8, &H62A930, &H4AB490, &H34B6A6, &H5AAD50, &H4655A0, &H2EAB64, &H54A570, &H4052B0, _
&H2AB173, &H4E6930, &H386B37, &H5E6AA0, &H48AD50, &H332AD5, &H582B60, &H42A570, &H2E52E4, &H50D160, &H3AE958, &H60D520, &H4ADA90, &H355AA6, &H5A56D0, &H462AE0, &H30A9D4, &H54A2D0, &H3ED150, &H28E952, _
&H4EB520, &H38D727, &H5EADA0, &H4A55B0, &H362DB5, &H5A45B0, &H44A2B0, &H2EB2B4, &H54A950, &H3CB559, &H626B20, &H4CAD50, &H385766, &H5C5370, &H484570, &H326574, &H5852B0, &H406950, &H2A7953, &H505AA0, _
&H3BAAA7, &H5EA6D0, &H4A4AE0, &H35A2E5, &H5AA550, &H42D2A0, &H2DE2A4, &H52D550, &H3E5ABB, &H6256A0, &H4C96D0, &H3949B6, &H5E4AB0, &H46A8D0, &H30D4B5, &H56B290, &H40B550, &H2A6D52, &H504DA0, &H3B9567, _
&H609570, &H4A49B0, &H34A975, &H5A64B0, &H446A90, &H2CBA94, &H526B50, &H3E2B60, &H28AB61, &H4C9570, &H384AE6, &H5CD160, &H46E4A0, &H2EED25, &H54DA90, &H405B50, &H2C36D3, &H502AE0, &H3A93D7, &H6092D0, _
&H4AC950, &H32D556, &H58B4A0, &H42B690, &H2E5D94, &H5255B0, &H3E25FA, &H6425B0, &H4E92B0, &H36AAB6, &H5C6950, &H4674A0, &H31B2A5, &H54AD50, &H4055A0, &H2AAB73, &H522570, &H3A5377, &H6052B0, &H4A6950, _
&H346D56, &H585AA0, &H42AB50, &H2E56D4, &H544AE0, &H3CA570, &H2864D2, &H4CD260, &H36EAA6, &H5AD550, &H465AA0, &H30ADA5, &H5695D0, &H404AD0, &H2AA9B3, &H50A4D0, &H3AD2B7, &H5EB250, &H48B540, &H33D556)'' /* Years 2100-2199 */
End Sub
Sub lunar(d, m, y)
Dim DiffADate, Counter, I, Temp
DiffADate = DateDiff("d", #1/31/1900#, CDate(d & "-" & m & "-" & y))
Counter = -1
Lyear = 1900
For I = Lyear To 2199
Temp = YearDays(I)
Counter = Counter + Temp
If Counter >= DiffADate Then
Counter = Counter - Temp
Exit For
End If
Lyear = Lyear + 1
Next
Leap = LeapMonth(Lyear)
isLeap = ""
Lmonth = 1
For I = 1 To 12
If Leap > 0 And I = Leap + 1 And isLeap = "" Then
isLeap = "(N)"
Lmonth = Lmonth - 1
I = I - 1
Temp = LeapDay(Lyear)
Else
Temp = MonthDays(Lyear, I)
End If
If isLeap = "(N)" And I <> Leap Then isLeap = ""
Counter = Counter + Temp
If Counter >= DiffADate Then
Counter = Counter - Temp
Exit For
End If
Lmonth = Lmonth + 1
Next
Lday = DiffADate - Counter
End Sub
Function LeapMonth(y)
LNI
If y >= 1900 Then LeapMonth = LunarInfo(y - 1900) And &HF Else LeapMonth = 0
End Function
'-----------
Function LeapDay(y)
LNI
If LunarInfo(y - 1900) And &HF Then
If LunarInfo(y - 1900) And &H10000 Then LeapDay = 30 Else LeapDay = 29
Else
LeapDay = 0
End If
End Function
'-----------
Function MonthDays(y, m)
LNI
MonthMask = Array(32768, 16384, 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16)
If LunarInfo(y - 1900) And MonthMask(m - 1) Then MonthDays = 30 Else MonthDays = 29
End Function
'-----------
Function YearDays(y)
Dim I
LNI
MonthMask = Array(32768, 16384, 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16)
YearDays = 348
For I = 0 To 11
If LunarInfo(y - 1900) And MonthMask(I) Then YearDays = YearDays + 1
Next
YearDays = YearDays + LeapDay(y)
End Function
'Ham so chuyen doi tu Duong lich sang Am lich dang ngay,thang,nam
Public Function TransLu(d, m, y)
Call lunar(m, d, y)
TransLu = Lday & "/" & Lmonth & isLeap & "/" & Lyear
End Function
'Ham so chuyen doi tu Duong lich sang Am lich dang tu mot o
Public Function TransLu1(NT As Date)
Call lunar(Day(NT), Month(NT), Year(NT))
TransLu1 = Lday & "-" & Lmonth & isLeap & "-" & CanchiV(Lyear - 0)
End Function
Public Function TransSolar(d, m, y) As Date'Ngay thang nam am lich sang duong lich
Dim iSd As Date
iSd = DateSerial(y, m, d) - 70
Do
iSd = iSd + 1
Loop Until TransLu(Day(iSd), Month(iSd), Year(iSd)) = d & "/" & m & "/" & y
TransSolar = iSd
End Function
'=======================================
'Cach su dung:
'=======================================
Private Sub Command1_Click()
MsgBox "Ngay DL: 22/1/2006" & vbCrLf & "Ngay AL: " & TransLu(22, 1, 2006)
End Sub
[/SIZE]
