這個是有計算方法的，只要妳有計算公式我就可以計算出來的。但是前提妳要有計算公式才行。
'公歷轉農歷模塊
'// 農歷數據定義 //
'先以 H2B 函數還原成長度為 18 的字符串，其定義如下：
'前12個字節代表1-12月：1為大月，0為小月；壓縮成十六進制(1-3位)
'第13位為閏月的情況，1為大月30天，0為小月29天；(4位)
'第14位為閏月的月份，如果不是閏月為0，否則給出月份(5位)
'最後4位為當年農歷新年的公歷日期，如0131代表1月31日；當作數值轉十六進制(6-7位)
'農歷常量(1899~2100，***202年）
Private Const ylData = "AB500D2,4BD0883," _
& "4AE00DB,A5700D0,54D0581,D2600D8,D9500CC,655147D,56A00D5,9AD00CA,55D027A,4AE00D2," _
& "A5B0682,A4D00DA,D2500CE,D25157E,B5500D6,56A00CC,ADA027B,95B00D3,49717C9,49B00DC," _
& "A4B00D0,B4B0580,6A500D8,6D400CD,AB5147C,2B600D5,95700CA,52F027B,49700D2,6560682," _
& "D4A00D9,EA500CE,6A9157E,5AD00D6,2B600CC,86E137C,92E00D3,C8D1783,C9500DB,D4A00D0," _
& "D8A167F,B5500D7,56A00CD,A5B147D,25D00D5,92D00CA,D2B027A,A9500D2,B550781,6CA00D9," _
& "B5500CE,535157F,4DA00D6,A5B00CB,457037C,52B00D4,A9A0883,E9500DA,6AA00D0,AEA0680," _
& "AB500D7,4B600CD,AAE047D,A5700D5,52600CA,F260379,D9500D1,5B50782,56A00D9,96D00CE," _
& "4DD057F,4AD00D7,A4D00CB,D4D047B,D2500D3,D550883,B5400DA,B6A00CF,95A1680,95B00D8," _
& "49B00CD,A97047D,A4B00D5,B270ACA,6A500DC,6D400D1,AF40681,AB600D9,93700CE,4AF057F," _
& "49700D7,64B00CC,74A037B,EA500D2,6B50883,5AC00DB,AB600CF,96D0580,92E00D8,C9600CD," _
& "D95047C,D4A00D4,DA500C9,755027A,56A00D1,ABB0781,25D00DA,92D00CF,CAB057E,A9500D6," _
& "B4A00CB,BAA047B,B5500D2,55D0983,4BA00DB,A5B00D0,5171680,52B00D8,A9300CD,795047D," _
& "6AA00D4,AD500C9,5B5027A,4B600D2,96E0681,A4E00D9,D2600CE,EA6057E,D5300D5,5AA00CB," _
& "76A037B,96D00D3,4AB0B83,4AD00DB,A4D00D0,D0B1680,D2500D7,D5200CC,DD4057C,B5A00D4," _
& "56D00C9,55B027A,49B00D2,A570782,A4B00D9,AA500CE,B25157E,6D200D6,ADA00CA,4B6137B," _
& "93700D3,49F08C9,49700DB,64B00D0,68A1680,EA500D7,6AA00CC,A6C147C,AAE00D4,92E00CA," _
& "D2E0379,C9600D1,D550781,D4A00D9,DA400CD,5D5057E,56A00D6,A6C00CB,55D047B,52D00D3," _
& "A9B0883,A9500DB,B4A00CF,B6A067F,AD500D7,55A00CD,ABA047C,A5A00D4,52B00CA,B27037A," _
& "69300D1,7330781,6AA00D9,AD500CE,4B5157E,4B600D6,A5700CB,54E047C,D1600D2,E960882," _
& "D5200DA,DAA00CF,6AA167F,56D00D7,4AE00CD,A9D047D,A2D00D4,D1500C9,F250279,D5200D1"
Private Const ylMd0 = "初壹初二初三初四初五初六初七初八初九初十十壹十二十三十四十五" _
& "十六十七十八十九二十廿壹廿二廿三廿四廿五廿六廿七廿八廿九三十 "
Private Const ylMn0 = "正二三四五六七八九十冬臘"
Private Const ylTianGan0 = "甲乙丙丁戊已庚辛壬癸"
Private Const ylDiZhi0 = "子醜寅卯辰巳午未申酉戌亥"
Private Const ylShu0 = "鼠牛虎兔龍蛇馬羊猴雞狗豬"
'公歷日期轉農歷
Function GetYLDate(ByVal strDate As String) As String
On Error GoTo aErr
If Not IsDate(strDate) Then Exit Function
Dim setDate As Date, tYear As Integer, tMonth As Integer, tDay As Integer
setDate = CDate(strDate)
tYear = Year(setDate): tMonth = Month(setDate): tDay = Day(setDate)
'如果不是有效有日期，退出
If tYear > 2100 Or tYear < 1900 Then Exit Function
Dim daList() As String * 18, conDate As Date, thisMonths As String
Dim AddYear As Integer, AddMonth As Integer, AddDay As Integer, getDay As Integer
Dim YLyear As String, YLShuXing As String
Dim dd0 As String, mm0 As String, ganzhi(0 To 59) As String * 2
Dim RunYue As Boolean, RunYue1 As Integer, mDays As Integer, i As Integer
'加載2年內的農歷數據
ReDim daList(tYear - 1 To tYear)
daList(tYear - 1) = H2B(Mid(ylData, (tYear - 1900) * 8 + 1, 7))
daList(tYear) = H2B(Mid(ylData, (tYear - 1900 + 1) * 8 + 1, 7))
AddYear = tYear
initYL:
AddMonth = CInt(Mid(daList(AddYear), 15, 2))
AddDay = CInt(Mid(daList(AddYear), 17, 2))
conDate = DateSerial(AddYear, AddMonth, AddDay) '農歷新年日期
getDay = DateDiff("d", conDate, setDate) + 1 '相差天數
If getDay < 1 Then AddYear = AddYear - 1: GoTo initYL
thisMonths = Left(daList(AddYear), 14)
RunYue1 = Val("&H" & Right(thisMonths, 1))? '閏月月份
If RunYue1 > 0 Then? '有閏月
thisMonths = Left(thisMonths, RunYue1) & Mid(thisMonths, 13, 1) & Mid(thisMonths, RunYue1 + 1)
End If
thisMonths = Left(thisMonths, 13)
For i = 1 To 13? '計算天數
mDays = 29 + CInt(Mid(thisMonths, i, 1))
If getDay > mDays Then
getDay = getDay - mDays
Else
If RunYue1 > 0 Then
If i = RunYue1 + 1 Then RunYue = True
If i > RunYue1 Then i = i - 1
End If
AddMonth = i
AddDay = getDay
Exit For
End If
Next
dd0 = Mid(ylMd0, (AddDay - 1) * 2 + 1, 2)
mm0 = Mid(ylMn0, AddMonth, 1) + "月"
For i = 0 To 59
ganzhi(i) = Mid(ylTianGan0, (i Mod 10) + 1, 1) + Mid(ylDiZhi0, (i Mod 12) + 1, 1)
Next i
YLyear = ganzhi((AddYear - 4) Mod 60)
YLShuXing = Mid(ylShu0, ((AddYear - 4) Mod 12) + 1, 1)
If RunYue Then mm0 = "閏" & mm0
GetYLDate = "農歷 " & YLyear & "(" & YLShuXing & ")年" & mm0 & dd0
aErr:
End Function
'農歷轉公歷日期
'secondMonth 為真，則天示當 tMonth 是閏月時，取第二個月
Function GetDate(ByVal tYear As Integer, tMonth As Integer, tDay As Integer, Optional secondMonth As Boolean = False) As String
On Error GoTo aErr
If tYear > 2100 Or tYear < 1899 Or tMonth > 12 Or tMonth < 1 Or tDay > 30 Or tDay < 1 Then Exit Function
Dim thisMonths As String, ylNewYear As Date, toMonth As Integer
Dim mDays As Integer, RunYue1 As Integer, i As Integer
thisMonths = H2B(Mid(ylData, (tYear - 1899) * 8 + 1, 7))
If tDay > 29 + CInt(Mid(thisMonths, tMonth, 1)) Then Exit Function
ylNewYear = DateSerial(tYear, CInt(Mid(thisMonths, 15, 2)), CInt(Mid(thisMonths, 17, 2))) '農歷新年日期
thisMonths = Left(thisMonths, 14)
RunYue1 = Val("&H" & Right(thisMonths, 1))? '閏月月份
toMonth = tMonth - 1
If RunYue1 > 0 Then? '有閏月
thisMonths = Left(thisMonths, RunYue1) & Mid(thisMonths, 13, 1) & Mid(thisMonths, RunYue1 + 1)
If tMonth > RunYue1 Or (secondMonth And tMonth = RunYue1) Then toMonth = tMonth
End If
thisMonths = Left(thisMonths, 13)
mDays = 0
For i = 1 To toMonth
mDays = mDays + 29 + CInt(Mid(thisMonths, i, 1))
Next
mDays = mDays + tDay
GetDate = ylNewYear + mDays - 1
aErr:
End Function
'將壓縮的陰歷字符還原
Private Function H2B(ByVal strHex As String) As String
Dim i As Integer, i1 As Integer, tmpV As String
Const hStr = "0123456789ABCDEF"
Const bStr = "0000000100100011010001010110011110001001101010111100110111101111"
tmpV = UCase(Left(strHex, 3))
'十六進制轉二進制
For i = 1 To Len(tmpV)
i1 = InStr(hStr, Mid(tmpV, i, 1))
H2B = H2B & Mid(bStr, (i1 - 1) * 4 + 1, 4)
Next
H2B = H2B & Mid(strHex, 4, 2)
'十六進制轉十進制
H2B = H2B & "0" & CStr(Val("&H" & Right(strHex, 2)))
End Function
Private Sub Command1_Click()
Label1.Caption = GetYLDate(Text1.Text)
End Sub