Bueno, para seguir con esto de los retos y hacer que haya mas actividad competitiva y cooperativa (y no tantas dudas :xD) propongo hacer la alternativa a la función IsDate con la siguiente firma
Function IsDate_Nombre(str As String) As Boolean
Function IsDate_Nombre_vX(str As String) As Boolean
'Ejemplos
Function IsDate_r338(str As String) As Boolean
Function IsDate_r338_v2(str As String) As Boolean
Function IsDate_7913(str As String) As Boolean
Tienen hasta el 5/09/2011 para proponer sus funciones bien pulidas y ahí las pondré a prueba ::)
- Para medir los tiempos se utilizará la clase CTiming (http://www.xbeat.net/vbspeed/download/CTiming.zip) utilizada en otros retos (Ver ejemplo de como se utiliza (http://foro.elhacker.net/programacion_visual_basic/reto-t302373.0.html;msg1500011#msg1500011))
- Se recomiendan usar API's, otras funciones, ASM, lo que se les ocurra
- No te inhibes, mientras mas concursantes participen, mejor!
- No es estrictamente necesario que sea igual que IsDate (como paso con IsNumeric que "1..2..3" era un numero, WTF!) tan solo debe validar fechas
- Debe aceptar desde 01/01/0000 hasta 31/12/9999
- La fecha DEBE ser valida, deben fijarse si el año es bisiesto, no debe devolver TRUE en un dia 31 con un mes que solo tiene 30 dias
- Puede aceptar en distintos formatos, pero la mayoría de las pruebas las haré con "DD/MM/YYYY" para no presionar tanto
- 1/1/2000
- 01/01/2000
- 1/1/00
- 01/01/00
- Sobre los separadores y el formato por default tomare "DD/MM/YYYY" con "/" como separador, aunque hay rutinas para obtener el formato y el separador :P
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Function GetDateSeparator() As String
Dim strLen As Long
GetDateSeparator = String$(5, 0)
strLen = GetProfileString("Intl", "sDate", "", GetDateSeparator, Len(GetDateSeparator))
GetDateSeparator = Left$(GetDateSeparator, strLen)
End Function
Function GetDateFormat() As String
Dim strLen As Long
GetDateFormat = String$(11, 0)
strLen = GetProfileString("Intl", "sShortDate", "", GetDateFormat, Len(GetDateFormat))
GetDateFormat = Left$(GetDateFormat, strLen)
End Function
Por el momento con estas fechas debe devolver true
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
Y con estas false
01/00/2011 ' No existe Mes 00
31/04/2001 ' Abril no tiene 31 xD
00/12/2011 ' Dia 00, WTF
00/00/2011 ' Dia 00, Mes 00, WTF x2
01/13/2011 ' Mes 13, WTF!
30/02/2001 ' Febrero NUNCA tendra 30
29/02/2003 ' 2003 No es bisiesto :3
Suerte a todos ;D ;-) y repito
No te inhibes, mientras mas concursantes participen, mejor!
.
Espacios en blanco?... = valen o se descartan...
Dulces Lunas!¡.
Function heyIgnorante_isDate(ByVal sDate As String) As Boolean
Dim elemts() As String
Dim D As Integer, M As Integer, A As Integer
sDate = Trim$(sDate)
elemnts = Split(sDate, "/")
If UBound(elemnts) <> 2 Then Exit Function
D = Val(elemnts(0)): M = Val(elemnts(1)): A = Val(elemnts(2))
If D > 31 Or D < 1 Or M > 12 Or M < 1 Or A > 9999 Or A < 0 Then Exit Function
If ((M < 8 And M Mod 2 = 0) Or (M > 7 And M Mod 2 = 1)) And D > 30 Then Exit Function
If (A Mod 4 <> 0 And M = 2 And D > 28) Or _
(A Mod 100 = 0 And A Mod 400 <> 0) Then
Exit Function
End If
heyIgnorante_isDate = True
End Function
A ver, aquí esta mi archirecontraultrasupermegavegetarianamarcianarobotpirata función...
Bastante básica, pero pasó las pruebas que pusiste y solo a eso se limita.
No mencionaste sobre... los... emmm... no sé como llamarlos, los caracteres que dividen día, mes, año: "/" <---- así que solo acepta este...
Saludos!
Edite: ¡JUM! :¬¬, @BlackZeroX▓▓▒▒░░
bueno yo creo que la funcion debe de tener las misma caracteristicas de la funcion isdate :P sino no se llamara del todo reemplazo de la funcion :P y pienso que raul338 dio informacion adicional acerca de la funcion isdate :P y no creo que no se referia a restricciones o adiciones a nuestra funcion :P
Cita de: BlackZeroX▓▓▒▒░░ en 28 Agosto 2011, 21:37 PM
Espacios en blanco?... = valen o se descartan...
Sin espacios.. solo numeros y "/"
Cita de: Raul100 en 28 Agosto 2011, 22:15 PM
bueno yo creo que la funcion debe de tener las misma caracteristicas de la funcion isdate :P sino no se llamara del todo reemplazo de la funcion :P
Pero no puse que sea "reemplazo" :xD
Ahi agrego un edit sobre el "/"
Cita de: raul338 en 28 Agosto 2011, 22:18 PM
Sin espacios.. solo numeros y "/"
Pero no puse que sea "reemplazo" :xD
"Bueno, para seguir con esto de los retos y hacer que haya mas actividad competitiva y cooperativa (y no tantas dudas ) propongo hacer el
reemplazo a la función IsDate con la siguiente firma"
:¬¬
v_v'
@Raul100: No era la intencion :xD
Ahi puse un codigo para obtener el formato y el separador, por si alguien quiere experimentar a futuro
HOLA!!!
Me puse a ver que podia hacer y salio esto:
Uso GoTos no me reten :P
/Ofuscando codigo :P/
VERSION 2.0
Private Function IsDate_7913_v2(str As String) As Boolean
On Error GoTo Fin
Dim Partes(2) As Long
Dim Primer() As String
Primer = Split(str, "/")
If UBound(Primer) <> 2 Then GoTo Fin
Partes(0) = Primer(0): Partes(1) = Primer(1): Partes(2) = Primer(2)
If Partes(2) > 9999 Then GoTo Fin
Select Case Partes(1) 'verificamos el mes
Case 0
GoTo Fin
Case 1, 3, 5, 7, 8, 10, 12 'si es de 31 dias
Select Case Partes(0) 'verificamos el dia
Case Is > 31
GoTo Fin 'si es mayor que 31 es false
Case Is < 1
GoTo Fin 'si es menor que 1 es false
Case Else
IsDate_7913_v2 = True : GoTo Fin 'sino true
End Select
Case 4, 6, 9, 11 'si es de 30 dias
Select Case Partes(0)
Case Is > 30
GoTo Fin
Case Is < 1
GoTo Fin
Case Else
IsDate_7913_v2 = True : GoTo Fin
End Select
Case 2 'si es febrero
Select Case Partes(0)
Case Is > 29 'si es mayor que 29
GoTo Fin
Case Is < 1 ' si es menor a 1
GoTo Fin
Case 29
If Partes(2) Mod 4 = 0 Then
If Partes(2) Mod 100 = 0 Then
If Partes(2) Mod 400 = 0 Then IsDate_7913_v2 = True 'si es biciesto multiplo de 100 y 400
Else
IsDate_7913_v2 = True : GoTo Fin 'si es biciesto
End If
End If
Case Else
IsDate_7913_v2 = True : GoTo Fin
End Select
End Select
Fin:
End Function
GRACIAS POR LEER!!!
Aca va el mio a ver que tal, no se si sera lento, pero lo intente hacer con mejor funcionalidad.
Option Explicit
Private Sub Form_Load()
Debug.Print "------CORRECTAS-------"
Debug.Print isDate_edu("31/07/2000")
Debug.Print isDate_edu("30/07/2000")
Debug.Print isDate_edu("01/02/2000")
Debug.Print isDate_edu("25/05/2002")
Debug.Print isDate_edu("15/07/2000")
Debug.Print isDate_edu("28/02/2001")
Debug.Print isDate_edu("31/05/2001")
Debug.Print isDate_edu("30/12/2011")
Debug.Print isDate_edu("29/02/2004")
Debug.Print "------FALSAS----------"
Debug.Print isDate_edu("01/00/2011")
Debug.Print isDate_edu("31/04/2001")
Debug.Print isDate_edu("00/12/2011")
Debug.Print isDate_edu("00/00/2011")
Debug.Print isDate_edu("01/13/2011")
Debug.Print isDate_edu("30/02/2001")
Debug.Print isDate_edu("29/02/2003")
End Sub
Function isDate_edu(str As String) As Boolean
Dim dato() As String
Dim anno, mes, dia As String
str = Trim$(str)
dato = Split(str, "/")
If UBound(dato) <> 2 Then Exit Function
dia = Val(dato(0))
mes = Val(dato(1))
anno = Val(dato(2))
If anno < 1 Or mes < 1 Or dia < 1 Then Exit Function
If mes > 12 Or dia > 31 Then Exit Function
If (Not mes And 1) And (mes <> 8) And (dia > 30) Then Exit Function
If (mes = 2 And dia > 28) And Not (anno Mod 4 = 0 And Not (anno Mod 100 = 0 And anno Mod 400 <> 0)) Then Exit Function
isDate_edu = True
End Function
Acuerdense que hay una exepcion para lo de los años biciestros, pueden mirar mi codigo y despues eso que pusiste ignore.. un año mayor que 9999 no puede ser? xD
un dato a añadir...
Un año es bisiesto si es divisible entre 4, excepto el último de cada siglo (aquel divisible por 100), salvo que este último sea divisible por 400.
Dulces Lunas!¡.
.
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!¡.
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 :xD
Salu2 ! :P
HOLA!!!
Alguien puede testear que es mas rapido (GoTo Fin o Exit Function)
GRACIAS POR LEER!!!
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!¡.
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:
CitarExit 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!!!
Cita de: 79137913 en 30 Agosto 2011, 19:47 PM
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!¡.
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 (http://www.mediafire.com/?9ax6b1w9ctb6foe) proyecto de prueba
@raul338
Probé 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é?
@BlackZerox
De qué va que a veces firmas "Dulces Lunas" y otras "Temibles Lunas"? :silbar:
Por el uso del procesador, de todas formas, siempre prueba el proyecto COMPILADO! :D
PD: Mi version (iba a hacer algo asi para el IsNumeric pero Black me gano de mano :xD
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, año 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
año = (j - 48) * 1000
Case 7
If j < 48 And j > 57 Then Exit Function
año = año + (j - 48) * 100
Case 8
If j < 48 And j > 57 Then Exit Function
año = año + (j - 48) * 10
Case 9
If j < 48 And j > 57 Then Exit Function
año = año + (j - 48)
If mes = 2 And dia = 29 Then If Not (año Mod 4 = 0 And Not (año Mod 100 = 0 And año Mod 400 <> 0)) Then Exit Function
End Select
Next
IsDate_r338 = True
End Function
.
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.] (http://foro.elhacker.net/programacion_visual_basic/reto_isdate-t337553.0.html;msg1657521#msg1657521)), 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!¡.
A ver que yo nunca hago retos, quiero saber que hice mal yo xD y que es eso de que falla con el año 9999? no es una fecha eso? digo por lo del codigo de ignorante..
Cita de: $Edu$ en 3 Septiembre 2011, 20:54 PM
A ver que yo nunca hago retos, quiero saber que hice mal yo xD y que es eso de que falla con el año 9999? no es una fecha eso? digo por lo del codigo de ignorante..
Quiere decir que tu funcion no devuelve como se espera, en la sección "Testeo de calidad" tu funcion deberia devolver TRUE pero devuelve false, si esta en "Testeo de falsos" tu funcion devuelve true y deberia ser falsos :xD
Utilizando mi ultima versión y la ultima de Black con 500000 vueltas por prueba
Testeo de velocidades
==============================
529,028 msec Raul338
532,471 msec BlackZeroX
3.522,390 msec 79137913
3.797,892 msec Tenient101
3.887,114 msec Ignorante v1.1
5.204,378 msec $Edu$
Si raul lo se -_-' xD pero me refiero a porque si yo habia probado todos y andaban bien, y que es eso del codigo de ignorante que un año no puede ser mayor a 9999? xD
@$Edu$
Seguramente solo es por que asi esta definido como reto, vaya puede ser del año -infinito hasta infinito tomando en cuenta que el 0 es donde se dice que es la era cristiana... y los numeros negativos los años A.C., pero claro como no hay años negativos (signo negativo) se pueden interpretar como A.C. y no D.C ( Actualidad ).
Dulces Lunas!¡.
Un poco tarde... :silbar: aquí está la mía:
Option Explicit
Private Const sMonths$ = "01 02 03 04 05 06 07 08 09 10 11 12"
Private Const s31Months$ = " 1 3 5 7 8 01 03 05 08 10 12 "
Private Const sDays$ = sMonths & " 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31"
'// Acepta formatos: DD/MM/YYYY, D/MM/YYYY y DD/M/YYYY.
Public Static Function IsDate_Psyke1(ByRef sDate$) As Boolean
Dim sDay$, sMonth$, sYear$, lp1&, lp2&
If LenB(sDate) < &H16 And LenB(sDate) > &HE Then
lp1 = InStrB(1, sDate, "/", vbBinaryCompare)
If lp1 = 0 Then Exit Function
sDay = LeftB$(sDate, lp1 - 1)
If InStrB(1, sDays, sDay, vbBinaryCompare) Then
lp2 = InStrB(lp1 + 1, sDate, "/", vbBinaryCompare)
If lp2 = 0 Then Exit Function
sMonth = MidB$(sDate, lp1 + 2, lp2 - lp1 - 2)
If InStrB(1, sMonths, sMonth, vbBinaryCompare) Then
sYear = RightB$(sDate, 8)
If Not (sYear Like "####") Then Exit Function
If InStrB(1, "02", sMonth, vbBinaryCompare) Then
If InStrB(1, "29", sDay, vbBinaryCompare) Then
IsDate_Psyke1 = ((sYear Mod &H4 = 0) And (sYear Mod &H64) Or (sYear Mod &H190 = 0))
Exit Function
ElseIf InStrB(1, "30", sDay, vbBinaryCompare) Then
Exit Function
End If
ElseIf InStrB(1, "31", sDay, vbBinaryCompare) Then
IsDate_Psyke1 = InstrB(1, s31Months, sMonth, vbBinaryCompare)
Exit Function
End If
IsDate_Psyke1 = True
End If
End If
End If
End Function
Tests:
Private Sub Form_Load()
Const sLine$ = "----------------------------------------"
Debug.Print sLine; "TRUE"; sLine
Debug.Print IsDate_Psyke1("31/07/2000")
Debug.Print IsDate_Psyke1("29/02/2004")
Debug.Print IsDate_Psyke1("15/07/2000")
Debug.Print IsDate_Psyke1("30/12/2011")
Debug.Print sLine; "FALSE"; sLine
Debug.Print IsDate_Psyke1("29/02/2003")
Debug.Print IsDate_Psyke1("01/13/2011")
Debug.Print IsDate_Psyke1("30/02/2001")
Debug.Print IsDate_Psyke1("00/12/2011")
Debug.Print IsDate_Psyke1("as/12/2000")
Debug.Print IsDate_Psyke1("13/as/2000")
Debug.Print IsDate_Psyke1("-31/44/2070")
Debug.Print IsDate_Psyke1("31/12/20s0")
End Sub
Resultado:
----------------------------------------TRUE----------------------------------------
True
True
True
True
----------------------------------------FALSE----------------------------------------
False
False
False
False
False
False
False
False
Ahora con el proyecto de raul338 (compilado y con la función de BlackZeroX actualizada), los tests me dicen que devuelve resultados correctos, y en cuanto a velocidad me dio esto:
Testeo de velocidades
==============================
43,920 msec Ignorante v1.1
35,993 msec 79137913
21,728 msec BlackZeroX
73,901 msec $Edu$
89,051 msec Tenient101
27,381 msec Raul338
16,374 msec Psyke1
@Raul338, @Ignorante :
Debug.Print IsDate_r338("31/12/20f0") ' = True.. xD
Debug.Print heyIgnorante_isDate("31/12/25y0") ' = True.. xD
Por tanto las funciones que dan resultados correctos:
Testeo de velocidades
==============================
35,993 msec 79137913
21,728 msec BlackZeroX
16,374 msec Psyke1
@BlackZeroX:
Me gustaría que me explicaras un par de cosas de tu código, si te pillo por el msn te molesto, que hace mucho que no hablamos. :-*
DoEvents! :P
Yo igual repare la mia... :rolleyes:
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
Dim F2 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 - 1)
B = Mid(Expresion, P1 + 1, P2 - P1 - 1)
C = Mid(Expresion, P2 + 1, Len(Expresion))
If (A And &H20) Then Exit Function
If (C And &H8000) Then Exit Function
If (B And &H8) Then
P1 = (B - &H8)
If (P1 And &H4) Then
P1 = (P1 - &H4)
If (P1 And &H1) Then
Exit Function
Else
F2 = True
End If
Else
If (P1 And &H2) Then
P1 = (P1 - &H2)
If (P1 Or &H0) = &H0 Then F2 = True
Else
If (P1 Or &H0) = &H0 Then F2 = True
End If
End If
Else
If (B And &H4) Then
P1 = (B - &H4)
If (P1 And &H2) Then
P1 = (P1 - &H2)
If (P1 And &H1) Then F2 = True
Else
If (P1 And &H1) Then F2 = True
End If
Else
If (B And &H2) Then
P1 = (B - &H2)
If (P1 And &H1) Then F2 = True
Else
If (B And &H1) Then F2 = True
End If
End If
End If
If (C And &H2000) Then
P1 = (P1 - &H2000)
If (P1 And &H400) Then
P1 = (P1 - &H400)
If (P1 And &H200) Then
P1 = (P1 - &H200)
If (P1 And &H100) Then
P1 = (P1 - &H100)
If (P1 And &H10) Then Exit Function
End If
End If
End If
End If
F = (((Not CBool((C Mod &H4))) And CBool(C Mod &H64)) Or (Not CBool(C Mod &H190)))
IsDate_T = True
If (A And &H10) Then
P1 = (A - &H10)
If (P1 And &H10) Then
If ((Not F2) And (Not F)) Then IsDate_T = False
Else
If (P1 And &H8) Then
P1 = (P1 - &H8)
If (P1 And &H4) Then
P1 = (P1 - &H4)
If P1 Then
If (B = &H2) Then
If (Not F) Then
IsDate_T = False
Else
If (Not (P1 = &H1)) Then IsDate_T = False
End If
Else
If (P1 And &H2) Then
P1 = (P1 - &H2)
If (P1 And &H1) Then
IsDate_T = F2
Else
If (P1 Or &H0) = &H0 Then
IsDate_T = F2
Else
IsDate_T = Not F2
End If
End If
End If
End If
End If
End If
End If
End If
End If
err:
End Function
@Psyke1: "31/02/2011" = True :o
Salu2!
Ook, gracias, se me escapó una cosa, sólo fue cambiar el orden de un If... :silbar:
DoEvents! :P
Mi nueva minifunción (no es para ir rápido, pero creo que es la manera más corta de hacerlo):
Option Explicit
'// Acepta formatos: DD/MM/YYYY, D/MM/YYYY y DD/M/YYYY.
Public Static Function IsDate_Psyke12(ByRef sDate$) As Boolean
On Error Resume Next
IsDate_Psyke12 = InStrB(1, CDate(sDate), sDate, vbBinaryCompare)
End Function
La más rápida que se me ocurre:
Option Explicit
'// Acepta formatos: DD/MM/YYYY, D/MM/YYYY y DD/M/YYYY.
Public Static Function IsDate_Psyke13(ByRef sDate$) As Boolean
Dim lDay&, lMonth&, lYear&, lp1&
On Error GoTo DateError
lp1 = InStrB(1, sDate, "/", vbBinaryCompare)
If lp1 = 0 Then Exit Function
lYear = RightB$(sDate, 8)
lDay = LeftB$(sDate, lp1 - 1)
If lDay > 31 Then Exit Function
If lDay < 1 Then Exit Function
lMonth = MidB$(sDate, lp1 + 2, InStrB(lp1 + 1, sDate, "/", vbBinaryCompare) - lp1 - 2)
Select Case lMonth
Case Is > 12, Is < 1
Exit Function
Case 2
If lDay = 29 Then
IsDate_Psyke13 = ((lYear Mod &H4 = 0) And (lYear Mod &H64) Or (lYear Mod &H190 = 0))
Exit Function
ElseIf lDay > 29 Then
Exit Function
End If
Case Else
If lDay = 31 Then
Select Case lMonth
Case 1,3,5,7,8,10,12
IsDate_Psyke13 = True
End Select
Exit Function
End If
End Select
IsDate_Psyke13 = True
Exit Function
DateError:
End Function
@Tenient101
Quizás un poco larga, pero me gustó la idea, por cierto:
Testeo de calidad
==============================
30/07/2000 Tenient101 FAILS
30/12/2011 Tenient101 FAILS
31/12/9999 $Edu$ FAILS
Resultados:
Testeo de velocidades
==============================
43,271 msec Ignorante v1.1
43,986 msec 79137913
21,627 msec BlackZeroX
60,085 msec $Edu$
20,118 msec Tenient101
27,267 msec Raul338
18,805 msec Psyke1
29,638 msec Psyke12
12,705 msec Psyke13
23,933 msec IsDate (función original de vb)
IsDate() PWND! :xD
(http://t2.gstatic.com/images?q=tbn:ANd9GcTVtVXfM_fVh_mWr1Ow5ETgd0px-o5GGlKX_EBIcp4xXwe5k40mmC7AHRJCZg)
DoEvents! :P
Ya esta corregida :rolleyes:, pero dos funciones tuyas siguen dando fail
Citar"31/11/2011" --- Psyke1
"31/11/2011" --- Psyke13
Salu2 !
Ook, ya están bien, recordemos que aún estoy engrasando motores, que llevo tiempo sin programar, ando oxidado.
Venga, ¿a qué esperáis? ¡otro reto ya!
DoEvents! :P