文章探索:   分类:    关键字:  
  + 栏目导航
  + 相关文章
文本框中光标位置的获得
用VB导入导出你的IE收藏夹
VB应用程序访问SQL Server方法探讨
VB访问SQL Server数据库技术全揭密
自动上网抓数据的机器人
自己的IE——用VB制作浏览器
VB中如何保存Webbrowser中的整个页面..
在VB中该如何控制其它程序的弹出窗口..
保存webbrowser中的HTML内容
破译动网验证码的简单方法
轻松获取QQ密码
VB.NET获取硬盘序列号的方法
WEBBROWSER 技巧一(收藏)
VB自动登陆网络站点详解(二):Inet..
获取webbrowser控件网页的源码
WebBrowser控件说明
关于用VB做更漂亮的窗体的思考
VB中访问存储过程的几种办法
VB6中改变屏幕的分辨率和刷新频率
VB编写一个能显示百分比的自定义进度..
公农历转换VB类
VB.NET窗口渐淡关闭
使用VB实现邮箱自动注册(二):修改..
VB.NET轻松实现任务栏程序
VB.NET启动外部程序
利用vb实现图片上传
VB实现局域网内的文件传输
VB 一个Function传回多个值
在VB中实现多线程
VB 手机号码编码程序


技术教程 -> VB教程 ->  
公农历转换VB类
来源:转载   人气:1810   录入时间:2007-11-8
    网上流传很多计算公农历的源代码,很多,但是居然没有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
   
   Next
   Next
   Next
   End With
   ''t.printf
   et = Timer
   Debug.Print et - st
   Set t = Nothing
   End Sub
   
   以下为代码:
   
   
   Option Explicit
   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)
   Next
   
   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)
   Next
   
   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)
   Next
   
   ''农历节日 *表示放假日
   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)
   Next
   
   ''某月的第几个星期几
   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)
   Next
   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
   Next
   
   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
   End If
   End If
   Next
   
   
   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
   Next
   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
   Next
   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
   End If
   End If
   End If
   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
   Next
   
   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 #12/31/2000#
   ConstellName = "摩蝎"
   Case #1/1/2000# To #1/19/2000#
   ConstellName = "摩蝎"
   Case #1/20/2000# To #2/18/2000#
   ConstellName = "水瓶"
   Case #2/19/2000# To #3/20/2000#
   ConstellName = "双鱼"
   Case Else
   ConstellName = ""
   End Select
   Constellation = ConstellName
   End Function
   ''/////////////////////////////////////////////////////////////////////////////////////////////////////////
   ''以下为类内部使用的一些函数
   ''传回农历 y年的总天数
   Private Function lYearDays(ByVal y As Long) As Long
   
   '' Dim i As Long
   '' Dim f As Long
   '' Dim sumDay As Long
   '' Dim info As Long
   
   '' sumDay = 348
   '' i = &H8000
   '' info = LunarInfo(y - 1900) And &H1000FFFF ''屏蔽高位,
   '' Do
   '' f = info And i
   '' If f <> 0 Then
   '' sumDay = sumDay + 1
   '' End If
   '' i = BitRight16(i, 1)
   '' Loop Until i < &H10
   '' lYearDays = sumDay + leapDays(y)
   
   lYearDays = LunarYearDays(y - 1900) ''先计算出每年的天数,并形成数组,以减少以后的运算时间
   End Function
   ''传回农历 y年m月的总天数
   Private Function lMonthDays(ByVal y As Long, ByVal m As Long) As Long
   If (LunarInfo(y - 1900) And &H1000FFFF) And BitRight32(&H10000, m) Then
   lMonthDays = 30
   Else
   lMonthDays = 29
   End If
   End Function
   ''传回农历 y年闰月的天数
   Private Function leapDays(y As Long) As Long
   If leapMonth(y) Then
   If LunarInfo(y - 1900) And &H10000 Then
   leapDays = 30
   Else
   leapDays = 29
   End If
   Else
   leapDays = 0
   End If
   End Function
   ''传回农历 y年闰哪个月 1-12 , 没闰传回 0
   Private Function leapMonth(y As Long) As Long
   Dim i As Long
   i = LunarInfo(y - 1900) And &HF
   If i > 12 Then
   Debug.Print y
   End If
   leapMonth = i
   End Function
   ''计算公历年月的天数
   Private Function SolarDays(y As Long, m As Long) As Long
   Dim d As Long
   
   If (y Mod 4) = 0 Then ''闰年
   If m = 2 Then
   d = 29
   Else
   d = SolarMonth(m - 1)
   End If
   Else
   If m = 2 Then
   d = 28
   Else
   d = SolarMonth(m - 1)
   End If
   End If
   
   SolarDays = d
   End Function
   
   ''//////////////////////////////////////////////////////////////////////////////////////////////////
   ''
   ''主要的函数,用公历年月日对日期对象进行初使化,在此函数内部完成对私有对象属性的设置
   ''
   ''//////////////////////////////////////////////////////////////////////////////////////////////////
   Public Sub sInitDate(ByVal y As Long, ByVal m As Long, ByVal d As Long)
   Dim i As Long
   Dim leap As Long
   Dim Temp As Long
   Dim offset As Long
   
   mvarDate = m & "/" & d & "/" & y
   mvarsYear = y
   mvarsMonth = m
   mvarsDay = d
   
   ''农历日期计算部分
   leap = 0
   Temp = 0
   
   offset = mvarDate - #1/30/1900# ''计算两天的基本差距
   
   For i = 1900 To 2049
   ''temp = lYearDays(i) ''求当年农历年天数
   
   offset = offset - Temp
   If offset < 1 Then Exit For
   Next
   
   offset = offset + Temp
   mvarlYear = i
   
   leap = leapMonth(i) ''闰哪个月
   mvarIsLeap = False
   For i = 1 To 12
   ''闰月
   If leap > 0 And i = (leap + 1) And mvarIsLeap = False Then
   mvarIsLeap = True
   i = i - 1
   Temp = leapDays(mvarlYear) ''计算闰月天数
   Else
   Temp = lMonthDays(mvarlYear, i) ''计算非闰月天数
   End If
   
   offset = offset - Temp
   If offset <= 0 Then Exit For
   Next
   
   offset = offset + Temp
   mvarlMonth = i
   mvarlDay = offset
   
   End Sub
   ''//////////////////////////////////////////////////////////////////////////////////////////////////
   ''
   ''主要的函数,用农历年月日对日期对象进行初使化,在此函数内部完成对私有对象属性的设置
   ''
   ''//////////////////////////////////////////////////////////////////////////////////////////////////
   Public Sub lInitDate(ByVal y As Long, ByVal m As Long, ByVal d As Long, Optional LeapFlag As Boolean = False)
   Dim i As Long
   Dim leap As Long
   Dim Temp As Long
   Dim offset As Long
   mvarlYear = y
   mvarlMonth = m
   mvarlDay = d
   
   offset = 0
   
   For i = 1900 To y - 1
   Temp = LunarYearDays(i - 1900) ''求当年农历年天数
   offset = offset + Temp
   Next
   
   leap = leapMonth(y) ''闰哪个月
   If m <> leap Then
   mvarIsLeap = False ''当前日期并非闰月
   Else
   mvarIsLeap = LeapFlag ''使用用户输入的是否闰月月份
   End If
   
   If (m < leap) Or (leap = 0) Then ''当闰月在当前日期后
   For i = 1 To m - 1
   Temp = lMonthDays(y, i) ''计算非闰月天数
   offset = offset + Temp
   Next
   Else ''在闰月后
   If mvarIsLeap = False Then ''用户要计算非闰月的月份
   For i = 1 To m - 1
   Temp = lMonthDays(y, i) ''计算非闰月天数
   offset = offset + Temp
   Next
   If m > leap Then
   Temp = leapDays(y) ''计算闰月天数
   offset = offset + Temp
   End If
   
   Else ''此时只有mvarisleap=ture,
   For i = 1 To m
   Temp = lMonthDays(y, i) ''计算非闰月天数
   offset = offset + Temp
   Next
   End If
   End If
   
   offset = offset + d ''加上当月的天数
   mvarDate = DateAdd("d", offset, #1/30/1900#)
   mvarsYear = Year(mvarDate)
   mvarsMonth = Month(mvarDate)
   mvarsDay = Day(mvarDate)
   End Sub
   ''本模块用于打印出1900-2049年 每年农历的天数,可以用于数组初使化
   ''Public Sub printf()
   '' Dim i As Long, j As Long
   '' Dim temp(10) As Long
   '' Dim base As Long
   
   '' base = 1900
   '' For i = 1 To 15
   '' For j = 1 To 10
   '' temp(j - 1) = lYearDays((i - 1) * 10 + (j - 1) + base) ''求当年农历年天数
   '' Next
   '' Debug.Print CStr(temp(0)) & " , " & CStr(temp(1)) & " , " & CStr(temp(2)) & " , " & CStr(temp(3)) & " , " & CStr(temp(4)) & " , " & CStr(temp(5)) & " , " & CStr(temp(6)) & " , " & CStr(temp(7)) & " , " & CStr(temp(8)) & " , " & CStr(temp(9)) & " , " & " _ "
   '' Next
   ''End Sub
   
   




Copyright(C)2007-2024 广州市佳沛数码科技有限公司 版权所有
公司地址: 广州市荔湾区东漖北路560号511室
电话:020-81803473 传真:020-81544987