Constellation Knowledge Network - Preguntas y respuestas sobre la interpretación de los sueños - Quiero un código fuente en lenguaje vb para calcular cumpleaños y horóscopos

Quiero un código fuente en lenguaje vb para calcular cumpleaños y horóscopos

Existe un método de cálculo para esto. Siempre que tengas la fórmula de cálculo, puedo calcularla. Pero el requisito previo es tener la fórmula de cálculo.

'Módulo de calendario gregoriano a calendario lunar

'//Definición de datos del calendario lunar//

'Primero use la función H2B para restaurarlo en una cadena con una longitud de 18 y su definición es la siguiente:

'Los primeros 12 bytes representan de enero a diciembre: 1 es el mes grande, 0 es el mes pequeño comprimido en hexadecimal (1-3 dígitos)

'Cuando el dígito 13 es un mes bisiesto, 1 es un mes grande con 30 días y 0 es un mes pequeño con 29 días (4 dígitos)

'El dígito 14; es el mes de un mes bisiesto, si no es un mes bisiesto, es 0, de lo contrario Da el mes (5 dígitos)

'Los últimos 4 dígitos son la fecha del calendario gregoriano del Año Nuevo Lunar ese año, por ejemplo, 0131 representa el 31 de enero; trátelo como un valor numérico y conviértalo a hexadecimal (6-7 dígitos)

'Constante lunar (1899~2100, ***202 años)

Const ylData privado = "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,AB 5147C,2B600D5, " p>& "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,AB600D 9,93700CE,4AF057F," _

& "49700D7,64B00CC,74A037B,EA500D2,6B50883,5AC00DB,AB600CF,96D0580,92E00 D8,C9600CD," _

& "D95047C,D4A00D4,DA500C9,755027A,56 A00D1, 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," _

& "76A037B,96D00D3,4AB0B83,4AD00DB,A4D00D0, D0B1680,D2500D7,D5200CC,DD4057C ,B5A00D4", _

& "56D00C9,55B027A,49B00D2,A570782,A4B00D9,AA500CE,B25157E,6D200D6,ADA00CA,4B6137B," _

& "93700D3,49F08C9, 00DB ,64B00D0,68A1680,EA500D7,6AA00CC,A6C147C,AAE00D4,92E00CA," _

& "D2E0379,C9600D1,D550781,D4A00D9,DA400CD,5D5057E,56A00D6,A6C00 55D047B,52D00D3," _< / p>

& "A9B0883,A9500DB,B4A00CF,B6A067F,AD500D7,55A00CD,ABA047C,A5A00D4,52B00CA,B27037A," _

& "69300D1,7330781,6AA00D9,AD500CE,4B5 57E, 4B600D6, A5700CB,54E047C,D1600D2,E960882," _

& "D5200DA,DAA00CF,6AA167F,56D00D7,4AE00CD,A9D047D,A2D00D4,D1500C9,F250279,D5200D1"

P Rivado Const ylMd0 = "Primer grado, segundo grado, tercer grado, cuarto grado, quinto grado, sexto grado, séptimo grado, octavo grado, noveno grado, once, veinte, treinta, cuarenta y cinco" _

& "Dieciséis, diecisiete, dieciocho, diecinueve, veintiuno, veintidós, veintitrés, veinticuatro, veinticinco, veintiséis, veintisiete, veintiocho, veintinueve y treinta"

Const privada ylMn0 = "正二三四五六七八九十七八九十俑"

p>

Const privada ylTianGan0 = "A, B, C, Ding, Wu, Geng, Xin, Rengui"

Const privada ylDiZhi0 = "Zichou, Yinmao, Chen, Siwu, Wuwei, Youxuhai"

Const privada ylShu0 = " Rata, vaca, tigre, conejo, dragón, serpiente, caballo, oveja, mono, pollo, perro, cerdo"

'Convertir fecha del calendario gregoriano en calendario lunar

Función GetYLDate(ByVal strDate As String) As String

En caso de error, vaya a aErr

Si no es IsDate(strDate), salga de la función

Atenuar setDate como fecha, tAño como entero, tMes como entero, tDía como entero

setDate = CDate(strDate)

tYear = Año(setDate): tMes = Mes(setDate): tDay = Día(setDate)

'Si no es así válido y tiene una fecha, salga

Si tYear > 2100 o tYear < 1900, entonces salga de la función

Dim daList() como cadena

* 18, conDate como fecha, thisMonths como cadena

Dim AddYear como entero, AddMonth como entero, AddDay como entero, getDay como entero

Dim YLyear como cadena, YLShuXing como cadena

Dim dd0 como cadena, mm0 como cadena, ganzhi(0 a 59) como cadena * 2

Dim RunYue como booleano, RunYue1 como entero, mDays como entero, i como entero

'Cargar datos del calendario lunar dentro de 2 años

ReDim daList(tYear - 1 To tYear)

daList(tYear - 1) = H2B(Mid(ylData, (tYear - 1900) * 8 + 1, 7))

daList(tAño) = H2B(Mid(ylData, (tAño - 1900 + 1) * 8 + 1, 7))

AgregarAño = tAño

initYL:

