Public Class Clschinaday
Private Solarmonth (12) AS INTEGER 'Soluk 12 months of days Private Solarterm (24) AS STRING' 气 Private Sterminfo (24) AS Double '节 信息 的 信息 l 码 l 19 l (150) As Double' from 1900-2049 This 150 years of the lunar calendar information code private newlunarinfo () AS STRING
Public Structure ChinaDateInfo Dim WestDate As String 'Western calendar Dim WeekDate As String' week Dim ChinaDate As String 'Lunar Date Dim Animal As String' is a like Dim Term As String 'throttle Dim RestDay As String' holiday Dim AllInfo As String 'all information End Structure
Function BackChina (ByRef OldDate As String) As String 'The return date Chinese name Dim NumberToChina (10) As String Dim CurYear As Integer Dim DayName (30) As String Dim MonName (12) As String Dim TianGan (10) As String Dim DiZhi (12) AS STRING DIM STRTEMP AS STRING DIM II AS INTEGER
ON Error ResMe next 'Chinese Numbertochina (0) = "Zero" Numbertochina (1) = "One" Numertochina (2) = "Two" Numbertochina (3) = "Three" Numertochina (4) = "4" Numbertochina (5 " ) = "Five" Numbertochina (6) = "six" Numbertochina (7) = "seven" Numbertochina (8) = "eight" Numbertochina (9) = "" "Lunar Date name dayName (0) =" * "dayname (1) = "First" DayName (2) = "Junior" DayName (3) = "First Three" DayName (4) = "First Four" DayName (5) = "First Five" DayName (6) = " Sixth "dayname (7) =" first seven "daysname (8) =" first eight "dayname (9) =" first nine "daysName (10) =" first ten "dayname (11) =" 11 "daysname 12) = "twelve" daysname (13) = "13" daysname (14) = "14" daysName (15) = "fifteen" daysname (16) = "16" daysname (17) = " Seven "dayname (18) =" 18 "dayname (19) =" 19 "daysname (20) =" twenty "dayname (21) =" 一 "dayname (22) =" 二 "daysname (23 ) = "三" daysname (24) = "四" daynam e (25) = "五" daysname (26) = "六" daysname (27) = "廿七" dayname (28) = "八" daysName (29) = "九" daysname (30) = "Thirty" 'Lunar Month Monname (0) = "*" Monname (1) = "Positive"
Monname (2) = "II" Monname (3) = "Three" Monname (4) = "Four" Monname (5) = "Five" Monname (6) = "Six" Monname (7) = "Seven" Monname 8) = "eight" Monname (9) = "nine" Monname (10) = "10" Monname (11) = "11" Monname (12) = "La" 'Trunk Name Tiangan (0) = "A" Tiangan (1) = "" "tiangan (2) =" "tiangan (3) =" Ding "tiangan (4) =" "tiangan (5) =" "tiangan (6) =" "tiangan 7) = "Xin" tiangan (8) = "" tiangan (9) = "" 'floor name dizhi (0) = "子" dizhi (1) = "ugly" dizhi (2) = "寅" dizhi (3) = "" dizhi (4) = "Chen" dizhi (5) = "" dizhi (6) = "noon" dizhi (7) = "Dizhi (8) =" Shen "dizhi (9 ) = "" Dizhi (10) = "" dizhi (11) = "Hai" '' ' ) MOD 10) & dizhi ((Curyear - 4) MOD 60) MOD 12) & "Year" IF (Olddate, 1, 1) = "1" THEN BackCHINA = BACKCHINA & "" Backchina = Backchina & Monname (Cint (MID (Olddate, 6, 2))) & "Month" BackChina = Backchina & DayName (Cint (MID (Olddate, 8, 12)) End Function
'Returning Lunar Yenda Month Time Function LMONTHDAYS (Byval Y AS Integer, Byval M AS Integer) AS Integer on Error ResMe Next If Y <1900 THEN Y = 1900 IF (CDBL (Y - 1900 1) ) And int (& h10000 / (2 ^ m))) = 0 Then LMONTHDAYS = 29 Else LMONTHDAYS = 30 END if End Function 'Back Lunar Years Which month 1-12, no 闰 0 0 0 (Byval Y) As integer on error resume next leapmonth = 0 if y> = 1900 Then LeapMonth = (LunarInfo (Y - 1900 1) and & hfs) end function
'Subject to Lunu Ye Years Function LeapDays (Byval Y AS Integer) AS INTEGER ON Error ResMe Next Dim M AS INTEGER DIM L As Double M = LeapMonth (Y) IF M = 0 Then LeapDays = 0 else L = LunarInfo Y - 1900 1) IF L <0 THEN L = L * (-1) L = (l And & H10000) IF L = 0 Then LeapDays = 29 else LeaPDays = 30 end if end if End function
'Returning Lunu Yenda Function LyeardAys (Byval Y AS Integer) AS Integer Dim II, Sum as Double ON Error ResMe Next Sum = 0 for II = 1 To 12 Sum = Sum LMONTHDAYS (Y, II) Next LyeardAys = SUM LeApDays (Y) End Function
'Remove the talented song Y year M month of the day function solardays (byval y as integer, byval m as integer) AS integer on error resume next if m = 2 Then IF (y mod 4 = 0 and y mod 100 <> 0) Or (y Mod 400 = 0) Then SolarDays = 29 Else SolarDays = 28 End If Else SolarDays = SolarMonth (M) End If End Function 'return genus as Function Animal (ByVal sYear as Date) as String On Error Resume Next Dim The Year Shuxiang (12) As string 'genia name shuxiang (0) = "rat" shuxiang (1) = "cattle" shuxiang (2) = "Tiger" shuxiang (3) = "rabbit" shuxiang (4) = "Dragon" Shuxiang (5) = "snake" shuxiang (6) = "Ma" shuxiang (7) = "Sheep" shuxiang (8) = "Monkey" shuxiang (9) = "Chicken" shuxiang (10) = "Dog" Shuxiang (11 ) = "Pig" Animal = shuxiang ((Year (SYEAR) - 4) MOD 60) MOD 12) End Function
'According to a given Gregorian, lunar return date Function GetLunar (ByVal SolarDate As Date) As String Dim DaysOffset As Integer Dim II As Integer Dim Temp As Integer Dim lmonth, lyear, lday As Integer Dim Leap As Integer Dim IsLeap As Boolean
ON Error ResMe next
Daysoffset = Solardate.Tooadate - CDATE ("1900-1-31"). Tooadate II = 1900 do while II <2050 and daysoffset> = 0 Temp = LyearDays (ii) Daysoffset = daysoffset - Temp II = II 1 LOOP
If Daysoffset <0 Then DaySoffset = DaySoffset Temp II = II - 1 end if = ii leap = leapmonth (ii) isleap = false ii = 1 do while II <13 and daysoffset> 0 if leap> 0 and II = (Leap 1) And IsLeap = False Then II = II - 1 IsLeap = True Temp = LeapDays (lyear) Else Temp = lMonthDays (lyear, II) End If If IsLeap And II = (Leap 1) Then IsLeap = False DaysOffset = DaysOffset - Temp II = II 1 LoopIf DaysOffset = 0 And Leap> 0 And II = Leap 1 Then If IsLeap Then IsLeap = False Else IsLeap = True II = II - 1 End If End If If DaysOffset <0 Then DaysOffset = DaysOffset Temp II = II - 1 end if lmonth = ii lday = daysoffset 1 'Returns a string of special logo If isleap dam, = "1" & lyear & vb6.format (lmonth, "00") & vb6.format (LDAY, "00") Else getlunar = "0" & lyear & vb6.format (lmonth, "00" ) & Vb6.format (LDAY, "00") end if end function
'Northern Northern Volume (from 1 small cold) Function STERM (Byval y as object, byref n as ") AS Date on Error Resume Next Dim D1, D2 AS Double D1 = (31556925.9747 * (Y - 1900) Sterminfo (N) * 60.0 #) D2 = datediff (Microsoft.visualBasic.dateInterVal.second, CDATE ("1970-1-1 0: 0"), CDATE ("1900-1-6 2: 5") ) D1 D1 = D2 / 2 STERM = dateadd (Microsoft.VisualBasic.dateInterVal.second, D2 - D1, DateAdd (Microsoft.visualbasic.DateInterVal.second, D1, CDATE ("1970-1-1 0: 0"))) Sterm = cdate (VB6.Format (Sterm, "YYYY / MM / DD"))) End function 'Returns its soil according to the column, if not, return empty function getterm (Byval Sdate As Date) AS String Dim y, M AS Integer ON Error ResMe Next Y = Year (SDATE) M = Month (Sdate) getterm = "" IF STERM (Y, M * 2 - 1) = SDATE THEN GETTERM = SOLARTERM (M * 2 - 1) Elseif Sterm (Y, M * 2) = SDATE THEN getterm = solarterm (m * 2) end if end function
'Return to the proliferation is the first day of the month, such as: 0520 Representation May 2nd Sunday Function GetMonthweek (Byval SDATE AS DATE) AS STRING DIM D0 AS DATE ON Error Resume Next
D0 = cdate (Year (SDATE) & "-") getMonthWeek = VB6.Format (Month), "00") & (INT ((((((Microsoft.visualBasic.DateAndtime.day) (SDATE) - 1 WEEKDAY (D0) - 1) / 7) 1) & WeekDay (SDATE) - 1 END FUNCTION
Public Function GetChinaInfo (ByRef OldDate As Date) As ChinaDateInfo Dim II As Integer Dim StrTemp As String Dim StrDate As String Dim S1, S2 As String Dim sFtv (25) As String 'Gregorian holiday Dim lFtv (11) As String' Lunar Holiday DIM WFTV (11) AS String 'Western Festival On Error ResMe next' The error occurs after more than 2038, Olddate = cdate (VB6.Format (Olddate, "YYYY-MM-DD")) 'Qian calendar festival: The top four numbers are MMDD (month), the back of the text is SFTV (1) = "0101 * New Year" sftv (2) = "0214 Valentine's Day" SFTV (3) = "0308 Women's Day" SFTV ( 4) = "0312 Tree Plant Festival" SFTV (5) = "0315 Right Day" SFTV (6) = "" SFTV (7) = "0401 April Fool" SFTV (8) = "0501 * Labor Day" SFTV (9) = "0504 Youth Festival" SFTV (10) = "0512 Nurse" SFTV (11) = "0601 Children's Day" SFTV (12) = "0701" SFTV (13) = "" SFTV (14) = "0801 Jianjun Festival "SFTV (15) =" 0808 Father's Day "SFTV (16) =" 0909 Master "SFTV (17) =" 0910 Teacher's Day "SFTV (18) =" 0928 Confucius "sftv (19) = "1001 * National Day" SFTV (20) = "1006 Old People" SFTV (21) = "1024 United Nations Japanese "SFTV (22) =" 1112 Sun Yat-sen "sftv (23) =" 1220 Macau Return "SFTV (24) =" 1225 Christmas "SFTV (25) =" 1226 Mao Shi "
'Lunar Festival: Date is the lunar calendar to a certain day LFTV (1) = "0101 * Spring Festival" LFTV (2) = "0115 Lantern Festival" LFTV (3) = "0505 Dragon Boat Festival" LFTV (4) = "0707 Qixi Festival" LFTV (5) = "0715 Middle Instrument" LFTV (6) = "0815 Mid-Autumn Festival" LFTV (7) = "0909 Double NN Festival" LFTV (8) = "" LFTV (9) = "1208 Laba Festival "LFTV (10) =" 1224 Tedu "LFTV (11) =" 0100 * New Year's Eve "'According to the holiday calculated by week: If 0231 indicates the third Monday, the prism (1) =" "WFTV (2) = "0231 President Day" WFTV (3) = "0520 Mother's Day" WFTV (4) = "" WFTV (5) = "0531 Victory Day" WFTV (6) = "0716 Cooperative" WFTV (7) = "0730 Slave Week" WFTV (8) = "" WFTV (9) = "" WFTV (10) = "1021 Columbus Day" WFTV (11) = "1144 Thanksgiving" '******* ***********************
NewLunarInfo = Split (Replace ( "0x04bd8,0x04ae0,0x0a570,0x054d5,0x0d260,0x0d950,0x16554,0x056a0,0x09ad0,0x055d2," & "0x04ae0,0x0a5b6,0x0a4d0,0x0d250,0x1d255,0x0b540,0x0d6a0,0x0ada2,0x095b0,0x14977, "&" 0x04970,0x0a4b0,0x0b4b5,0x06a50,0x06d40,0x1ab54,0x02b60,0x09570,0x052f2,0x04970, "&" 0x06566,0x0d4a0,0x0ea50,0x06e95,0x05ad0,0x02b60,0x186e3,0x092e0,0x1c8d7,0x0c950, "&" 0x0d4a0 , 0x1d8a6,0x0b550,0x056a0,0x1a5b4,0x025d0,0x092d0,0x0d2b2,0x0a950,0x0b557, "&" 0x06ca0,0x0b550,0x15355,0x04da0,0x0a5d0,0x14573,0x052d0,0x0a9a8,0x0e950,0x06aa0, "&" 0x0aea6,0x0ab50,0x04b60 , 0x0aae4,0x0a570,0x05260,0x0f263,0x0d950,0x05b57,0x056a0, "&" 0x096d0,0x04dd5,0x04ad0,0x0a4d0,0x0d4d4,0x0d250,0x0d558,0x0b540,0x0b5a0,0x195a6, "&" 0x095b0,0x049b0,0x0a974,0x0a4b0,0x0b27a , 0x06a50,0x06d40,0x0af46,0x0ab60,0x09570, "&" 0x04af5,0x04970,0x064b0,0x074a3,0x0ea50,0x06b58,0x055c0,0x0ab60,0x096d5,0x092e0, "&" 0x0c960,0x0d954,0x0d4a0,0x0da50,0x07552,0x056a0,0x0abb7 0x025d0, 0x092d0, 0x0cab5, "&" 0x0a950, 0x0b4a0, 0x0baa4, 0x0ad50, 0x0 55d9,0x04ba0,0x0a5b0,0x15176,0x052b0,0x0a930, "&" 0x07954,0x06aa0,0x0ad50,0x05b52,0x04b60,0x0a6e6,0x0a4e0,0x0d260,0x0ea65,0x0d530, "&" 0x05aa0,0x076a3,0x096d0,0x04bd7,0x04ad0,0x0a4d0, 0x1D0B6, 0X0D250, 0X0D520, 0X0DD45, "&" 0x0B5A0, 0X056D0, 0X055B2, 0X049B0, 0X0A577, 0X0A4B0, 0X0Aa50, 0x1B255, 0X06D20, 0X0ADA0 "," 0x "," & H "),", ") for II = 1 TO 150 LunarInfo (II) = CDBL (Newlunarinfo (II - 1)) 'When the character is processed, it has been converted into a sixteen-entered Next
For ii = 1 to 12 Select Case II Case 1, 3, 5, 7, 8, 10, 12 Solarmons (II) = 31 Case 2 Solarmonth (II) = 28 Case Else Solarmonth (II) = 30 End Select Next = " Small cold, cold spring, rain, Spring, Spring, Spring, Qingming, Yuti, Xia Xia, Summer, Summer, Summer, Summer, Summer, Summer, Summer, Summer, Summer, White, Snow, Snow, Snow, Winter, S2 = "000000, 021208, 042467, 063836, 085551, 107014, 128867, 150921, 063149, 195551, 218072, 240693, 308563, 331033, 35330, 375494, 39747, 419210, 4440795, 462224, 483532, 504758 "For the throttle assignment for II = 1 to 24 solarterm (II) = MID (S1, (ii - 1) * 2 1, 2) Sterminfo (II) = VAL (MID (S2, (II - 1) * 7 1, 6)) Next
'节 节 s s = VB6.Format (Olddate, "MMDD") for II = 1 To Ubound (SFTV) IF SFTV (II) <> "" The IF MID (SFTV (II), 1, 4) = STRDATE THEN' Judging equal strTemp = Right (SFTV (II), LEN (SFTV (II)) - 4) EXIT for end if endiffate = Right (getlunar (cdate (olddate)), 4) for ii = 1 to Ubound (LFTV) IF LFTV (II) <> "" THEN IF MID (LFTV (II), 1, 4) = STRDATE 'Judgment equal If strtemp <> "" straTemp = strtemp & "," strTemp = Right (STRTEMP = Right LFTV (II), LEN (LFTV (II)) - 4) End if end if next 'Sun festival strdate = getMonthweek (cdate (olddate)) for ii = 1 To Ubound (WFTV) IF WFTV (II) <> "" THEN IF MID (WFTV (II), 1, 4) = STRDATE THEN 'Judgment equal If straTemp <> "" Thrtemp = strtemp & "," strTemp = Right (WFTV (II), LEN (WFTV (WFTV) II)) - 4) Endness information getchinainfo.westdate = vb6.format (cdate (olddate), "YYYY-MM-DD") getChinaInfo.chinadate = backchina (getlunar (cdate (cdate (cdate)) GetChinaInfo .Animal = Animal (OldDate) GetChinaInfo.Term = getTerm (OldDate) GetChinaInfo.RestDay = strTemp GetChinaInfo.WeekDate = WeekDayName (WeekDay (CDate (OldDate))) strTemp = "today is" & GetChinaInfo.WestDate & "(" & GetChinaInfo .Wekdate & "
), Lunar calendar "& getChinainfo.chinadate &" ["& get Chinafo.Animal &" "IF get Chinafo.Restday <>" "Ten Strtemp = Strtemp &" ["& getChinaInfo.Restday &"] "ife" i getChinaInfo.term <> "" THENSTEMP = strTemp & "[" & getChinaInfo.term & "]" getChinaInfo.allinfo = strTemp End Functionend Class
