真正的公农历转换类for VB - 技术文档 - VB文档 - 其他文档

网页功能：加入收藏设为首页网站搜索

2024年04月25日

首页

您的位置：立华软件园 → 技术文档 → VB文档 → 其他文档

搜索：

真正的公农历转换类for VB
	发表日期：2003-12-01	作者：BlueDog[] 出处：

公农历转换VB类 clsDate

网上流传很多计算公农历的源代码，很多，但是居然没有VB的，晕，

所以。。。。。

用法：

以l开始的方法均为阴历，以s开始的方法均为公历

基本的两个初使函数：

lInitDate：用农历年月日初使化日期对象

sInitDate: 用公历年月日初使化日期对象

其它的方法看下面的一小段代码吧

示例代码

Private Sub Command1_Click()

Dim t As clsDate

Dim y As Long

Dim m As Long

Dim d As Long

Dim st As Single

Dim et As Single

Dim da As Date

Dim j As Long

Dim ret As Long

Set t = New clsDate

't.sInitDate 1900, 1, 1

t.lInitDate 2047, 5, 12, False '农历2047年5月12日，非闰月

Debug.Print t.lYear

If t.IsLeap = False Then

Debug.Print t.lMonth

Else

Debug.Print " 闰 " & t.lMonth

End If

Debug.Print t.CDayStr(t.lDay) '农历日期中文大写

Debug.Print t.GanZhi(t.lYear) '求干支

Debug.Print t.YearAttribute(t.lYear) '农历年的属相

Debug.Print t.sYear ' 公历年

Debug.Print t.sMonth ' 公历月

Debug.Print t.sDay ' 公历日

Debug.Print t.sWeekDay '公历星期

Debug.Print t.Era(t.sYear)' 公历纪元

Debug.Print t.Constellation(t.sMonth, t.sDay) ' 星座

Debug.Print "Week:" & t.wHoliday ' 按第几个星期几计算的假日

Debug.Print "Solar" & t.sHoliday ' 按公历计算的假日

Debug.Print "Lunar" & t.lHoliday ' 按阴历计算的假日

Debug.Print t.lSolarTerm ' 计算节气

'以下为速度测试，很快吧。

st = Timer

With t

For y = 1900 To 2049

For m = 1 To 12

For d = 1 To 28

.lInitDate y, m, d, False

End With

't.printf

et = Timer

Debug.Print et - st

Set t = Nothing

End Sub

‘///////////////////////////////////////////////////////////////////////////////

' 以下为源代码部分，如果你需要在你的程序中使用，请在你写一封E-mail给我，至少让我知道有人

' 还在用它。

' E-mail: lxs@xtcz.net

' zhenghesoft@hotmail.com

' QQ: 248241571

' BlueDog 即日

’

Option Explicit

' ///////////////////////////////////////////////////////////////////////////////

' // //

' // 说明:本模块仅能用于1900.1.31日起至 2049.12.31日止的数据转换,否则会出错。 //

' // 或者农力1900.1.1日起至2049.12.7日止 //

' // //

' // 2003.10.21 //

' // //

' ///////////////////////////////////////////////////////////////////////////////

Private Type SolarHolidayStruct

Month As Long

Day As Long

Recess As Long

HolidayName As String

End Type

Private Type LunarHolidayStruct

Month As Long

Day As Long

Recess As Long

HolidayName As String

End Type

Private Type WeekHolidayStruct

Month As Long

WeekAtMonth As Long

WeekDay As Long

HolidayName As String

End Type

'保持属性值的局部变量

Private mvarsYear As Long '局部复制

Private mvarsMonth As Long '局部复制

Private mvarsDay As Long '局部复制

Private mvarlYear As Long '局部复制

Private mvarlMonth As Long '局部复制

Private mvarlDay As Long '局部复制

Private mvarIsLeap As Boolean '局部复制

Private Declare Function BitRight32 Lib "Bit4VB.DLL" (ByVal x As Long, ByVal num As Long) As Long

