Code tham khảo từ Hongocduc
Option Explicit
Public Lday, Lmonth As Byte, Lyear As Integer, isLeap, LunarInfo
‘ chú thích
Sub lunar(d, m, y)
Dim DiffADate, Counter, i, Temp, Leap
‘ tính sô ngày tù môc 1/31/1900 ‘ghi chú: d se Ðuoc xem nhu month
DiffADate = DateDiff(“d”, #1/31/1900#, CDate(m & “-” & d & “-” & y))
Counter = -1 ‘ngày 31/1/1900 có DateDiff = 0 tuong úng ÂL là ngày 1
‘nên counter = -1 vì ngày ÂL = DateDiff – counter
Lyear = 1900 ‘nam bat Ðâu tính, Lyear là nam ÂL tuong Ðuong DL
For i = Lyear To 2199 ‘ Ðêm trong 300 nam kê tiêp
Temp = YearDays(i) ‘goi Function YearDays nam Ðang Ðêm = sô ngày/nam
Counter = Counter + Temp ‘cong sô ngày dôn
If Counter >= DiffADate Then ‘nêu sô ngày dôn >= DiffADate
Counter = Counter – Temp ‘ tru` sô ngày dôn 1 nam Ðang tính
Exit For ‘và thoát vòng lap, = Ðã có giá tri Lyear
End If
Lyear = Lyear + 1 ‘nam Ðang Ðêm thêm 1 don vi
Next
‘so’ di phai tính nhu thê Ðê tìm chính xác nhung ngày cuôi nam ÂL mà Ðã sang nam mo’i DL
‘trong truong hop nây, xem nhu vân nam cu
Leap = LeapMonth(Lyear) ‘ goi hàm LeapMonth, tháng nhuân là tháng mây?
isLeap = “” ‘ set giá tri xác Ðinh cua tháng nhuân = “”
Lmonth = 1
For i = 1 To 12
If Leap > 0 And i = Leap + 1 And isLeap = “” Then
isLeap = “(N)” ‘nêu tháng nhuân có và I lo’n hon 1 thì Nhuân
Lmonth = Lmonth – 1 ‘tháng lùi 1
i = i – 1 ‘Ðêm lùi 1
Temp = LeapDay(Lyear) ‘ goi hàm leapday, tính sô ngày nhuân
Else
Temp = MonthDays(Lyear, i) ‘goi hàm monthdays tính sô ngày thuong
End If
If isLeap = “(N)” And i <> Leap Then isLeap = “”
‘ Nêu xác dinh Nhuân và I khác tháng nhuân thì Xác Ðinh không phai Nhuan
Counter = Counter + Temp ‘ cong dôn ngày tù vi trí Exit For khi xác Ðinh Lyear
If Counter >= DiffADate Then ‘nêu sô ngày dôn >= DiffADate
Counter = Counter – Temp ‘ tru` sô ngày dôn 1 tháng Ðang tính
Exit For ‘và thoát vòng lap, = Ðã có giá tri Lmonth
End If
Lmonth = Lmonth + 1 ‘tháng Ðang Ðêm thêm 1 don vi
Next
Lday = DiffADate – Counter ‘Ngày Ðuoc xác Ðinh
End Sub
Function LeapMonth(y) ””””””
If y >= 1900 Then LeapMonth = LunarInfo(y – 1900) And &HF Else LeapMonth = 0
‘Tháng nhuân = LunarInfo(nam Ðang chuyên) And &HF = ( tu 0 – 12) ngoài ra thì = 0
End Function
Function LeapDay(y) ”””””
If LunarInfo(y – 1900) And &HF Then ‘nêu có tháng nhuân thì
If LunarInfo(y – 1900) And &H10000 Then LeapDay = 30 Else LeapDay = 29
‘ Nêu LunarInfo(nam Ðang chuyên) And &H10000 > 0 thì 30 không thì 29 ngày
Else
LeapDay = 0
End If
End Function
Function MonthDays(y, m) ”””””””’
Dim MonthMask
MonthMask = Array(32768, 16384, 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16)
‘ Mang loc tháng(1-12) = MonthMask(0-11)
‘ Nêu LunarInfo(nam Ðang chuyên) And Mang loc tháng(tháng Ðang chuyên) > 0 thì 30 ngoài ra thì 29
If LunarInfo(y – 1900) And MonthMask(m – 1) Then MonthDays = 30 Else MonthDays = 29
End Function
Function YearDays(y) ””””””’
Dim i, MonthMask
MonthMask = Array(32768, 16384, 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16)
YearDays = 348 ’12 tháng x 29 ngày
For i = 0 To 11 ‘tháng nào có 30 ngày thì thêm 1
If LunarInfo(y – 1900) And MonthMask(i) Then YearDays = YearDays + 1
Next
YearDays = YearDays + LeapDay(y) ‘ cong thêm sô ngày nhuân nêu có
End Function
‘Ham so chuyen doi tu Duong lich sang Am lich dang ngay,thang,nam
Public Function TransLu(d, m, y)
Call Goi
‘ cau trúc cua hàm lunar là (d, m, y), VB6 dùng (m, d, y) nên function TransLu
‘ se doi vi tri câu trúc khi goi hàm lunar
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) ‘ NT = ngày tháng
Call lunar(Day(NT), Month(NT), Year(NT)) ‘goi hàm Lunar theo câu trúc nây ?
‘ Ðê nghi nhu’ hàm TransLu làm: Call lunar(Month(NT), Day(NT), Year(NT))
‘TransLu1 = Lday & “-” & Lmonth & isLeap & “-” & CanchiV(Lyear – 0)
‘Hàm CanchiV bi thiêu!
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()
If Days = “” Or Months = “” Or Years = “” Then Exit Sub
NgayAL = TransLu(Days, Months, Years)
End Sub
Private Sub Command2_Click()
If Years = “” Then Exit Sub
ThangNhuan = LeapMonth(Years)
End Sub
Private Sub Command3_Click()
If Years = “” Then Exit Sub
SoNgayNhuan = LeapDay(Years)
End Sub
Private Sub Command4_Click()
If Years = “” Or Months = “” Then Exit Sub
SoNgayThangT = MonthDays(Years, Months)
End Sub
Private Sub Command5_Click()
If Years = “” Then Exit Sub
SoNgayNam = YearDays(Years)
End Sub
Sub Goi()
‘Mang do HoNgocDuc tu xây dung, chu’a thông tin nam ÂL tu 1900-2199
‘nam Ðó tháng mây nhuân? gôm mây ngày? Môi tháng còn lai có mây ngày? nam Ðó có mây ngày?
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
