Autor
|
Tema: [RETO] IsDate (Leído 12,265 veces)
|
BlackZeroX
Wiki
Desconectado
Mensajes: 3.158
I'Love...!¡.
|
. Aquí les dejo mi codigo... esta bastante legible... Option Explicit Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal pDst As Long, ByVal pSrc As Long, ByVal ByteLen As Long) ' // Formato aceptado DD/MM/YYYY, D/M/YYYY, D/MM/YYYY, DD/M/YYYY, D/M/Y, etc... Public Function isDate_BlackZX(ByRef sStr As String) As Boolean Dim lChar As Long Dim lVal As Long Dim lConvert(3) As Long Dim lDim As Long Dim lMult As Long Dim pStr As Long Dim pChar As Long pStr = LenB(sStr) If (pStr < &H5) Then Exit Function pStr = StrPtr(sStr) + (pStr - &H4) pChar = VarPtr(lChar) lDim = &H2 lMult = &H1 lConvert(lDim) = &H0 Do Until StrPtr(sStr) > pStr RtlMoveMemory pChar, pStr, &H4 lVal = (lChar And &HFF0000) If (lVal = &H2F0000) Then lDim = (lDim - &H1) If ((lDim And &H80000000) = &H80000000) Then Exit Function lMult = &H1 Else If ((lVal > &H390000) Or (lVal < &H300000)) Then Exit Function lConvert(lDim) = lConvert(lDim) + (((lVal / &H10000) - &H30) * lMult) lMult = (lMult * &HA) End If lVal = (lChar And &HFF) If (lVal = &H2F) Then lDim = (lDim - &H1) If ((lDim And &H80000000) = &H80000000) Then Exit Function lMult = &H1 Else If ((lVal > &H39) Or (lVal < &H30)) Then Exit Function lConvert(lDim) = lConvert(lDim) + ((lVal - &H30) * lMult) lMult = (lMult * &HA) End If pStr = (pStr - &H4) Loop If ((lConvert(&H2) > &H270F) Or _ ((lConvert(&H2) And &H80000000) = &H80000000)) Or _ Not (lDim = &H0) Then Exit Function Select Case lConvert(&H1) Case &H1, &H3, &H5, &H7, &H8, &HA, &HC If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H20)) Then isDate_BlackZX = True Case Is > &HC, Is <= &H0 Exit Function Case Else If (lConvert(&H1) = &H2) Then If ((lConvert(&H2) Mod &H4) = &H0) Then If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1E)) Then isDate_BlackZX = True ElseIf ((lConvert(&H2) Mod 400) = &H0) Then If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1E)) Then isDate_BlackZX = True ElseIf ((lConvert(&H2) Mod 100) = &H0) Then If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1E)) Then isDate_BlackZX = True Else If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1D)) Then isDate_BlackZX = True End If Else If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1F)) Then isDate_BlackZX = True End If End Select End Function
El siguiente codigo en lugar de leer 2 char ( 4 bytes ), solo lee 1 char ( 2 bytes ), PPuede o no ser mas rapido, pero eso a mi no me interesa. Public Function isDate_BlackZX(ByRef sStr As String) As Boolean Dim lChar As Long Dim lVal As Long Dim lConvert(3) As Long Dim lDim As Long Dim lMult As Long Dim pStr As Long Dim pChar As Long pStr = LenB(sStr) If (pStr < &H5) Then Exit Function pStr = StrPtr(sStr) + (pStr - &H2) pChar = VarPtr(lChar) lDim = &H2 lMult = &H1 lConvert(lDim) = &H0 Do Until StrPtr(sStr) > pStr RtlMoveMemory pChar, pStr, &H2 ' // Dos bytes = char... lVal = (lChar And &HFF) If (lVal = &H2F) Then lDim = (lDim - &H1) If ((lDim And &H80000000) = &H80000000) Then Exit Function lMult = &H1 Else If ((lVal > &H39) Or (lVal < &H30)) Then Exit Function lConvert(lDim) = lConvert(lDim) + ((lVal - &H30) * lMult) lMult = (lMult * &HA) End If pStr = (pStr - &H2) Loop If ((lConvert(&H2) > &H270F) Or _ ((lConvert(&H2) And &H80000000) = &H80000000)) Or _ Not (lDim = &H0) Then Exit Function Select Case lConvert(&H1) Case &H1, &H3, &H5, &H7, &H8, &HA, &HC If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H20)) Then isDate_BlackZX = True Case Is > &HC, Is <= &H0 Exit Function Case Else If (lConvert(&H1) = &H2) Then If ((lConvert(&H2) Mod &H4) = &H0) Then If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1E)) Then isDate_BlackZX = True ElseIf ((lConvert(&H2) Mod 400) = &H0) Then If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1E)) Then isDate_BlackZX = True ElseIf ((lConvert(&H2) Mod 100) = &H0) Then If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1E)) Then isDate_BlackZX = True Else If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1D)) Then isDate_BlackZX = True End If Else If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1F)) Then isDate_BlackZX = True End If End Select End Function
Temibles Lunas!¡.
|
|
« Última modificación: 3 Septiembre 2011, 09:22 am por BlackZeroX▓▓▒▒░░ »
|
En línea
|
The Dark Shadow is my passion.
|
|
|
Sanlegas
Desconectado
Mensajes: 131
https://fbcdn-sphotos-e-a.akamaihd.net/hphotos-ak-
|
Public Function IsDate_T(ByRef Expresion As String) As Boolean On Error GoTo err Dim A As Integer Dim B As Integer Dim C As Integer Dim P1 As Integer Dim P2 As Integer Dim F As Boolean P1 = InStr(1, Expresion, "/") If (Not CBool(P1)) Then Exit Function P2 = InStr(P1 + 1, Expresion, "/") If (Not CBool(P2)) Then Exit Function A = Mid(Expresion, 1, P1) B = Mid(Expresion, P1 + 1, P2 - P1) C = Mid(Expresion, P2 + 1, Len(Expresion)) F = (((Not CBool((C Mod 4))) And CBool(C Mod 100)) Or (Not CBool(C Mod 400))) IsDate_T = Not ((C < 0) Or (C > 9999) Or (A < 1) Or (B < 1) Or (B > 12) Or (F And (A > 29) And (B = 2)) Or (Not F And (A > 28) And (B = 2))) err: End Function
Me pude haber ahorrado variables... pero el codigo no quedaria bien explicado y tal vez seria mas lento, o bien usar el "truco" del vb con una variable de tipo Date Salu2 !
|
|
« Última modificación: 29 Agosto 2011, 20:09 pm por Tenient101 »
|
En línea
|
|
|
|
79137913
Desconectado
Mensajes: 1.169
4 Esquinas
|
HOLA!!!
Alguien puede testear que es mas rapido (GoTo Fin o Exit Function)
GRACIAS POR LEER!!!
|
|
|
En línea
|
"Como no se puede igualar a Dios, ya he decidido que hacer, ¡SUPERARLO!" "La peor de las ignorancias es no saber corregirlas"
79137913 *Shadow Scouts Team*
|
|
|
BlackZeroX
Wiki
Desconectado
Mensajes: 3.158
I'Love...!¡.
|
Usa un poco la logica:
Exit function deberia de invocar * El Retorno. * Fin del proceso. Goto deberia invocar. * Un guardado de posicion ( Insersion en una pila ). * Un salto de posicion.
En tu caso lo que haces es un goto al termino es decir * Un guardado de posicion ( Insersion en una pila ). * Un salto de posicion. * El Retorno. * Fin del proceso.
Es mas lento...
Dulces Lunas!¡.
|
|
« Última modificación: 30 Agosto 2011, 19:34 pm por BlackZeroX▓▓▒▒░░ »
|
En línea
|
The Dark Shadow is my passion.
|
|
|
79137913
Desconectado
Mensajes: 1.169
4 Esquinas
|
HOLA!!! Mmm, si como lo planteas si pero pensando esto... El exit function es un goto enfundado (para mi) Acabe de testear y tardan casi lo mismo diferencia infima en un bucle de 600000000 vueltas. Siempre a favor de Exit function, que debe ser ese tiempo donde guarda la posicion de la etiqueta (creo). Pero yendo al tema donde la etiqueta la uso para el handle de errores, ese tiempo ya lo pierdo si o si... entonces debe tardar lo mismo. tomando estas funciones: Private Function a() As Boolean GoTo Fin Fin: End Function Private Function b() As Boolean Exit Function End Function Osea para mi: Exit function deberia de invocar * El Retorno. * Un salto de posicion. * Fin del proceso. Goto deberia invocar. * Un guardado de posicion ( Insersion en una pila ).(solo la primera vez) * Un salto de posicion.
En tu caso lo que haces es un goto al termino es decir * Un guardado de posicion ( Insersion en una pila ).(solo una vez) * El Retorno. * Fin del proceso. * Un salto de posicion. GRACIAS POR LEER!!!
|
|
|
En línea
|
"Como no se puede igualar a Dios, ya he decidido que hacer, ¡SUPERARLO!" "La peor de las ignorancias es no saber corregirlas"
79137913 *Shadow Scouts Team*
|
|
|
BlackZeroX
Wiki
Desconectado
Mensajes: 3.158
I'Love...!¡.
|
El exit function es un goto enfundado (para mi)
Ammm nop exit function seria como una semejansza Uniforme de return como en C/C++, ya que termina la funcion ( Aun que estaria equivocado... pero... tendremos que ver el ASM de una funcion/proceso en vb6 para ver y poder afirmarlo. ) Exit Funcion en mi logica viene siendo una cutre representacion o simulacion de invocar al return de la funcion y por ende su terminacion, mas no de ir al final de una funcion... igual abria que ver el ASM de una funcion en vb6... Puedo estar errado... Aun con pruebas... se sabe... Dulces Lunas!¡.
|
|
|
En línea
|
The Dark Shadow is my passion.
|
|
|
raul338
Desconectado
Mensajes: 2.633
La sonrisa es la mejor forma de afrontar las cosas
|
Resultados parciales Testeo de calidad ============================== 31/07/2000 Tenient101 FAILS 30/07/2000 Tenient101 FAILS 01/02/2000 Tenient101 FAILS 25/05/2002 Tenient101 FAILS 15/07/2000 Tenient101 FAILS 28/02/2001 Tenient101 FAILS 31/05/2001 Tenient101 FAILS 30/12/2011 Tenient101 FAILS 29/02/2004 Tenient101 FAILS 01/01/2001 Tenient101 FAILS 31/12/9999 $Edu$ FAILS 31/12/9999 Tenient101 FAILS 29/02/2012 Tenient101 FAILS
Descargar proyecto de prueba
|
|
« Última modificación: 4 Septiembre 2011, 00:55 am por raul338 »
|
En línea
|
|
|
|
ignorantev1.1
Desconectado
Mensajes: 617
/\ Así acabo cuando quiero programar...
|
@raul338Probé el proyecto(el que pusiste para descargar) varias veces y los resultados varían mucho, hay veces que incluso mi función es la más rápida... ¿Por qué? @BlackZeroxDe qué va que a veces firmas "Dulces Lunas" y otras "Temibles Lunas"?
|
|
|
En línea
|
|
|
|
raul338
Desconectado
Mensajes: 2.633
La sonrisa es la mejor forma de afrontar las cosas
|
Por el uso del procesador, de todas formas, siempre prueba el proyecto COMPILADO! PD: Mi version (iba a hacer algo asi para el IsNumeric pero Black me gano de mano Public Function IsDate_r338(ByVal str As String) As Boolean If str = vbNullString Then Exit Function Dim strp As Long strp = StrPtr(str) If lstrlenW(strp) <> 10 Then Exit Function Dim j As Long, k As Long, dia As Long, mes As Long, anio As Long, jp As Long jp = VarPtr(j) For k = 0 To 18 Step 2 Call RtlMoveMemory(jp, strp + k, 1) Select Case k / 2 Case 0 If j < 48 And j > 51 Then Exit Function dia = (j - 48) * 10 Case 1 If j < 48 And j > 57 Then Exit Function dia = dia + (j - 48) If dia = 0 Or dia > 31 Then Exit Function Case 2, 5: If j <> 47 Then Exit Function Case 3 If j <> 48 And j <> 49 Then Exit Function mes = (j - 48) * 10 Case 4 If j < 48 And j > 57 Then Exit Function mes = mes + (j - 48) If mes = 0 Or mes > 12 Then Exit Function If Not (mes = 1 Or mes = 3 Or mes = 5 Or mes = 7 Or mes = 8 Or mes = 10 Or mes = 12) And dia = 31 Then Exit Function If mes = 2 And dia > 29 Then Exit Function Case 6 If j < 48 And j > 57 Then Exit Function anio = (j - 48) * 1000 Case 7 If j < 48 And j > 57 Then Exit Function anio = anio + (j - 48) * 100 Case 8 If j < 48 And j > 57 Then Exit Function anio = anio + (j - 48) * 10 Case 9 If j < 48 And j > 57 Then Exit Function anio = anio + (j - 48) If mes = 2 And dia = 29 Then If Not (anio Mod 4 = 0 And Not (anio Mod 100 = 0 And anio Mod 400 <> 0)) Then Exit Function End Select Next IsDate_r338 = True End Function
|
|
« Última modificación: 4 Septiembre 2011, 00:46 am por raul338 »
|
En línea
|
|
|
|
BlackZeroX
Wiki
Desconectado
Mensajes: 3.158
I'Love...!¡.
|
. jajaja, la funcion de Raul338 tiene un parecido a la mia... aun asi no se moldea automaticamente a formatos D/M/YYYY, DD/M/YYYY, D/MM/YYYY, etc..., aun asi es muy buena!¡. Edito:MODIFIQUE MI FUNCION ( Aqui [en donde estaba el anterior codigo.]), solo modifique unos cuantos rangos... despresiando la velocidad. Desde cuando " y0/45/hola" es una fecha? respeto el formato DD/MM/YYYY que querian que tuviera. sTests = Split("31/07/2000|30/07/2000|01/02/2000|25/05/2002|15/07/2000|28/02/2001|" & _ "31/05/2001|30/12/2011|29/02/2004|01/01/2001|31/12/9999|29/02/2012", "|") sFalses = Split("01/00/2011|31/04/2001|00/12/2011|00/00/2011|01/13/2011|30/02/2001|y0/45/hola|" & _ "29/02/2003|99/99/9999|32/12/9999|29/13/2000|LALA|00/00/0000|31/09/2011|y0/45/hola|", "|") Open App.Path & "\log.txt" For Output As #1 Call txt(" === Reto IsDate ====") Call txt(Date$ & " " & Time$) Call txt("Testeo de calidad", True) For i = 0 To UBound(sTests) If modFunctions.heyIgnorante_isDate(sTests(i)) = False Then Call txt(sTests(i) & vbTab & "Ignorante v1.1 FAILS") If modFunctions.IsDate_7913_v2(sTests(i)) = False Then Call txt(sTests(i) & vbTab & "79137913 FAILS") If modFunctions.isDate_BlackZX(sTests(i)) = False Then Call txt(sTests(i) & vbTab & "BlackZeroX FAILS") If modFunctions.isDate_edu(sTests(i)) = False Then Call txt(sTests(i) & vbTab & "$Edu$ FAILS") If modFunctions.IsDate_T(sTests(i)) = False Then Call txt(sTests(i) & vbTab & "Tenient101 FAILS") If modFunctions.IsDate_r338(sTests(i)) = False Then Call txt(sTests(i) & vbTab & "Raul338 FAILS") Next Call txt("Testeo de falsos", True) For i = 0 To UBound(sFalses) If modFunctions.heyIgnorante_isDate(sFalses(i)) Then Call txt(sFalses(i) & vbTab & "Ignorante v1.1 FAILS") If modFunctions.IsDate_7913_v2(sFalses(i)) Then Call txt(sFalses(i) & vbTab & "79137913 FAILS") If modFunctions.isDate_BlackZX(sFalses(i)) Then Call txt(sFalses(i) & vbTab & "BlackZeroX FAILS") If modFunctions.isDate_edu(sFalses(i)) Then Call txt(sFalses(i) & vbTab & "$Edu$ FAILS") If modFunctions.IsDate_T(sFalses(i)) Then Call txt(sTests(i) & vbTab & "Tenient101 FAILS") If modFunctions.IsDate_r338(sFalses(i)) Then Call txt(sFalses(i) & vbTab & "Raul338 FAILS") Next
Al test de velocidades hay que hacerle una media de velocidad ya que a mi me salio esto... claro que igual me gana en otras ocasiones Raul338... === Reto IsDate ==== 09-03-2011 01:43:19
Testeo de calidad ============================== 31/07/2000 Tenient101 FAILS 30/07/2000 Tenient101 FAILS 01/02/2000 Tenient101 FAILS 25/05/2002 Tenient101 FAILS 15/07/2000 Tenient101 FAILS 28/02/2001 Tenient101 FAILS 31/05/2001 Tenient101 FAILS 30/12/2011 Tenient101 FAILS 29/02/2004 Tenient101 FAILS 01/01/2001 Tenient101 FAILS 31/12/9999 $Edu$ FAILS 31/12/9999 Tenient101 FAILS 29/02/2012 Tenient101 FAILS
Testeo de falsos ============================== 01/00/2011 Raul338 FAILS 00/12/2011 Raul338 FAILS 00/00/2011 Raul338 FAILS 01/13/2011 Raul338 FAILS 32/12/9999 Raul338 FAILS 29/13/2000 Raul338 FAILS 00/00/0000 Raul338 FAILS 31/09/2011 $Edu$ FAILS
Testeo de velocidades ============================== 79.816 msec Ignorante v1.1 74.246 msec 79137913 10.764 msec BlackZeroX 108.810 msec $Edu$ 63.844 msec Tenient101 12.090 msec Raul338
Sangriento Infierno Lunar!¡.
|
|
« Última modificación: 3 Septiembre 2011, 09:13 am por BlackZeroX▓▓▒▒░░ »
|
En línea
|
The Dark Shadow is my passion.
|
|
|
|
Mensajes similares |
|
Asunto |
Iniciado por |
Respuestas |
Vistas |
Último mensaje |
|
|
Reto ;)
Ingeniería Inversa
|
NeoKiller
|
3
|
3,196
|
15 Agosto 2004, 23:12 pm
por NeoKiller
|
|
|
Reto!!
Ingeniería Inversa
|
HaCkZaTaN
|
2
|
3,212
|
10 Septiembre 2004, 09:30 am
por Ðevastador
|
|
|
Reto vB
Ingeniería Inversa
|
nhouse
|
2
|
3,704
|
16 Marzo 2005, 09:41 am
por 4rS3NI(
|
|
|
reto en VB6
Ingeniería Inversa
|
ellolo
|
1
|
2,818
|
15 Abril 2005, 10:03 am
por UnpaCker!
|
|
|
Un reto !!!
« 1 2 3 »
Programación Visual Basic
|
VirucKingX
|
24
|
9,226
|
8 Mayo 2006, 23:36 pm
por Kizar
|
|