Ngôn ngữ lập trình: VB6
Tác giả: Nguyễn Quốc Sản. truongphu bổ sung nhỏ
Chức năng: Module chuyển Dương Lich sang Âm lịch
Module chuyển Dương Lich sang Âm lịch nầy do tác giả Nguyễn Quốc Sản viết trực tiếp bằng VB6.
Đăng trên website của tác giả Hồ Ngọc Đức.
(Khác với các module trước dịch từ java sang vb6)
Tôi (truongphu) có bổ sung thêm function NamÂmLich
và ở Function Solar2Lunar của tác giả Nguyễn Quốc Sản, tôi (tp) tạm ngừng kết quả trả về,
để bổ sung vào đó năm Âm lịch theo tên gọi, chứ không mang số của DL
Module:
- Option Explicit ' Nguyê~n Quô'c Sa?n
- Const PI As Double = 3.14159265358979 ' Atn(1) * 4
- 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 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 ' Time in Julian centuries from 1900 January 0.5
- 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
- ' Time in Julian centuries from 2000-01-01 12:00:00 GMT
- T2 = T * T
- dr = PI / 180 ' degree to radian
- 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 ' true longitude, degree
- L = L * dr
- L = L - PI * 2 * (Fix(L / (PI * 2))) ' Normalize to (0, 2*PI)
- 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) ' sun longitude at local midnight
- 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 ' We start with the month following lunar month 11
- 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
- ' NguyenQuocSan
- 'Solar2Lunar = Format(lunarDay, "00") & _
- "/" & Format(lunarMonth, "00") & _
- "/" & Format(lunarYear, "0000 \A\L") & IIf(lunarLeap, " (" & lunarMonth & " N)", "")
- 'truongphu bô sung
- Dim NamAL$: NamAL = NamÂmLich(lunarYear) & IIf(lunarLeap, " (" & lunarMonth & " N)", "")
- Solar2Lunar = Format(lunarDay, "00") & _
- "/" & Format(lunarMonth, "00") & "/" & NamAL
- End Function
- Function NamÂmLich(ByVal year As Long) As String
- Dim Can$(), Chi$() ' truongphu
- Can = Split("Canh,Tân,Nhâm,Qúy,Giáp,Ât,Bính,Ðinh,Mâu,Ky", ",")
- Chi = Split("Thân,Dâu,Tuât,Ho'i,Tý,Suu,Dân,Mao,Thìn,Ty,Ngo,Mùi", ",")
- NamÂmLich = Can(year Mod 10) & " " & Chi(year Mod 12)
- End Function
- untitled.JPG (15.95 KiB) Đã xem 4006 lần
Hay không?
Project sử dụng module như hình minh họa:
