农历类(VB)

原创 2004年10月05日 22:28:00
Public Class ClsChinaDay
    Private SolarMonth(12) As Integer '阳历12个月的天数
    Private SolarTerm(24) As String '阳历的节气
    Private sTermInfo(24) As Double '阳历节气的信息码
    Private LunarInfo(150) As Double '从1900-2049年这150年的农历信息码
    Private NewLunarInfo() As String
    Public Structure ChinaDateInfo
        Dim WestDate As String '西历
        Dim WeekDate As String '星期
        Dim ChinaDate As String '农历日期
        Dim Animal As String '属象
        Dim Term As String '节气
        Dim RestDay As String '节日
        Dim AllInfo As String '全部的信息
    End Structure
    Function BackChina(ByRef OldDate As String) As String
        '根据日期返回中文名称
        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 Resume Next
        '中文数字
        NumberToChina(0) = "零"
        NumberToChina(1) = "一"
        NumberToChina(2) = "二"
        NumberToChina(3) = "三"
        NumberToChina(4) = "四"
        NumberToChina(5) = "五"
        NumberToChina(6) = "六"
        NumberToChina(7) = "七"
        NumberToChina(8) = "八"
        NumberToChina(9) = "九"
        '农历日期名
        DayName(0) = "*"
        DayName(1) = "初一"
        DayName(2) = "初二"
        DayName(3) = "初三"
        DayName(4) = "初四"
        DayName(5) = "初五"
        DayName(6) = "初六"
        DayName(7) = "初七"
        DayName(8) = "初八"
        DayName(9) = "初九"
        DayName(10) = "初十"
        DayName(11) = "十一"
        DayName(12) = "十二"
        DayName(13) = "十三"
        DayName(14) = "十四"
        DayName(15) = "十五"
        DayName(16) = "十六"
        DayName(17) = "十七"
        DayName(18) = "十八"
        DayName(19) = "十九"
        DayName(20) = "二十"
        DayName(21) = "廿一"
        DayName(22) = "廿二"
        DayName(23) = "廿三"
        DayName(24) = "廿四"
        DayName(25) = "廿五"
        DayName(26) = "廿六"
        DayName(27) = "廿七"
        DayName(28) = "廿八"
        DayName(29) = "廿九"
        DayName(30) = "三十"
        '农历月份名
        MonName(0) = "*"
        MonName(1) = "正"
        MonName(2) = "二"
        MonName(3) = "三"
        MonName(4) = "四"
        MonName(5) = "五"
        MonName(6) = "六"
        MonName(7) = "七"
        MonName(8) = "八"
        MonName(9) = "九"
        MonName(10) = "十"
        MonName(11) = "十一"
        MonName(12) = "腊"
        '天干名称
        TianGan(0) = "甲"
        TianGan(1) = "乙"
        TianGan(2) = "丙"
        TianGan(3) = "丁"
        TianGan(4) = "戊"
        TianGan(5) = "己"
        TianGan(6) = "庚"
        TianGan(7) = "辛"
        TianGan(8) = "壬"
        TianGan(9) = "癸"
        '地支名称
        DiZhi(0) = "子"
        DiZhi(1) = "丑"
        DiZhi(2) = "寅"
        DiZhi(3) = "卯"
        DiZhi(4) = "辰"
        DiZhi(5) = "巳"
        DiZhi(6) = "午"
        DiZhi(7) = "未"
        DiZhi(8) = "申"
        DiZhi(9) = "酉"
        DiZhi(10) = "戌"
        DiZhi(11) = "亥"
        '例如:020480102
        CurYear = CInt(Mid(OldDate, 2, 4))
        BackChina = TianGan(((CurYear - 4) Mod 60) Mod 10) & DiZhi(((CurYear - 4) Mod 60) Mod 12) & "年"
        If Mid(OldDate, 1, 1) = "1" Then BackChina = BackChina & "闰"
        BackChina = BackChina & MonName(CInt(Mid(OldDate, 6, 2))) & "月"
        BackChina = BackChina & DayName(CInt(Mid(OldDate, 8, 12)))
    End Function
    '传回农历 y年m月的总天数
    Function lMonthDays(ByVal y As Integer, ByVal M As Integer) As Integer
        On Error Resume Next
        If y < 1900 Then y = 1900
        If (CDbl(LunarInfo(y - 1900 + 1)) And Int(&H10000 / (2 ^ M))) = 0 Then
            lMonthDays = 29
        Else
            lMonthDays = 30
        End If
    End Function
    '传回农历 y年闰哪个月 1-12 , 没闰传回 0
    Function LeapMonth(ByVal y As Integer) As Integer
        On Error Resume Next
        LeapMonth = 0
        If y >= 1900 Then LeapMonth = (LunarInfo(y - 1900 + 1) And &HFS)
    End Function
    '传回农历 y年闰月的天数
    Function LeapDays(ByVal y As Integer) As Integer
        On Error Resume 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
    '传回农历 y年的总天数
    Function lYearDays(ByVal y As Integer) As Integer
        Dim II, Sum As Double
        On Error Resume Next
        Sum = 0
        For II = 1 To 12
            Sum = Sum + lMonthDays(y, II)
        Next
        lYearDays = Sum + LeapDays(y)
    End Function
    '传回阳历 y年某m月的天数
    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
    '根据年份返回属象
    Function Animal(ByVal sYear As Date) As String
        On Error Resume Next
        Dim ShuXiang(12) As String
        '属相名称
        ShuXiang(0) = "鼠"
        ShuXiang(1) = "牛"
        ShuXiang(2) = "虎"
        ShuXiang(3) = "兔"
        ShuXiang(4) = "龙"
        ShuXiang(5) = "蛇"
        ShuXiang(6) = "马"
        ShuXiang(7) = "羊"
        ShuXiang(8) = "猴"
        ShuXiang(9) = "鸡"
        ShuXiang(10) = "狗"
        ShuXiang(11) = "猪"
        Animal = ShuXiang(((Year(sYear) - 4) Mod 60) Mod 12)
    End Function
    '根据给定的阳历,返回农历的日期
    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 Resume 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
        lyear = 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
        Loop
        If 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
        '返回特殊标志的字符串
        If IsLeap Then
            GetLunar = "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
    '某y年的第n个节气的日期(从1小寒起算)
    Function sTerm(ByVal y As Object, ByRef n As Integer) 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
    '根据阳历返回其节气,若不是则返回空
    Function GetTerm(ByVal sDate As Date) As String
        Dim y, M As Integer
        On Error Resume 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
    '返回阳历是该月的第几个星期几的字符串,如:0520表示5月份第2个星期日
    Function GetMonthWeek(ByVal sDate As Date) As String
        Dim D0 As Date
        On Error Resume Next
        D0 = CDate(Year(sDate) & "-" & Month(sDate) & "-1")
        GetMonthWeek = VB6.Format(Month(sDate), "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 '阳历的节日
        Dim lFtv(11) As String '农历的节日
        Dim wFtv(11) As String '西方的节日
        On Error Resume Next
        '//时间超过2038年后就出现错误
        OldDate = CDate(VB6.Format(OldDate, "yyyy-mm-dd"))
        '阳历节日:前四位数字为阳历的MMDD(月日),后面的文字为意义
        sFtv(1) = "0101*元旦"
        sFtv(2) = "0214情人节"
        sFtv(3) = "0308妇女节"
        sFtv(4) = "0312植树节"
        sFtv(5) = "0315权益日"
        sFtv(6) = ""
        sFtv(7) = "0401愚人节"
        sFtv(8) = "0501*劳动节"
        sFtv(9) = "0504青年节"
        sFtv(10) = "0512护士节"
        sFtv(11) = "0601儿童节"
        sFtv(12) = "0701建党节"
        sFtv(13) = ""
        sFtv(14) = "0801建军节"
        sFtv(15) = "0808父亲节"
        sFtv(16) = "0909毛逝世纪念"
        sFtv(17) = "0910教师节"
        sFtv(18) = "0928孔子诞辰"
        sFtv(19) = "1001*国庆节"
        sFtv(20) = "1006老人节"
        sFtv(21) = "1024联合国日"
        sFtv(22) = "1112孙中山诞辰"
        sFtv(23) = "1220澳门回归"
        sFtv(24) = "1225圣诞节"
        sFtv(25) = "1226毛诞辰纪念"
        '农历的节日:日期表示的是农历的某月某日
        lFtv(1) = "0101*春节"
        lFtv(2) = "0115元宵节"
        lFtv(3) = "0505端午节"
        lFtv(4) = "0707七夕节"
        lFtv(5) = "0715中元节"
        lFtv(6) = "0815中秋节"
        lFtv(7) = "0909重阳节"
        lFtv(8) = ""
        lFtv(9) = "1208腊八节"
        lFtv(10) = "1224小年"
        lFtv(11) = "0100*除夕"
        '按星期计算的节日:如0231表示阳历02月份的第三个星期一
        wFtv(1) = ""
        wFtv(2) = "0231总统日"
        wFtv(3) = "0520母亲节"
        wFtv(4) = ""
        wFtv(5) = "0531胜利日"
        wFtv(6) = "0716合作节"
        wFtv(7) = "0730被奴周"
        wFtv(8) = ""
        wFtv(9) = ""
        wFtv(10) = "1021哥伦布日"
        wFtv(11) = "1144感恩节"
        '********************************
        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,0x055d9,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)) '在字符处理的时候就已经转换成为十六进制乐
        Next
        For II = 1 To 12
            Select Case II
                Case 1, 3, 5, 7, 8, 10, 12
                    SolarMonth(II) = 31
                Case 2
                    SolarMonth(II) = 28
                Case Else
                    SolarMonth(II) = 30
            End Select
        Next
        S1 = "小寒大寒立春雨水惊蛰春分清明谷雨立夏小满芒种夏至小暑大暑立秋处暑白露秋分寒露霜降立冬小雪大雪冬至"
        S2 = "000000,021208,042467,063836,085337,107014,128867,150921,173149,195551,218072,240693,263343,285989,308563,331033,353350,375494,397447,419210,440795,462224,483532,504758"
        '对节气赋值
        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
        '阳历节日
        StrDate = VB6.Format(OldDate, "mmdd")
        For II = 1 To UBound(sFtv)
            If sFtv(II) <> "" Then
                If Mid(sFtv(II), 1, 4) = StrDate Then '判断相等
                    StrTemp = Right(sFtv(II), Len(sFtv(II)) - 4)
                    Exit For
                End If
            End If
        Next
        '阴历节日
        StrDate = Right(GetLunar(CDate(OldDate)), 4)
        For II = 1 To UBound(lFtv)
            If lFtv(II) <> "" Then
                If Mid(lFtv(II), 1, 4) = StrDate Then '判断相等
                    If StrTemp <> "" Then StrTemp = StrTemp & ","
                    StrTemp = Right(lFtv(II), Len(lFtv(II)) - 4)
                End If
            End If
        Next
        '星期节日
        StrDate = GetMonthWeek(CDate(OldDate))
        For II = 1 To UBound(wFtv)
            If wFtv(II) <> "" Then
                If Mid(wFtv(II), 1, 4) = StrDate Then '判断相等
                    If StrTemp <> "" Then StrTemp = StrTemp & ","
                    StrTemp = Right(wFtv(II), Len(wFtv(II)) - 4)
                End If
            End If
        Next
        '取得信息
        GetChinaInfo.WestDate = VB6.Format(CDate(OldDate), "yyyy-mm-dd")
        GetChinaInfo.ChinaDate = BackChina(GetLunar(CDate(OldDate)))
        GetChinaInfo.Animal = Animal(OldDate)
        GetChinaInfo.Term = GetTerm(OldDate)
        GetChinaInfo.RestDay = StrTemp
        GetChinaInfo.WeekDate = WeekDayName(WeekDay(CDate(OldDate)))
        StrTemp = "今天是" & GetChinaInfo.WestDate & "(" & GetChinaInfo.WeekDate & "),农历" & GetChinaInfo.ChinaDate & "[" & GetChinaInfo.Animal & "]"
        If GetChinaInfo.RestDay <> "" Then StrTemp = StrTemp & "[" & GetChinaInfo.RestDay & "]"
        If GetChinaInfo.Term <> "" Then StrTemp = StrTemp & "[" & GetChinaInfo.Term & "]"
        GetChinaInfo.AllInfo = StrTemp
    End Function