'Private Declare Function BitRight16 Lib "Bit4VB.DLL" (ByVal x As Integer, ByVal num As Integer) As Integer

'定义类内部用公用变量

Private SolarMonth As Variant

Private Gan As Variant

Private Zhi As Variant

Private Animals As Variant

Private SolarTerm As Variant

Private sTermInfo As Variant

Private nStr1 As Variant

Private nStr2 As Variant

Private MonthName As Variant

Private LunarInfo(150) As Long

Private LunarYearDays(150) As Long

Private sHolidayInfo() As SolarHolidayStruct

Private lHolidayInfo() As LunarHolidayStruct

Private wHolidayInfo() As WeekHolidayStruct

Private mvarDate As Date '内部使用标准的日期变量

Private Sub Class_Initialize()

Dim tempArray As Variant

Dim i As Long

Dim b As Long

Dim sFtv As Variant

Dim lFtv As Variant

Dim wFtv As Variant

'根据VB的位计算特点,故扩充原有的数据位,将其变成32位

tempArray = Array( _

&H104BD8, &H104AE0, &H10A570, &H1054D5, &H10D260, &H10D950, &H116554, &H1056A0, &H109AD0, &H1055D2, _

&H104AE0, &H10A5B6, &H10A4D0, &H10D250, &H11D255, &H10B540, &H10D6A0, &H10ADA2, &H1095B0, &H114977, _

&H104970, &H10A4B0, &H10B4B5, &H106A50, &H106D40, &H11AB54, &H102B60, &H109570, &H1052F2, &H104970, _

&H106566, &H10D4A0, &H10EA50, &H106E95, &H105AD0, &H102B60, &H1186E3, &H1092E0, &H11C8D7, &H10C950, _

&H10D4A0, &H11D8A6, &H10B550, &H1056A0, &H11A5B4, &H1025D0, &H1092D0, &H10D2B2, &H10A950, &H10B557, _

&H106CA0, &H10B550, &H115355, &H104DA0, &H10A5D0, &H114573, &H1052D0, &H10A9A8, &H10E950, &H106AA0, _

&H10AEA6, &H10AB50, &H104B60, &H10AAE4, &H10A570, &H105260, &H10F263, &H10D950, &H105B57, &H1056A0, _

&H1096D0, &H104DD5, &H104AD0, &H10A4D0, &H10D4D4, &H10D250, &H10D558, &H10B540, &H10B5A0, &H1195A6, _

&H1095B0, &H1049B0, &H10A974, &H10A4B0, &H10B27A, &H106A50, &H106D40, &H10AF46, &H10AB60, &H109570, _

&H104AF5, &H104970, &H1064B0, &H1074A3, &H10EA50, &H106B58, &H1055C0, &H10AB60, &H1096D5, &H1092E0, _

&H10C960, &H10D954, &H10D4A0, &H10DA50, &H107552, &H1056A0, &H10ABB7, &H1025D0, &H1092D0, &H10CAB5, _

&H10A950, &H10B4A0, &H10BAA4, &H10AD50, &H1055D9, &H104BA0, &H10A5B0, &H115176, &H1052B0, &H10A930, _

&H107954, &H106AA0, &H10AD50, &H105B52, &H104B60, &H10A6E6, &H10A4E0, &H10D260, &H10EA65, &H10D530, _

&H105AA0, &H1076A3, &H1096D0, &H104BD7, &H104AD0, &H10A4D0, &H11D0B6, &H10D250, &H10D520, &H10DD45, _

&H10B5A0, &H1056D0, &H1055B2, &H1049B0, &H10A577, &H10A4B0, &H10AA50, &H11B255, &H106D20, &H10ADA0)

For i = 0 To 149

LunarInfo(i) = tempArray(i)