AgregarMes = CInt(Mid(daList(AddAño), 15, 2))

AgregarDía = CInt(Mid(daList) ( AddYear), 17, 2))

conDate = DateSerial(AddYear, AddMonth, AddDay) 'Fecha del Año Nuevo Lunar

getDay = DateDiff("d", conDate, setDate) + 1 'Diferencia en días

Si getDay < 1 Then AddYear = AddYear - 1: GoTo initYL

thisMonths = Left(daList(AddYear), 14)

RunYue1 = Val("&H" & Right(thisMonths, 1))? 'Mes bisiesto

Si RunYue1 > 0 ¿Entonces? 'Hay un mes bisiesto

thisMonths = Left( thisMonths, RunYue1) & Mid (thisMonths, 13, 1) & Mid(thisMonths, RunYue1 + 1)

End If

thisMonths = Left(thisMonths, 13)

¿Para i = 1 a 13? 'Calcular el número de días

mDays = 29 + CInt(Mid(thisMonths, i, 1))

If getDay > mDays Then

getDay = getDay - mDays

Else

Si RunYue1 > 0 Entonces

Si i = RunYue1 + 1 Entonces RunYue = True

Si i > RunYue1 Entonces i = i - 1

Finalizar si

AddMonth = i

AddDay = getDay

Salir para

Finalizar si

Siguiente

dd0 = Medio(ylMd0, (AddDay - 1) * 2 + 1, 2)

mm0 = Medio(ylMn0, AddMonth, 1) + "mes"

Para i = 0 a 59

ganzhi(i) = Mid(ylTianGan0, (i Mod 10) + 1, 1) + Mid(ylDiZhi0, (i Mod 12) + 1, 1 )

Siguiente i

YLyear = ganzhi((AddYear - 4) Mod 60)

YLShuXing = Mid(ylShu0, ((AddYear - 4) Mod 12 ) + 1, 1)

Si RunYue Entonces mm0 = "Salto" & mm0

GetYLDate = "Calendario lunar" & YLyear & "(" & YLShuXing & ")年" & mm0 & dd0

aErr:

Función final

'Convertir calendario lunar a fecha del calendario gregoriano

'Si secondMonth es verdadero, el sky indica cuando tMonth es Cuando es un mes bisiesto, obtenga el segundo mes

Función GetDate(ByVal tYear As Integer, tMonth As Integer, tDay As Integer, SecondMonth Opcional As Boolean = False) Como String

En caso de error, GoTo aErr

Si tYear > 2100 o tYear < 1899 o tMonth > 12 o tMonth < 1 o tDay > 30 o tDay < 1, entonces salga de la función

Atenuar thisMonths como cadena, ylNewYear como fecha, toMonth como entero

Dim mDays como entero, RunYue1 como entero, i como entero

thisMonths = H2B(Mid(ylData, (tYear - 1899) ) * 8 + 1, 7) )

Si tDay > 29 + CInt(Mid(thisMonths, tMonth, 1)) Entonces salga de la función

ylNewYear = DateSerial(tYear, CInt( Mid(thisMonths, 15, 2) ), CInt(Mid(thisMonths, 17, 2))) 'Fecha del Año Nuevo Lunar

thisMonths = Left(thisMonths, 14)

RunYue1 = Val("&H" & Right( thisMonths, 1))? 'Mes bisiesto

toMonth = tMonth - 1

Si RunYue1 > 0 ¿Entonces hay un mes bisiesto

thisMonths = Left(thisMonths, RunYue1) & Mid(thisMonths, 13, 1) & Mid(thisMonths, RunYue1 + 1)

Si tMont

h > RunYue1 O (segundoMes Y tMes = RunYue1) Entonces toMonth = tMonth

Fin

thisMonths = Left(thisMonths, 13)

mDays = 0

Para i = 1 A toMonth

mDays = mDays + 29 + CInt(Mid(thisMonths, i, 1))

Siguiente

mDays = mDays + tDay

GetDate = ylNewYear + mDays - 1

aErr:

End Function

' Comprimirá la luna calendario Restauración de caracteres

Función privada H2B(ByVal strHex como cadena) Como cadena

Dim i como entero, i1 como entero, tmpV como cadena

Const hStr = " 0123456789ABCDEF"

Const bStr = "0000000100100011010001010110011110001001101010111100110111101111"

tmpV = UCase(Left(strHex 3))

'Convertir hexadecimal a binario

Para i = 1 a Len(tmpV)

i1 = InStr(hStr, Mid(tmpV, i, 1))

H2B = H2B & Mid(bStr, ( i1 - 1) * 4 + 1, 4)

Siguiente

H2B = H2B & Mid(strHex, 4, 2)

'Hexadecimal Convertir sistema a decimal

H2B = H2B & "0" & ​​​​CStr(Val("&H" & Right(strHex, 2)))

Función final

Subcomando privado1_Click()

Label1.Caption = GetYLDate(Text1.Text)

End Sub

上篇: Cómo cerrar la caja del pastel 下篇: ¿Cuánto tiempo lleva regresar a la escuela después del primer número de lotería para los estudiantes de escuela primaria en el distrito de Yuexiu, Guangzhou?
Artículos populares