End Class

 

VB中农历的实现

Option ExplicitPrivate Function NongLiCalender() As String    Dim WeekName(7) As Variant    Dim Mont...
  • Dengyu1997
  • Dengyu1997
  • 2006年03月06日 14:51
  • 2177

常用函数集农历函数

常用函数集农历函数原来是vb代码,重新整理为VB.NET版的,并在VS2003中编译通过Imports System.MathPublic Class UCnCalendar    Private S...
  • 21aspnet
  • 21aspnet
  • 2004年11月04日 11:05
  • 3919

C#通用类库--农历类(很全面)

代码源于网络,自己整理的,一个C#资源分享平台,专业分享学习高质量代码,每周期布置学习任务,激发学习C#兴趣!(QQ群:128874886)   用法:            ...
  • my98800
  • my98800
  • 2017年03月03日 08:31
  • 258

公农历转换VB类

  • zgqtxwd
  • zgqtxwd
  • 2008年04月24日 08:36
  • 144

中国农历算法java实现(转自Herong Yang)

/** * ChineseCalendarGB.java * Copyright (c) 1997-2002 by Dr. Herong Yang * 中国农历算法 - 实用于公历 1901 年至 2...
  • jeensung
  • jeensung
  • 2006年02月07日 19:35
  • 7815

阳历到农历转换的一个PHP类

  • zhaicunqi
  • zhaicunqi
  • 2016年03月21日 11:00
  • 1358

中国农历的Java实现

中国农历支持公历范围为:1900-01-31到2099-12-31范围内,农历日期和公历日期的转换。实现思路通过记录1900年-2099年间的农历信息到二维数组中,经过查询和相关计算就能实现公历日期和...
  • he_qiao_2010
  • he_qiao_2010
  • 2015年09月07日 22:14
  • 1474

真正的公农历转换类for VB

  • zgqtxwd
  • zgqtxwd
  • 2008年05月01日 05:02
  • 286

Java8 新语法习惯 (类型推断)

学习如何在 lambda 表达式中使用类型推断,掌握改进参数命名的技巧。概览Java8 是一个支持类型推断的 Java 版本,而且它仅对 lambda 表达式支持此功能。在 lambda 表达式中使用...
  • hnzcdy
  • hnzcdy
  • 2018年01月11日 15:06
  • 49

JAVA农历转公历,公历转农历算法

public class Lunar    {        private int year;        private int month;        private int da...
  • u010854543
  • u010854543
  • 2013年11月22日 08:43
  • 3810
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:农历类(VB)
举报原因:
原因补充:

(最多只允许输入30个字)