tempArray = Array( _

384, 354, 355, 383, 354, 355, 384, 354, 355, 384, _

354, 384, 354, 354, 384, 354, 355, 384, 355, 384, _

354, 354, 384, 354, 354, 385, 354, 355, 384, 354, _

383, 354, 355, 384, 355, 354, 384, 354, 384, 354, _

354, 384, 355, 354, 385, 354, 354, 384, 354, 384, _

354, 355, 384, 354, 355, 384, 354, 383, 355, 354, _

384, 355, 354, 384, 355, 353, 384, 355, 384, 354, _

355, 384, 354, 354, 384, 354, 384, 354, 355, 384, _

355, 354, 384, 354, 384, 354, 354, 384, 355, 355, _

384, 354, 354, 383, 355, 384, 354, 355, 384, 354, _

354, 384, 354, 355, 384, 354, 385, 354, 354, 384, _

354, 354, 384, 355, 384, 354, 355, 384, 354, 354, _

384, 354, 355, 384, 354, 384, 354, 354, 384, 355, _

354, 384, 355, 384, 354, 354, 384, 354, 354, 384, _

355, 355, 384, 354, 384, 354, 354, 384, 354, 355)

For i = 0 To 149

LunarYearDays(i) = tempArray(i)

SolarMonth = Array(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)

Gan = Array("甲", "乙", "丙", "丁", "戊", "己", "庚", "辛", "壬", "癸")

Zhi = Array("子", "丑", "寅", "卯", "辰", "巳", "午", "未", "申", "酉", "戌", "亥")

Animals = Array("鼠", "牛", "虎", "兔", "龙", "蛇", "马", "羊", "猴", "鸡", "狗", "猪")

SolarTerm = Array("小寒", "大寒", "立春", "雨水", "惊蛰", "春分", "清明", "谷雨", "立夏", "小满", "芒种", "夏至", "小暑", "大暑", "立秋", "处暑", "白露", "秋分", "寒露", "霜降", "立冬", "小雪", "大雪", "冬至")

sTermInfo = Array(0, 21208, 42467, 63836, 85337, 107014, 128867, 150921, 173149, 195551, 218072, 240693, 263343, 285989, 308563, 331033, 353350, 375494, 397447, 419210, 440795, 462224, 483532, 504758)

nStr1 = Array("日", "一", "二", "三", "四", "五", "六", "七", "八", "九", "十")

nStr2 = Array("初", "十", "廿", "卅", "　")

MonthName = Array("JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC")

'国历节日 *表示放假日

sFtv = Array( _

1, 1, 1, "元旦", _

2, 14, 0, "情人节", 2, 10, 0, "国际气象节", _

3, 18, 0, "妇女节", 3, 12, 0, "植树节", 3, 15, 0, "消费者权益日", _

4, 1, 0, "愚人节", _

5, 1, 1, "劳动节", 5, 4, 0, "青年节", 5, 12, 0, "护士节", 5, 31, 0, "世界无烟日", _

6, 1, 0, "儿童节", _

7, 1, 0, "建党节香港回归纪念", _

8, 1, 0, "建军节", 8, 8, 0, "中国男子节父亲节", _

9, 9, 0, "毛泽东逝世纪念", 9, 10, 0, "教师节", 9, 18, 0, "九·一八事变纪念日", 9, 28, 0, "孔子诞辰", _

10, 1, 0, "国庆节国际音乐日", 10, 6, 0, "老人节", 10, 24, 0, "联合国日", _

11, 12, 0, "孙中山诞辰纪念", _

12, 1, 0, "世界艾滋病日", 12, 3, 0, "世界残疾人日", 12, 20, 0, "澳门回归纪念", 12, 24, 0, "平安夜", 12, 25, 0, "圣诞节", 12, 26, 0, "毛泽东诞辰纪念")

b = UBound(sFtv) + 1

ReDim sHolidayInfo(b / 4)

For i = 0 To (b / 4) - 1

sHolidayInfo(i).Month = sFtv(i * 4)

sHolidayInfo(i).Day = sFtv(i * 4 + 1)

sHolidayInfo(i).Recess = sFtv(i * 4 + 2)

sHolidayInfo(i).HolidayName = sFtv(i * 4 + 3)

'农历节日 *表示放假日

