There is a calculation method for this. As long as you have the calculation formula, I can calculate it. But the prerequisite is that you need to have the calculation formula.
'Gregorian calendar to lunar calendar module
'//Lunar calendar data definition//
'First use the H2B function to restore it to a string with a length of 18, and its definition As follows:
'The first 12 bytes represent January to December: 1 is the big month, 0 is the small month; compressed into hexadecimal (1-3 digits)
'When the 13th digit is a leap month, 1 is a big month with 30 days, and 0 is a small month with 29 days; (4 digits)
'The 14th digit is the month of a leap month, if it is not a leap month, it is 0, otherwise Give the month (5 digits)
'The last 4 digits are the Gregorian calendar date of the Lunar New Year that year, for example, 0131 represents January 31st; treat it as a numerical value and convert it to hexadecimal (6-7 digits)
'Lunar constant (1899~2100, ***202 years)
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," _< /p>
& "A4B00D0,B4B0580,6A500D8,6D400CD,AB5147C,2B600D5,95700CA,52F027B,49700D2,6560682," _
& "D4A00D9,EA500CE,6A9157E,5AD00D 6,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,F 260379,D9500D1,5B50782,56A00D9, 96D00CE," _
& "4DD057F,4AD00D7,A4D00CB,D4D047B,D2500D3,D550883,B5400DA,B6A00CF,95A1680,95B00D8," _
& "49B00CD,A97047D,A4B 00D5, B270ACA,6A500DC,6D400D1,AF40681,AB600D9,93700CE,4AF057F," _
& "49700D7,64B00CC,74A037B,EA500D2,6B50883,5AC00DB,AB600CF,96D0580,92E00 D8,C9600CD," _
& "D95047C,D4A00D4,DA500C9,755027A,56A00D1,ABB0781,25D00DA,92D00CF,CAB057E,A9500D6," _
& "B4A00CB,BAA047B,B5500D2,55D0983,4 BA00DB,A5B00D0,5171680 ,52B00D8,A9300CD,795047D," _
& "6AA00D4,AD500C9,5B5027A,4B600D2,96E0681,A4E00D9,D2600CE,EA6057E,D5300D5,5AA00CB," _
& "76 A037B ,96D00D3,4AB0B83,4AD00DB,A4D00D0,D0B1680,D2500D7,D5200CC,DD4057C,B5A00D4," _
& "56D00C9,55B027A,49B00D2,A570782,A4B00D9,AA50 0CE,B25157E,6D200D6,ADA00CA,4B6137B, " _
& "93700D3,49F08C9,49700DB,64B00D0,68A1680,EA500D7,6AA00CC,A6C147C,AAE00D4,92E00CA," _
& "D2E0379,C9600D1,D550781,D4A 00D9, DA400CD,5D5057E,56A00D6,A6C00CB,55D047B,52D00D3," _
& "A9B0883,A9500DB,B4A00CF,B6A067F,AD500D7,55A00CD,ABA047C,A5A00D4,52B00CA,B2 7037A," _
< p>& "69300D1,7330781,6AA00D9,AD500CE,4B5157E,4B600D6,A5700CB,54E047C,D1600D2,E960882," _& "D5200DA,DAA00CF,6AA167F,56D00D7,4AE00 CD,A9D047D,A2D00D4,D1500C9 ,F250279,D5200D1"
Private Const ylMd0 = "First grade, second grade, third grade, fourth grade, fifth grade, sixth grade, seventh grade, eighth grade, ninth grade, eleven, twenty, thirty, forty-five" _< /p>
& "Sixteen seventeen eighteen nineteen twenty-one twenty-two twenty-three twenty-four twenty-five twenty-six twenty-seven twenty-eight twenty-nine thirty"
Private Const ylMn0 = "正二三四五六七八九十七十七六十六十六 from 10 to 10 years ago"
Private Const ylTianGan0 = "A, B, C, Ding, Wu, Geng, Xin, Rengui"
Private Const ylDiZhi0 = "Zichou, Yinmao, Chen, Siwu Not applied for Youxuhai"
Private Const ylShu0 = "Rat, ox, tiger, rabbit, dragon, snake, horse, sheep, monkey, chicken, dog, pig"
'Convert Gregorian calendar date to lunar calendar
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 it is not valid and has a date, exit
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
'Load 2 Lunar calendar data within the year
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) 'Lunar New Year date
getDay = DateDiff("d", conDate, setDate) + 1 'Difference in days
If getDay < 1 Then AddYear = AddYear - 1: GoTo initYL
thisMonths = Left(daList(AddYear), 14)
RunYue1 = Val("&H" & Right (thisMonths, 1))? 'Leap month
If RunYue1 > 0 Then? 'There is a leap month
thisMonths = Left(thisMonths, RunYue1) & Mid(thisMonths, 13, 1) & Mid(thisMonths, RunYue1 + 1)
End If
thisMonths = Left(thisMonths, 13)
For i = 1 To 13? 'Calculate the number of days
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) + "month "
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 = "Leap" & mm0
GetYLDate = "Lunar calendar" & YLyear & "(" & YLShuXing & ") Year" & mm0 & dd0
aErr:
End Function
'Convert lunar calendar to Gregorian calendar date
'If secondMonth is true, then day Indicates that when tMonth is a leap month, take the second month
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))) 'Lunar New Year date
thisMonths = Left(thisMonths, 14)
RunYue1 = Val("&H " & Right(thisMonths, 1))? 'Leap month
toMonth = tMonth - 1
If RunYue1 > 0 Then? 'There is a leap month
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
'Restore compressed lunar characters
Private Function H2B(ByVal strHex As String) As String
Dim i As Integer, i1 As Integer, tmpV As String
Const hStr = "0123456789ABCDEF"
Const bStr = "00000001001000110100010101100111100010011010101111001101 11101111"
tmpV = UCase(Left(strHex, 3))
'Hexadecimal to binary
For i = 1 To Len(tmpV)
< p>i1 = InStr(hStr, Mid(tmpV, i, 1))H2B = H2B & Mid(bStr, (i1 - 1) * 4 + 1, 4)
Next
H2B = H2B & Mid(strHex, 4, 2)
'Convert hexadecimal to decimal
H2B = H2B & "0" & CStr(Val("&H" & Right(strHex, 2)))
End Function
Private Sub Command1_Click()
Label1.Caption = GetYLDate( Text1.Text)
End Sub