'---------------------------------------------------------------------------------------- Imports System.Math
Public Class clsLunar Private Const Pi = 3.14159265358979 Private ThienCan() As String = {"Gi�p", "?t", "B�nh", "�inh", "M?u", "K?", "Canh", "T�n", "Nh�m", "Qu�"} Private DiaChi() As String = {"T�", "S?u", "D?n", "M�o", "Th�n", "T?", "Ng?", "M�i", "Th�n", "D?u", "Tu?t", "H?i"} Private VDayNameOfWeek() As String = {"Ch? nh?t", "Th? hai", "Th? ba", "Th? tu", "Th? nam", "Th? s�u", "Th? b?y"} Private TietKhi() As String = {"Xu�n ph�n", "Thanh Minh", "C?c vu", "L?p h?", "Ti?u m�n", "Mang ch?ng", "H? ch�", "Ti?u th?", _ "�?i th?", "L?p thu", "X? th?", "B?ch l?", "Thu ph�n", "H�n l?", "Suong gi�ng", "L?p d�ng", _ "Ti?u tuy?t", "�?i tuy?t", "��ng ch�", "Ti?u h�n", "�?i h�n", "L?p xu�n", "Vu th?y", "K�nh tr?p"}
Public Structure FakeDate Dim fdDay As Double Dim fdMonth As Double Dim fdYear As Double
Sub New(ByVal d As Date) fdDay = d.Day fdMonth = d.Month fdYear = d.Year End Sub
Public Shadows Function ToString() Return fdDay & "/" & fdMonth & "/" & fdYear End Function End Structure
Public Structure AllLunarInfo Dim sDayNameOfWeek As String ' T�n ng�y trong tu?n Dim fdLunarDate As FakeDate ' Ng�y, th�ng, nam �m l?ch Dim dDayOfLeap As Double ' Thu?c th�ng nhu?n = 1 Dim dLeap As Double ' Th�ng nhu?n = 0 l� kh�ng c� Dim dLeapMonth As Double ' N?u c� th�ng nhu?n, tr? v? th�ng d� Dim fdLeap2SolarFrom As FakeDate ' Tuong ?ng v?i ng�y duong l?ch: t? Dim fdLeap2SolarTo As FakeDate ' Tuong ?ng v?i ng�y duong l?ch: d?n Dim dMonthLenght As Double ' S? ng�y trong th�ng, n?u > 29 th� l� th�ng d? Dim sVMonthName As String ' T�n th�ng g?i theo �m l?ch Dim sDayCanChi As String Dim sMonthCanChi As String Dim sYearCanChi As String Dim sHourCanChi As String Dim sTietKhi As String Dim fdStartSolarDateTietKhi As FakeDate ' Ng�y d?u ti?t kh� theo Duong l?ch Dim fdStartLunarDateTietKhi As FakeDate ' Ng�y d?u ti?t kh� theo �m l?ch
Public Function ToLunarDate() As String ' �?nh d?ng ng�y th�ng theo �m l?ch. V� d?: 20/11 nam Canh D?n Return fdLunarDate.fdDay & "/" & fdLunarDate.fdMonth & " nam " & sYearCanChi End Function
Public Function ToLunarTietKhi() As String ' �?nh d?ng ng�y th�ng theo �m l?ch. V� d?: 20/11 nam Canh D?n Return fdStartLunarDateTietKhi.fdDay & "/" & fdStartLunarDateTietKhi.fdMonth & " nam " & sYearCanChi End Function End Structure
Private Function JuliusDays(ByVal dDay As Double, ByVal dMonth As Double, ByVal dYear As Double) As Double 'Done Dim dD As Double, dM As Double, dY As Double
On Error GoTo Err_WrongDate dD = Int((14 - dMonth) / 12) dY = dYear + 4800 - dD dM = dMonth + 12 * dD - 3
JuliusDays = dDay + Int((153 * dM + 2) / 5) + 365 * dY + Int(dY / 4) - Int(dY / 100) + Int(dY / 400) - 32045
If JuliusDays < 2299161 Then JuliusDays = dDay + Int((153 * dM + 2) / 5) + 365 * dY + Int(dY / 4) - 32083 End If Exit Function
Err_WrongDate: JuliusDays = -1 End Function
Private Function JuliusDays2Date(ByVal JDNumber As Double) As FakeDate 'Done Dim dA As Double, dB As Double, dC As Double, dD As Double Dim dE As Double, dM As Double
On Error GoTo Err_CantCalc With JuliusDays2Date If JDNumber < 2299161 Then dA = JDNumber Else dM = Int((JDNumber - 1867216.25) / 36524.25) dA = JDNumber + 1 + dM - Int(dM / 4) End If dB = dA + 1524 dC = Int((dB - 122.1) / 365.25) dD = Int(365.25 * dC) dE = Int((dB - dD) / 30.6001) .fdDay = Int(dB - dD - Int(30.6001 * dE)) If dE < 14 Then .fdMonth = dE - 1 Else .fdMonth = dE - 13 End If If .fdMonth < 3 Then .fdYear = dC - 4715 Else .fdYear = dC - 4716 End If End With Exit Function
Err_CantCalc: With JuliusDays2Date .fdDay = -1 .fdMonth = -1 .fdYear = -1 End With End Function
Private Function GetNewMoonDay(ByVal NMPos As Double, ByVal dTimeZone As Double) As Double 'Done 'Return Julius Day at New Moon position from 01/01/1900 Dim dT1 As Double, dT2 As Double, dT3 As Double Dim dDr As Double, dJD1 As Double, dM As Double Dim dMpr As Double, dF As Double, dC1 As Double Dim dDelta As Double, dJDNew As Double
dT1 = NMPos / 1236.85 dT2 = dT1 * dT1 dT3 = dT2 * dT1
dDr = Pi / 180 dJD1 = 2415020.75933 + 29.53058868 * NMPos + 0.0001178 * dT2 - 0.000000155 * dT3 dJD1 = dJD1 + 0.00033 * Sin((166.56 + 132.87 * dT1 - 0.009173 * dT2) * dDr) dM = 359.2242 + 29.10535608 * NMPos - 0.0000333 * dT2 - 0.00000347 * dT3 dMpr = 306.0253 + 385.81691806 * NMPos + 0.0107306 * dT2 + 0.00001236 * dT3 dF = 21.2964 + 390.67050646 * NMPos - 0.0016528 * dT2 - 0.00000239 * dT3 dC1 = (0.1734 - 0.000393 * dT1) * Sin(dM * dDr) + 0.0021 * Sin(2 * dDr * dM) dC1 = dC1 - 0.4068 * Sin(dMpr * dDr) + 0.0161 * Sin(dDr * 2 * dMpr) dC1 = dC1 - 0.0004 * Sin(dDr * 3 * dMpr) dC1 = dC1 + 0.0104 * Sin(dDr * 2 * dF) - 0.0051 * Sin(dDr * (dM + dMpr)) dC1 = dC1 - 0.0074 * Sin(dDr * (dM - dMpr)) + 0.0004 * Sin(dDr * (2 * dF + dM)) dC1 = dC1 - 0.0004 * Sin(dDr * (2 * dF - dM)) - 0.0006 * Sin(dDr * (2 * dF + dMpr)) dC1 = dC1 + 0.001 * Sin(dDr * (2 * dF - dMpr)) + 0.0005 * Sin(dDr * (2 * dMpr + dM))
If dT1 < -11 Then dDelta = 0.001 + 0.000839 * dT1 + 0.0002261 * dT2 - 0.00000845 * dT3 - 0.000000081 * dT1 * dT3 Else dDelta = -0.000278 + 0.000265 * dT1 + 0.000262 * dT2 End If
dJDNew = dJD1 + dC1 - dDelta GetNewMoonDay = Int(dJDNew + 0.5 + dTimeZone / 24) End Function
Private Function SunLongitude(ByVal dJD As Double, ByVal dTimeZone As Double) As Double 'Done Dim dT1 As Double, dT2 As Double, dDr As Double Dim dM As Double, dL0 As Double, dDL As Double Dim dL As Double
dT1 = (dJD - 2451545.5 - dTimeZone / 24) / 36525 dT2 = dT1 * dT1 dDr = Pi / 180
dM = 357.5291 + 35999.0503 * dT1 - 0.0001559 * dT2 - 0.00000048 * dT1 * dT2 dL0 = 280.46645 + 36000.76983 * dT1 + 0.0003032 * dT2 dDL = (1.9146 - 0.004817 * dT1 - 0.000014 * dT2) * Sin(dDr * dM) dDL = dDL + (0.019993 - 0.000101 * dT1) * Sin(dDr * 2 * dM) + 0.00029 * Sin(dDr * 3 * dM) dL = dL0 + dDL dL = dL * dDr dL = dL - Pi * 2 * Int(dL / (Pi * 2))
SunLongitude = Int(dL / Pi * 6) End Function
Private Function SunLongitude2(ByVal dJD As Double) As Double 'Done Dim dT1 As Double, dT2 As Double, dDr As Double Dim dM As Double, dL0 As Double, dDL As Double Dim dL As Double
dT1 = (dJD - 2451545) / 36525 dT2 = dT1 * dT1 dDr = Pi / 180
dM = 357.5291 + 35999.0503 * dT1 - 0.0001559 * dT2 - 0.00000048 * dT1 * dT2 dL0 = 280.46645 + 36000.76983 * dT1 + 0.0003032 * dT2 dDL = (1.9146 - 0.004817 * dT1 - 0.000014 * dT2) * Sin(dDr * dM) dDL = dDL + (0.019993 - 0.000101 * dT1) * Sin(dDr * 2 * dM) + 0.00029 * Sin(dDr * 3 * dM) dL = dL0 + dDL dL = dL * dDr dL = dL - Pi * 2 * Int(dL / (Pi * 2))
SunLongitude2 = dL End Function
Private Function GetSunLongitude(ByVal dJD As Double, ByVal dTimeZone As Double) As Double GetSunLongitude = Int(SunLongitude2(dJD - 0.5 - dTimeZone / 24) / Pi * 12) End Function
Private Function GetLunarMonth11th(ByVal dYear As Double, ByVal dTimeZone As Double) As Double 'Done Dim dK As Double, dOff As Double, sunLong As Double Dim NM As Double
dOff = JuliusDays(31, 12, dYear) - 2415021 dK = Int(dOff / 29.530588853) NM = GetNewMoonDay(dK, dTimeZone) sunLong = SunLongitude(NM, dTimeZone)
If sunLong >= 9 Then NM = GetNewMoonDay(dK - 1, dTimeZone)
GetLunarMonth11th = NM End Function
Private Function GetLeapMonthOffset(ByVal dMonth11th As Double, ByVal dTimeZone As Double) As Double 'Done Dim dK As Double, dLast As Double, dArc As Double, i As Integer
dK = Int((dMonth11th - 2415021.07699869) / 29.530588853 + 0.5) dLast = 0 i = 1 dArc = SunLongitude(GetNewMoonDay(dK + i, dTimeZone), dTimeZone) Do dLast = dArc i = i + 1 dArc = SunLongitude(GetNewMoonDay(dK + i, dTimeZone), dTimeZone) Loop While (dArc <> dLast And i < 14)
GetLeapMonthOffset = i - 1 End Function
Public Function Solar2Lunar(ByVal dDay As Double, ByVal dMonth As Double, ByVal dYear As Double, ByVal dTimeZone As Double) As FakeDate Dim dK As Double, dDayNum As Double, dMonthStart As Double Dim dF11 As Double, dS11 As Double, dLunarDay As Double Dim dLunarMonth As Double, dLunarYear As Double, dLunarLeap As Double Dim dDiff As Double, dLeapMonthDiff As Double
dDayNum = JuliusDays(dDay, dMonth, dYear) dK = Int((dDayNum - 2415024.07699869) / 29.530588853) dMonthStart = GetNewMoonDay(dK + 1, dTimeZone) If dMonthStart > dDayNum Then dMonthStart = GetNewMoonDay(dK, dTimeZone) dF11 = GetLunarMonth11th(dYear, dTimeZone) dS11 = dF11 If dF11 > dMonthStart Then dLunarYear = dYear dF11 = GetLunarMonth11th(dYear - 1, dTimeZone) Else dLunarYear = dYear + 1 dS11 = GetLunarMonth11th(dYear + 1, dTimeZone) End If dLunarDay = dDayNum - dMonthStart + 1 dDiff = Int((dMonthStart - dF11) / 29) dLunarLeap = 0 dLunarMonth = dDiff + 11 If (dS11 - dF11) > 365 Then dLeapMonthDiff = GetLeapMonthOffset(dF11, dTimeZone) If dDiff >= dLeapMonthDiff Then dLunarMonth = dDiff + 10 If dDiff = dLeapMonthDiff Then dLunarLeap = 1 End If End If If dLunarMonth > 12 Then dLunarMonth = dLunarMonth - 12 If dLunarMonth >= 11 And dDiff < 4 Then dLunarYear = dLunarYear - 1 Solar2Lunar.fdDay = dLunarDay Solar2Lunar.fdMonth = dLunarMonth Solar2Lunar.fdYear = dLunarYear End Function
Public Function Lunar2Solar(ByVal dLunarDay As Double, ByVal dLunarMonth As Double, ByVal dLunarYear As Double, ByVal dLunarLeap As Double, ByVal dTimeZone As Double) As FakeDate Dim dK As Double, dF11 As Double, dS11 As Double Dim dOff As Double, dLeapOff As Double, dLeapMonth As Double Dim dMonthStart As Double If dLunarMonth < 11 Then dF11 = GetLunarMonth11th(dLunarYear - 1, dTimeZone) dS11 = GetLunarMonth11th(dLunarYear, dTimeZone) Else dF11 = GetLunarMonth11th(dLunarYear, dTimeZone) dS11 = GetLunarMonth11th(dLunarYear + 1, dTimeZone) End If dOff = dLunarMonth - 11 If dOff < 0 Then dOff = dOff + 12 If (dS11 - dF11) > 365 Then dLeapOff = GetLeapMonthOffset(dF11, dTimeZone) dLeapMonth = dLeapOff - 2 If dLeapMonth < 0 Then dLeapMonth = dLeapMonth + 12 If dLunarLeap <> 0 And dLunarMonth <> dLeapMonth Then Lunar2Solar.fdDay = 0 Lunar2Solar.fdMonth = 0 Lunar2Solar.fdYear = 0 ElseIf dLunarLeap <> 0 Or dLunarMonth <> dLeapMonth Then dOff = dOff + 1 End If End If dK = Int(0.5 + (dF11 - 2415021.07699869) / 29.530588853) dMonthStart = GetNewMoonDay(dK + dOff, dTimeZone) With JuliusDays2Date(dMonthStart + dLunarDay - 1) Lunar2Solar.fdDay = .fdDay Lunar2Solar.fdMonth = .fdMonth Lunar2Solar.fdYear = .fdYear End With End Function
'---------------------------------------------------------------------------------------- '* Test, Edit and Translate by vie87vn - www.caulacbovb.com '---------------------------------------------------------------------------------------- Public Function GetAllLunarInfo(ByVal dDay As Double, ByVal dMonth As Double, ByVal dYear As Double, ByVal dTimeZone As Double) As AllLunarInfo Dim i As Integer, dJD As Double, dLLeap As Double Dim dLDay As Double, dLMonth As Double, dLYear As Double Dim dMonthLen As Double Dim dLM As Double, iPos As Integer, iCan As Integer, iChi As Integer
iPos = ((JuliusDays(dDay, dMonth, dYear) + 1) Mod 7)
With Solar2Lunar(dDay, dMonth, dYear, dTimeZone) dLDay = .fdDay dLMonth = .fdMonth dLYear = .fdYear End With
dLM = GetLeapMonthOffset(GetLunarMonth11th(dLYear, dTimeZone), dTimeZone) If dLM > 2 Then dLM = GetLeapMonthOffset(GetLunarMonth11th(dLYear - 1, dTimeZone), dTimeZone) End If If dLM < 13 Then dLM = dLM - 2 If dLM <= 0 Then dLM = dLM + 12 dLLeap = IIf(dLM > 12, 0, 1) Dim dSDay As Double, dSMonth As Double, dSYear As Double dSDay = Lunar2Solar(1, dLMonth, dLYear, dLLeap, dTimeZone).fdDay dSMonth = Lunar2Solar(1, dLMonth, dLYear, dLLeap, dTimeZone).fdMonth dSYear = Lunar2Solar(1, dLMonth, dLYear, dLLeap, dTimeZone).fdYear dJD = JuliusDays(dSDay, dSMonth, dSYear) For i = 25 To 31 If Solar2Lunar(JuliusDays2Date(dJD + i).fdDay, JuliusDays2Date(dJD + i).fdMonth, JuliusDays2Date(dJD + i).fdYear, dTimeZone).fdDay = 1 Then Exit For End If Next i dMonthLen = i
With GetAllLunarInfo .sDayNameOfWeek = VDayNameOfWeek(iPos) .fdLunarDate.fdDay = dLDay .fdLunarDate.fdMonth = dLMonth .fdLunarDate.fdYear = dLYear .dLeap = dLLeap .dLeapMonth = IIf(dLM > 12, 0, dLM) .dMonthLenght = dMonthLen iCan = (JuliusDays(dDay, dMonth, dYear) + 9) Mod 10 iChi = (JuliusDays(dDay, dMonth, dYear) + 1) Mod 12 .sDayCanChi = ThienCan(iCan) & " " & DiaChi(iChi) iCan = (iCan * 2) Mod 10 iChi = 0 .sHourCanChi = ThienCan(iCan) & " " & DiaChi(iChi) iCan = (dLYear * 12 + dLMonth + 3) Mod 10 iChi = IIf((dLMonth - 11) < 0, dLMonth + 1, dLMonth - 11) .sMonthCanChi = ThienCan(iCan) & " " & DiaChi(iChi) iCan = (dLYear + 6) Mod 10 iChi = (dLYear + 8) Mod 12 .sYearCanChi = ThienCan(iCan) & " " & DiaChi(iChi) .dDayOfLeap = 0 If dLLeap = 1 Then .fdLeap2SolarFrom.fdDay = Lunar2Solar(1, .dLeapMonth, dLYear, dLLeap, dTimeZone).fdDay .fdLeap2SolarFrom.fdMonth = Lunar2Solar(1, .dLeapMonth, dLYear, dLLeap, dTimeZone).fdMonth .fdLeap2SolarFrom.fdYear = Lunar2Solar(1, .dLeapMonth, dLYear, dLLeap, dTimeZone).fdYear dJD = JuliusDays(.fdLeap2SolarFrom.fdDay, .fdLeap2SolarFrom.fdMonth, .fdLeap2SolarFrom.fdYear) For i = 25 To 31 If Solar2Lunar(JuliusDays2Date(dJD + i).fdDay, JuliusDays2Date(dJD + i).fdMonth, JuliusDays2Date(dJD + i).fdYear, dTimeZone).fdDay = 1 Then Exit For End If Next i dJD = dJD + i - 1 .fdLeap2SolarTo.fdDay = JuliusDays2Date(dJD).fdDay .fdLeap2SolarTo.fdMonth = JuliusDays2Date(dJD).fdMonth .fdLeap2SolarTo.fdYear = JuliusDays2Date(dJD).fdYear If dMonth = .fdLeap2SolarFrom.fdMonth Then If dDay >= .fdLeap2SolarFrom.fdDay Then .dDayOfLeap = 1 Else .dDayOfLeap = 0 ElseIf dMonth = .fdLeap2SolarTo.fdMonth Then If dDay <= .fdLeap2SolarTo.fdDay Then .dDayOfLeap = 1 Else .dDayOfLeap = 0 Else .dDayOfLeap = 0 End If Else .fdLeap2SolarFrom.fdDay = 0 .fdLeap2SolarFrom.fdMonth = 0 .fdLeap2SolarFrom.fdYear = 0 .fdLeap2SolarTo.fdDay = 0 .fdLeap2SolarTo.fdMonth = 0 .fdLeap2SolarTo.fdYear = 0 End If iPos = GetSunLongitude(JuliusDays(dDay, dMonth, dYear) + 1, dTimeZone) .sTietKhi = TietKhi(iPos) dJD = JuliusDays(dDay, dMonth, dYear) + 1 For i = 0 To 20 If GetSunLongitude(dJD - i, dTimeZone) <> iPos Then Exit For Next i .fdStartSolarDateTietKhi.fdDay = JuliusDays2Date(dJD - i).fdDay .fdStartSolarDateTietKhi.fdMonth = JuliusDays2Date(dJD - i).fdMonth .fdStartSolarDateTietKhi.fdYear = JuliusDays2Date(dJD - i).fdYear .fdStartLunarDateTietKhi.fdDay = Solar2Lunar(.fdStartSolarDateTietKhi.fdDay, .fdStartSolarDateTietKhi.fdMonth, .fdStartSolarDateTietKhi.fdYear, dTimeZone).fdDay .fdStartLunarDateTietKhi.fdMonth = Solar2Lunar(.fdStartSolarDateTietKhi.fdDay, .fdStartSolarDateTietKhi.fdMonth, .fdStartSolarDateTietKhi.fdYear, dTimeZone).fdMonth .fdStartLunarDateTietKhi.fdYear = Solar2Lunar(.fdStartSolarDateTietKhi.fdDay, .fdStartSolarDateTietKhi.fdMonth, .fdStartSolarDateTietKhi.fdYear, dTimeZone).fdYear .sVMonthName = VMonthName(dLMonth) End With End Function
Private Function VMonthName(ByVal dMonth As Double) As String 'truongphu, c� u'ng dung v�o picLunarInfo Dim uu() As String uu = Split("gi�ng,hai,ba,tu,nam,s�u,b?y,t�m,ch�n,mu?i,mu?i m?t,ch?p", ",") VMonthName = "Th�ng " & uu(dMonth - 1) End Function End Class
-------------
Qu� Huong
|