lFtv = Array( _

1, 1, 1, "春节", _

1, 15, 0, "元宵节", _

5, 5, 0, "端午节", _

7, 7, 0, "七夕情人节", _

7, 15, 0, "中元节盂兰盆节", _

8, 15, 0, "中秋节", _

9, 9, 0, "重阳节", _

12, 8, 0, "腊八节", _

12, 24, 0, "小年")

'12, 31, 0, "除夕") '注意除夕需要其它方法进行计算

b = UBound(lFtv) + 1

ReDim lHolidayInfo(b / 4)

For i = 0 To (b / 4) - 1

lHolidayInfo(i).Month = lFtv(i * 4)

lHolidayInfo(i).Day = lFtv(i * 4 + 1)

lHolidayInfo(i).Recess = lFtv(i * 4 + 2)

lHolidayInfo(i).HolidayName = lFtv(i * 4 + 3)

'某月的第几个星期几

wFtv = Array( _

5, 2, 1, "国际母亲节", _

5, 3, 1, "全国助残日", _

6, 3, 1, "父亲节", _

9, 3, 3, "国际和平日", _

9, 4, 1, "国际聋人节", _

10, 1, 2, "国际住房日", _

10, 1, 4, "国际减轻自然灾害日", _

11, 4, 5, "感恩节")

b = UBound(wFtv) + 1

ReDim wHolidayInfo(b / 4)

For i = 0 To (b / 4) - 1

wHolidayInfo(i).Month = wFtv(i * 4)

wHolidayInfo(i).WeekAtMonth = wFtv(i * 4 + 1)

wHolidayInfo(i).WeekDay = wFtv(i * 4 + 2) '1 代表星期天

wHolidayInfo(i).HolidayName = wFtv(i * 4 + 3)

End Sub

'/////////////////////////////////////////////////////////////////////////////////////////////////////////////

'计算农历上的节气

Public Property Get lSolarTerm() As String

'//===== 某年的第n个节气为几日(从0小寒起算)

'function sTerm(y,n) {

' var offDate = new Date( ( 31556925974.7*(y-1900) + sTermInfo[n]*60000 ) + Date.UTC(1900,0,6,2,5) )

' return(offDate.getUTCDate())

'//节气

' tmp1 = sTerm(y, m * 2) - 1

Dim baseDateAndTime As Date

Dim newDate As Date

Dim num As Double

Dim y As Long

Dim tempStr As String

baseDateAndTime = #1/6/1900 2:05:00 AM#

y = mvarsYear

tempStr = ""

Dim i As Long

For i = 1 To 24

num = 525948.76 * (y - 1900) + sTermInfo(i - 1)

newDate = DateAdd("n", num, baseDateAndTime) '按分钟计算,之所以不按秒钟计算，是因为会溢出

If Abs(DateDiff("d", newDate, mvarDate)) = 0 Then

tempStr = SolarTerm(i - 1)

Exit For

End If

lSolarTerm = tempStr

End Property

'计算按第几周星期几计算的节日

Public Property Get wHoliday() As String

Dim w As Long

Dim i As Long

Dim b As Long

Dim FirstDay As Date

Dim tempStr As String

b = UBound(wHolidayInfo)

For i = 0 To b

If wHolidayInfo(i).Month = mvarsMonth Then '当月份相当时

w = WeekDay(mvarDate)

If wHolidayInfo(i).WeekDay = w Then '仅当星期几也相等时

FirstDay = mvarsMonth & "/" & 1 & "/" & mvarsYear '取当月第一天

If (DateDiff("ww", FirstDay, mvarDate) = wHolidayInfo(i).WeekAtMonth) Then

tempStr = wHolidayInfo(i).HolidayName

End If

wHoliday = tempStr

End Property

Public Property Get lHoliday() As String

Dim i As Long

Dim b As Long

Dim tempStr As String

Dim oy As Long

Dim odate As Date

Dim ndate As Date

tempStr = ""

b = UBound(lHolidayInfo)

If mvarlMonth = 12 And (mvarlDay = 29 Or mvarlDay = 30) Then

