' CÁC BẠN DÙNG THỬ ĐOẠN MÃ SAU
' COPY VÀ DÁN VÀO 1 MODUL BẤT KỲ TRÊN VBA
' CÁCH DÙNG: VÍ DỤ: Solar2lunar(01,01,2009,7) số cuối là múi giờ
Option Explicit
Const PI As Double = 3.14159265358979
Function jdFromDate(ByVal dd As Long, ByVal mm As Long, ByVal yy As Long) As Long
Dim a As Double, y As Long, m As Long, jd As Long
a = Fix((14 - mm) / 12)
y = yy + 4800 - a
m = mm + 12 * a - 3
jd = dd + Fix((153 * m + 2) / 5) + 365 * y _
+ Fix(y / 4) - Fix(y / 100) + Fix(y / 400) - 32045
If jd < 2299161 Then
jd = dd + Fix((153 * m + 2) / 5) + 365 * y + Fix(y / 4) - 32083
End If
jdFromDate = jd
End Function
Function jdToDate(ByVal jd As Long)
Dim a As Long, b As Long, c As Long, d As Long, e As Long, m As Long
Dim Day As Long, Month As Long, Year As Long
If (jd > 2299160) Then
a = jd + 32044
b = Fix((4 * a + 3) / 146097)
c = a - Fix((b * 146097) / 4)
Else
b = 0
c = jd + 32082
End If
d = Fix((4 * c + 3) / 1461)
e = c - Fix((1461 * d) / 4)
m = Fix((5 * e + 2) / 153)
Day = e - Fix((153 * m + 2) / 5) + 1
Month = m + 3 - 12 * Fix(m / 10)
Year = b * 100 + d - 4800 + Fix(m / 10)
jdToDate = Array(Day, Month, Year)
End Function
Function NewMoon(ByVal k As Long) As Double
Dim T As Double, T2 As Double, T3 As Double, dr As Double
Dim Jd1 As Double, m As Double, Mpr As Double
Dim F As Double, C1 As Double, deltat As Double, JdNew As Double
T = k / 1236.85
T2 = T * T
T3 = T2 * T
dr = PI / 180
Jd1 = 2415020.75933 + 29.53058868 * k + 0.0001178 * T2 - 0.000000155 * T3
Jd1 = Jd1 + 0.00033 * Sin((166.56 + 132.87 * T - 0.009173 * T2) * dr)
m = 359.2242 + 29.10535608 * k - 0.0000333 * T2 - 0.00000347 * T3
Mpr = 306.0253 + 385.81691806 * k + 0.0107306 * T2 + 0.00001236 * T3
F = 21.2964 + 390.67050646 * k - 0.0016528 * T2 - 0.00000239 * T3
C1 = (0.1734 - 0.000393 * T) * Sin(m * dr) + 0.0021 * Sin(2 * dr * m)
C1 = C1 - 0.4068 * Sin(Mpr * dr) + 0.0161 * Sin(dr * 2 * Mpr)
C1 = C1 - 0.0004 * Sin(dr * 3 * Mpr)
C1 = C1 + 0.0104 * Sin(dr * 2 * F) - 0.0051 * Sin(dr * (m + Mpr))
C1 = C1 - 0.0074 * Sin(dr * (m - Mpr)) + 0.0004 * Sin(dr * (2 * F + m))
C1 = C1 - 0.0004 * Sin(dr * (2 * F - m)) - 0.0006 * Sin(dr * (2 * F + Mpr))
C1 = C1 + 0.001 * Sin(dr * (2 * F - Mpr)) + 0.0005 * Sin(dr * (2 * Mpr + m))
If (T < -11) Then
deltat = 0.001 + 0.000839 * T + 0.0002261 * T2 _
- 0.00000845 * T3 - 0.000000081 * T * T3
Else
deltat = -0.000278 + 0.000265 * T + 0.000262 * T2
End If
JdNew = Jd1 + C1 - deltat
NewMoon = JdNew
End Function
Function SunLongitude(ByVal jdn As Double) As Double
Dim T As Double, T2 As Double, dr As Double, m As Double
Dim L0 As Double, DL As Double, L As Double
T = (jdn - 2451545) / 36525
T2 = T * T
dr = PI / 180
m = 357.5291 + 35999.0503 * T - 0.0001559 * T2 - 0.00000048 * T * T2
L0 = 280.46645 + 36000.76983 * T + 0.0003032 * T2
DL = (1.9146 - 0.004817 * T - 0.000014 * T2) * Sin(dr * m)
DL = DL + (0.019993 - 0.000101 * T) * Sin(dr * 2 * m) _
+ 0.00029 * Sin(dr * 3 * m)
L = L0 + DL
L = L * dr
L = L - PI * 2 * (Fix(L / (PI * 2)))
SunLongitude = L
End Function
Function getSunLongitude(ByVal dayNumber As Double, ByVal timeZone As Byte) As Long
getSunLongitude = Fix(SunLongitude(dayNumber - 0.5 - timeZone / 24) / PI * 6)
End Function
Function getNewMoonDay(ByVal k As Long, ByVal timeZone As Long) As Long
getNewMoonDay = Fix(NewMoon(k) + 0.5 + timeZone / 24)
End Function
Function getLunarMonth11(ByVal yy As Long, ByVal timeZone As Long) As Long
Dim k As Long, off As Double, nm As Long, sunLong As Double
off = jdFromDate(31, 12, yy) - 2415021
k = Fix(off / 29.530588853)
nm = getNewMoonDay(k, timeZone)
sunLong = getSunLongitude(nm, timeZone)
If (sunLong >= 9) Then
nm = getNewMoonDay(k - 1, timeZone)
End If
getLunarMonth11 = nm
End Function
Function getLeapMonthOffset(ByVal a11 As Double, ByVal timeZone As Long) As Long
Dim k As Long, last As Long, Arc As Long, I As Long
k = Fix((a11 - 2415021.07699869) / 29.530588853 + 0.5)
last = 0
I = 1
Arc = getSunLongitude(getNewMoonDay(k + I, timeZone), timeZone)
Do
last = Arc
I = I + 1
Arc = getSunLongitude(getNewMoonDay(k + I, timeZone), timeZone)
Loop While (Arc <> last And I < 14)
getLeapMonthOffset = I - 1
End Function
Function Solar2Lunar( _
ByVal dd As Long, _
ByVal mm As Long, _
Optional ByVal yy As Long = 0, _
Optional ByVal timeZone As Long = 7) As String
Dim k As Long, diff As Long, leapMonthDiff As Long, dayNumber As Long
Dim monthStart As Double, a11 As Long, b11 As Long
Dim lunarDay As Double, lunarMonth As Long, lunarYear As Long, lunarLeap As Long
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If yy = 0 Then yy = Year(Date)
dayNumber = jdFromDate(dd, mm, yy)
k = Fix((dayNumber - 2415021.07699869) / 29.530588853)
monthStart = getNewMoonDay(k + 1, timeZone)
If (monthStart > dayNumber) Then
monthStart = getNewMoonDay(k, timeZone)
End If
a11 = getLunarMonth11(yy, timeZone)
b11 = a11
If (a11 >= monthStart) Then
lunarYear = yy
a11 = getLunarMonth11(yy - 1, timeZone)
Else
lunarYear = yy + 1
b11 = getLunarMonth11(yy + 1, timeZone)
End If
lunarDay = dayNumber - monthStart + 1
diff = Fix((monthStart - a11) / 29)
lunarLeap = 0
lunarMonth = diff + 11
If (b11 - a11 > 365) Then
leapMonthDiff = getLeapMonthOffset(a11, timeZone)
If (diff >= leapMonthDiff) Then
lunarMonth = diff + 10
If (diff = leapMonthDiff) Then lunarLeap = 1
End If
End If
If (lunarMonth > 12) Then lunarMonth = lunarMonth - 12
If (lunarMonth >= 11 And diff < 4) Then lunarYear = lunarYear - 1
Solar2Lunar = Format(lunarDay, "00") & _
"/" & Format(lunarMonth, "00") & _
"/" & Format(lunarYear, "0000 \A\L") & IIf(lunarLeap, " (" & lunarMonth & " N)", "")
End Function
Function Lunar2Solar( _
ByVal lunarDay As Long, _
ByVal lunarMonth As Long, _
Optional ByVal lunarYear As Long = 0, _
Optional ByVal lunarLeap As Long = 0, _
Optional ByVal timeZone As Long = 7) As Date
Dim k As Long, a11 As Long, b11 As Long, off As Long, leapOff As Long
Dim LeapMonth As Long, monthStart As Long
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If lunarYear = 0 Then lunarYear = Year(Date)
If (lunarMonth < 11) Then
a11 = getLunarMonth11(lunarYear - 1, timeZone)
b11 = getLunarMonth11(lunarYear, timeZone)
Else
a11 = getLunarMonth11(lunarYear, timeZone)
b11 = getLunarMonth11(lunarYear + 1, timeZone)
End If
k = Fix(0.5 + (a11 - 2415021.07699869) / 29.530588853)
off = lunarMonth - 11
If (off < 0) Then off = off + 12
If (b11 - a11 > 365) Then
leapOff = getLeapMonthOffset(a11, timeZone)
LeapMonth = leapOff - 2
If (LeapMonth < 0) Then LeapMonth = LeapMonth + 12
If (lunarLeap <> 0 And lunarMonth <> LeapMonth) Then
Lunar2Solar = Array(0, 0, 0)
Exit Function
ElseIf (lunarLeap <> 0 Or off >= leapOff) Then
off = off + 1
End If
End If
monthStart = getNewMoonDay(k + off, timeZone)
Dim R
R = jdToDate(monthStart + lunarDay - 1)
Lunar2Solar = Date******(R(2), R(1), R(0))
End Function