'保

oy = mvarlYear '保存农历年数

odate = mvarDate

ndate = mvarDate + 1

Call sInitDate(Year(ndate), Month(ndate), Day(ndate)) '计算第二天的属性

If oy = mvarlYear - 1 Then '如果农历年数增加了1

tempStr = "除夕"

Call sInitDate(Year(odate), Month(odate), Day(odate)) '恢复到今天原有数据

End If

Else

For i = 0 To b

If (lHolidayInfo(i).Month = mvarlMonth) And _

(lHolidayInfo(i).Day = mvarlDay) Then

tempStr = lHolidayInfo(i).HolidayName

Exit For

End If

lHoliday = tempStr

End Property

'求公历节日

Public Property Get sHoliday() As String

Dim i As Long

Dim b As Long

Dim tempStr As String

tempStr = ""

b = UBound(sHolidayInfo)

For i = 0 To b

If (sHolidayInfo(i).Month = mvarsMonth) And _

(sHolidayInfo(i).Day = mvarsDay) Then

tempStr = sHolidayInfo(i).HolidayName

Exit For

End If

sHoliday = tempStr

End Property

'是否是农历的闰月

Public Property Get IsLeap() As Boolean

IsLeap = mvarIsLeap

End Property

Public Property Get lDay() As Long

lDay = mvarlDay

End Property

Public Property Get lMonth() As Long

lMonth = mvarlMonth

End Property

Public Property Get lYear() As Long

lYear = mvarlYear

End Property

Public Property Get sWeekDay() As Long

sWeekDay = WeekDay(mvarDate)

End Property

Public Property Get sDay() As Long

sDay = mvarsDay

End Property

Public Property Get sMonth() As Long

sMonth = mvarsMonth

End Property

Public Property Get sYear() As Long

sYear = mvarsYear

End Property

'////////////////////////////////////////////////////////////////////////////////////////////////////////

Public Function IsToday(y As Long, m As Long, d As Long) As Boolean

If (Year(Date) = y) And _

(Month(Date) = m) And _

(Day(Date) = d) Then

IsToday = True

Else

IsToday = False

End If

End Function

'根据年份不同计算当年属于什么朝代

Public Function Era(y As Long) As String

Dim tempStr As String

If y < 1874 Then

tempStr = "未知"

Else

If y <= 1908 Then

tempStr = "清朝光绪"

If y = 1874 Then

tempStr = tempStr & "元年"

Else

tempStr = tempStr & UpNumber(CStr(y - 1874)) & "年"

End If

Else

If y <= 1910 Then

tempStr = "清朝宣统"

If y = 1909 Then

tempStr = tempStr & "元年"

Else

tempStr = tempStr & UpNumber(CStr(y - 1909 + 1)) & "年"

End If

Else

If y < 1949 Then

tempStr = "中华民国"

If y = 1912 Then

tempStr = tempStr & "元年"

Else

tempStr = tempStr & UpNumber(CStr(y - 1912 + 1)) & "年"

End If

Else

tempStr = "中华人民共和国成立"

If y = 1949 Then

tempStr = tempStr & "了"

Else

Select Case y

Case 2000

tempStr = "千禧年"

Case Else

tempStr = tempStr & UpNumber(CStr(y - 1949)) & "周年"

End Select

End If

Era = tempStr

End Function

' 传入 num 传回干支, 0=甲子

Public Function GanZhi(num As Long) As String

Dim tempStr As String

Dim i As Long

i = (num - 1864) Mod 60 '计算干支

tempStr = Gan(i Mod 10) & Zhi(i Mod 12)

GanZhi = tempStr

End Function

'计算年的属相字串

Public Function YearAttribute(y As Long) As String

YearAttribute = Animals((y - 1900) Mod 12)

End Function

'将数字汉化

Public Function UpNumber(Dxs As String) As String

'检测为空时

If Trim(Dxs) = "" Then

UpNumber = ""

Exit Function

End If

Dim Sw As Integer, SzUp As Integer, tempStr As String, DXStr As String

Sw = Len(Trim(Dxs))

Dim i As Integer

For i = 1 To Sw

tempStr = Right(Trim(Dxs), i)

tempStr = Left(tempStr, 1)

tempStr = Converts(tempStr)

Select Case i

Case 1

If tempStr = "零" Then

tempStr = ""

Else

tempStr = tempStr + ""

End If

Case 2

If tempStr = "零" Then

tempStr = "零"

Else

tempStr = tempStr + "十"

End If

Case 3

If tempStr = "零" Then

tempStr = "零"

Else

tempStr = tempStr + "百"

End If

Case 4

If tempStr = "零" Then

tempStr = "零"

Else

tempStr = tempStr + "千"

End If

Case 5

If tempStr = "零" Then

tempStr = "万"

Else

tempStr = tempStr + "万"

End If

Case 6

If tempStr = "零" Then

tempStr = "零"

Else

tempStr = tempStr + "十"

End If

Case 7

If tempStr = "零" Then

tempStr = "零"

Else

tempStr = tempStr + "百"

End If

Case 8

If tempStr = "零" Then

tempStr = "零"

Else

tempStr = tempStr + "千"

End If

Case 9

If tempStr = "零" Then

tempStr = "亿"

Else

tempStr = tempStr + "亿"

End If

End Select

Dim TempA As String

TempA = Left(Trim(DXStr), 1)

If tempStr = "零" Then

Select Case TempA

Case "零"

DXStr = DXStr

Case "万"

DXStr = DXStr

Case "亿"

DXStr = DXStr

Case Else

DXStr = tempStr + DXStr

End Select

Else

DXStr = tempStr + DXStr

End If

UpNumber = DXStr

End Function

Private Function Converts(NumStr As String) As String

Select Case val(NumStr)

Case 0

Converts = "零"

Case 1

Converts = "一"

Case 2

Converts = "二"

Case 3

Converts = "三"

Case 4

Converts = "四"

Case 5

Converts = "五"

Case 6

Converts = "六"

Case 7

Converts = "七"

Case 8

Converts = "八"

Case 9

Converts = "九"

End Select

End Function

'中文日期

Public Function CDayStr(d As Long) As String

Dim s As String

Select Case d

Case 0

s = ""

Case 10

s = "初十"

Case 20

s = "二十"

Case 30

s = "三十"

Case Else

s = nStr2(d \ 10) '整数除法

s = s & nStr1(d Mod 10)

End Select

CDayStr = s

End Function

'计算星座归属

Public Function Constellation(m As Long, d As Long) As String

Dim y As Long

Dim tempDate As Date

Dim ConstellName As String

y = 2000

tempDate = m & "/" & d & "/" & y

Select Case tempDate

Case #3/21/2003# To #4/19/2000#

ConstellName = "白羊"

Case #4/20/2000# To #5/20/2000#

ConstellName = "金牛"

Case #5/21/2000# To #6/21/2000#

ConstellName = "双子"

Case #6/22/2000# To #7/22/2000#

ConstellName = "巨蟹"

Case #7/23/2000# To #8/22/2000#

ConstellName = "狮子"

Case #8/23/2000# To #9/22/2000#

ConstellName = "处女"

Case #9/23/2000# To #10/23/2000#

ConstellName = "天秤"

Case #10/24/2000# To #11/21/2000#

ConstellName = "天蝎"

Case #11/22/2000# To #12/21/2000#

ConstellName = "射手"

Case #12/22/2000# To #

【我来说两句】【加入收藏】【返加顶部】【打印本页】【关闭窗口】

在

中搜索真正的公农历转换类for VB

本类热点文章

如何学好VB
如何学好VB
一个自杀程序
一个自杀程序
Visual Basic6.0实现自动化测试
VB问题集锦及编程技巧
VB问题集锦及编程技巧
如何在VB中实现ActiveX控件的IobjectSa..
VB计算农历的算法
VB计算农历的算法
RSA加密算法在VB中的实现
在VB中调用CHM帮助的几种方法