Foro de elhacker.net

Programación => Programación Visual Basic => Mensaje iniciado por: raul338 en 28 Agosto 2011, 20:09 pm


Título: [RETO] IsDate
Publicado por: raul338 en 28 Agosto 2011, 20:09 pm
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

Código
  1. Function IsDate_Nombre(str As String) As Boolean
  2. Function IsDate_Nombre_vX(str As String) As Boolean
  3. 'Ejemplos
  4. Function IsDate_r338(str As String) As Boolean
  5. Function IsDate_r338_v2(str As String) As Boolean
  6. Function IsDate_7913(str As String) As Boolean
  7.  

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
Código
  1. 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
  2.  
  3. Function GetDateSeparator() As String
  4.     Dim strLen As Long
  5.     GetDateSeparator = String$(5, 0)
  6.     strLen = GetProfileString("Intl", "sDate", "", GetDateSeparator, Len(GetDateSeparator))
  7.     GetDateSeparator = Left$(GetDateSeparator, strLen)
  8. End Function
  9.  
  10. Function GetDateFormat() As String
  11.     Dim strLen As Long
  12.     GetDateFormat = String$(11, 0)
  13.     strLen = GetProfileString("Intl", "sShortDate", "", GetDateFormat, Len(GetDateFormat))
  14.     GetDateFormat = Left$(GetDateFormat, strLen)
  15. End Function
  16.  

Por el momento con estas fechas debe devolver true
Código:
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
Código:
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!

Título: Re: [RETO] IsDate
Publicado por: BlackZeroX en 28 Agosto 2011, 21:37 pm
.
Espacios en blanco?... = valen o se descartan...

Dulces Lunas!¡.

Título: Re: [RETO] IsDate
Publicado por: ignorantev1.1 en 28 Agosto 2011, 21:44 pm
Código
  1. Function heyIgnorante_isDate(ByVal sDate As String) As Boolean
  2.     Dim elemts() As String
  3.     Dim D As Integer, M As Integer, A As Integer
  4.  
  5.     sDate = Trim$(sDate)
  6.     elemnts = Split(sDate, "/")
  7.  
  8.     If UBound(elemnts) <> 2 Then Exit Function
  9.  
  10.     D = Val(elemnts(0)): M = Val(elemnts(1)): A = Val(elemnts(2))
  11.  
  12.     If D > 31 Or D < 1 Or M > 12 Or M < 1 Or A > 9999 Or A < 0 Then Exit Function
  13.  
  14.     If ((M < 8 And M Mod 2 = 0) Or (M > 7 And M Mod 2 = 1)) And D > 30 Then Exit Function
  15.  
  16.     If (A Mod 4 <> 0 And M = 2 And D > 28) Or _
  17.     (A Mod 100 = 0 And A Mod 400 <> 0) Then
  18.          Exit Function
  19.     End If
  20.     heyIgnorante_isDate = True
  21. End Function
  22.  

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▓▓▒▒░░

Título: Re: [RETO] IsDate
Publicado por: x64core 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 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

Título: Re: [RETO] IsDate
Publicado por: raul338 en 28 Agosto 2011, 22:18 pm
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 "/"

Título: Re: [RETO] IsDate
Publicado por: x64core en 28 Agosto 2011, 22:26 pm
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'

Título: Re: [RETO] IsDate
Publicado por: raul338 en 28 Agosto 2011, 22:32 pm
@Raul100: No era la intencion :xD

Ahi puse un codigo para obtener el formato y el separador, por si alguien quiere experimentar a  futuro

Título: Re: [RETO] IsDate
Publicado por: 79137913 en 28 Agosto 2011, 22:44 pm
HOLA!!!

Me puse a ver que podia hacer y salio esto:
Uso GoTos no me reten :P
/Ofuscando codigo :P/

VERSION 2.0
Código
  1. Private Function IsDate_7913_v2(str As String) As Boolean
  2. On Error GoTo Fin
  3. Dim Partes(2) As Long
  4. Dim Primer() As String
  5.     Primer = Split(str, "/")
  6.     If UBound(Primer) <> 2 Then GoTo Fin
  7.     Partes(0) = Primer(0): Partes(1) = Primer(1): Partes(2) = Primer(2)
  8.     If Partes(2) > 9999 Then GoTo Fin
  9.     Select Case Partes(1) 'verificamos el mes
  10.         Case 0
  11.             GoTo Fin
  12.         Case 1, 3, 5, 7, 8, 10, 12 'si es de 31 dias
  13.             Select Case Partes(0) 'verificamos el dia
  14.                 Case Is > 31
  15.                     GoTo Fin 'si es mayor que 31 es false
  16.                 Case Is < 1
  17.                     GoTo Fin 'si es menor que 1 es false
  18.                 Case Else
  19.                     IsDate_7913_v2 = True : GoTo Fin 'sino true
  20.             End Select
  21.         Case 4, 6, 9, 11 'si es de 30 dias
  22.             Select Case Partes(0)
  23.                 Case Is > 30
  24.                     GoTo Fin
  25.                 Case Is < 1
  26.                     GoTo Fin
  27.                 Case Else
  28.                     IsDate_7913_v2 = True : GoTo Fin 
  29.             End Select
  30.         Case 2 'si es febrero
  31.             Select Case Partes(0)
  32.                 Case Is > 29 'si es mayor que 29
  33.                     GoTo Fin
  34.                 Case Is < 1 ' si es menor a 1
  35.                     GoTo Fin
  36.                 Case 29
  37.                     If Partes(2) Mod 4 = 0 Then
  38.                         If Partes(2) Mod 100 = 0 Then
  39.                             If Partes(2) Mod 400 = 0 Then IsDate_7913_v2 = True 'si es biciesto multiplo de 100 y 400
  40.                         Else
  41.                             IsDate_7913_v2 = True : GoTo Fin  'si es biciesto
  42.                         End If
  43.                     End If
  44.                 Case Else
  45.                     IsDate_7913_v2 = True : GoTo Fin 
  46.             End Select
  47.         End Select
  48. Fin:
  49. End Function
  50.  

GRACIAS POR LEER!!!

Título: Re: [RETO] IsDate
Publicado por: $Edu$ en 28 Agosto 2011, 22:50 pm
Aca va el mio a ver que tal, no se si sera lento, pero lo intente hacer con mejor funcionalidad.

Código
  1. Option Explicit
  2.  
  3. Private Sub Form_Load()
  4. Debug.Print "------CORRECTAS-------"
  5. Debug.Print isDate_edu("31/07/2000")
  6. Debug.Print isDate_edu("30/07/2000")
  7. Debug.Print isDate_edu("01/02/2000")
  8. Debug.Print isDate_edu("25/05/2002")
  9. Debug.Print isDate_edu("15/07/2000")
  10. Debug.Print isDate_edu("28/02/2001")
  11. Debug.Print isDate_edu("31/05/2001")
  12. Debug.Print isDate_edu("30/12/2011")
  13. Debug.Print isDate_edu("29/02/2004")
  14.  
  15. Debug.Print "------FALSAS----------"
  16. Debug.Print isDate_edu("01/00/2011")
  17. Debug.Print isDate_edu("31/04/2001")
  18. Debug.Print isDate_edu("00/12/2011")
  19. Debug.Print isDate_edu("00/00/2011")
  20. Debug.Print isDate_edu("01/13/2011")
  21. Debug.Print isDate_edu("30/02/2001")
  22. Debug.Print isDate_edu("29/02/2003")
  23.  
  24. End Sub
  25.  
  26. Function isDate_edu(str As String) As Boolean
  27.  
  28.     Dim dato() As String
  29.     Dim anno, mes, dia As String
  30.  
  31. str = Trim$(str)
  32.  
  33. dato = Split(str, "/")
  34.  
  35. If UBound(dato) <> 2 Then Exit Function
  36.  
  37. dia = Val(dato(0))
  38. mes = Val(dato(1))
  39. anno = Val(dato(2))
  40.  
  41. If anno < 1 Or mes < 1 Or dia < 1 Then Exit Function
  42. If mes > 12 Or dia > 31 Then Exit Function
  43.  
  44. If (Not mes And 1) And (mes <> 8) And (dia > 30) Then Exit Function
  45.  
  46. 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
  47.  
  48. isDate_edu = True
  49. End Function
  50.  

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

Título: Re: [RETO] IsDate
Publicado por: BlackZeroX en 28 Agosto 2011, 23:27 pm
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!¡.

Título: Re: [RETO] IsDate
Publicado por: BlackZeroX en 29 Agosto 2011, 00:24 am
.
Aquí les dejo mi codigo... esta bastante legible...

Código
  1.  
  2. Option Explicit
  3.  
  4. Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal pDst As Long, ByVal pSrc As Long, ByVal ByteLen As Long)
  5.  
  6. '   //  Formato aceptado   DD/MM/YYYY, D/M/YYYY, D/MM/YYYY, DD/M/YYYY, D/M/Y, etc...
  7. Public Function isDate_BlackZX(ByRef sStr As String) As Boolean
  8. Dim lChar           As Long
  9. Dim lVal            As Long
  10. Dim lConvert(3)     As Long
  11.  
  12. Dim lDim            As Long
  13. Dim lMult           As Long
  14. Dim pStr            As Long
  15. Dim pChar           As Long
  16.  
  17.     pStr = LenB(sStr)
  18.     If (pStr < &H5) Then Exit Function
  19.  
  20.     pStr = StrPtr(sStr) + (pStr - &H4)
  21.     pChar = VarPtr(lChar)
  22.  
  23.     lDim = &H2
  24.     lMult = &H1
  25.     lConvert(lDim) = &H0
  26.  
  27.     Do Until StrPtr(sStr) > pStr
  28.         RtlMoveMemory pChar, pStr, &H4
  29.         lVal = (lChar And &HFF0000)
  30.         If (lVal = &H2F0000) Then
  31.             lDim = (lDim - &H1)
  32.             If ((lDim And &H80000000) = &H80000000) Then Exit Function
  33.             lMult = &H1
  34.         Else
  35.             If ((lVal > &H390000) Or (lVal < &H300000)) Then Exit Function
  36.             lConvert(lDim) = lConvert(lDim) + (((lVal / &H10000) - &H30) * lMult)
  37.             lMult = (lMult * &HA)
  38.         End If
  39.         lVal = (lChar And &HFF)
  40.         If (lVal = &H2F) Then
  41.             lDim = (lDim - &H1)
  42.             If ((lDim And &H80000000) = &H80000000) Then Exit Function
  43.             lMult = &H1
  44.         Else
  45.             If ((lVal > &H39) Or (lVal < &H30)) Then Exit Function
  46.             lConvert(lDim) = lConvert(lDim) + ((lVal - &H30) * lMult)
  47.             lMult = (lMult * &HA)
  48.         End If
  49.         pStr = (pStr - &H4)
  50.     Loop
  51.  
  52.     If ((lConvert(&H2) > &H270F) Or _
  53.         ((lConvert(&H2) And &H80000000) = &H80000000)) Or _
  54.     Not (lDim = &H0) Then Exit Function
  55.  
  56.     Select Case lConvert(&H1)
  57.         Case &H1, &H3, &H5, &H7, &H8, &HA, &HC
  58.             If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H20)) Then isDate_BlackZX = True
  59.         Case Is > &HC, Is <= &H0
  60.             Exit Function
  61.         Case Else
  62.             If (lConvert(&H1) = &H2) Then
  63.                 If ((lConvert(&H2) Mod &H4) = &H0) Then
  64.                     If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1E)) Then isDate_BlackZX = True
  65.                 ElseIf ((lConvert(&H2) Mod 400) = &H0) Then
  66.                     If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1E)) Then isDate_BlackZX = True
  67.                 ElseIf ((lConvert(&H2) Mod 100) = &H0) Then
  68.                     If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1E)) Then isDate_BlackZX = True
  69.                 Else
  70.                     If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1D)) Then isDate_BlackZX = True
  71.                 End If
  72.             Else
  73.                 If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1F)) Then isDate_BlackZX = True
  74.             End If
  75.     End Select
  76.  
  77. End Function
  78.  
  79.  

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.

Código
  1.  
  2. Public Function isDate_BlackZX(ByRef sStr As String) As Boolean
  3. Dim lChar           As Long
  4. Dim lVal            As Long
  5. Dim lConvert(3)     As Long
  6.  
  7. Dim lDim            As Long
  8. Dim lMult           As Long
  9. Dim pStr            As Long
  10. Dim pChar           As Long
  11.  
  12.     pStr = LenB(sStr)
  13.     If (pStr < &H5) Then Exit Function
  14.  
  15.     pStr = StrPtr(sStr) + (pStr - &H2)
  16.     pChar = VarPtr(lChar)
  17.  
  18.     lDim = &H2
  19.     lMult = &H1
  20.     lConvert(lDim) = &H0
  21.  
  22.     Do Until StrPtr(sStr) > pStr
  23.         RtlMoveMemory pChar, pStr, &H2  '   //  Dos bytes = char...
  24.         lVal = (lChar And &HFF)
  25.         If (lVal = &H2F) Then
  26.             lDim = (lDim - &H1)
  27.             If ((lDim And &H80000000) = &H80000000) Then Exit Function
  28.             lMult = &H1
  29.         Else
  30.             If ((lVal > &H39) Or (lVal < &H30)) Then Exit Function
  31.             lConvert(lDim) = lConvert(lDim) + ((lVal - &H30) * lMult)
  32.             lMult = (lMult * &HA)
  33.         End If
  34.         pStr = (pStr - &H2)
  35.     Loop
  36.  
  37.     If ((lConvert(&H2) > &H270F) Or _
  38.         ((lConvert(&H2) And &H80000000) = &H80000000)) Or _
  39.     Not (lDim = &H0) Then Exit Function
  40.  
  41.     Select Case lConvert(&H1)
  42.         Case &H1, &H3, &H5, &H7, &H8, &HA, &HC
  43.             If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H20)) Then isDate_BlackZX = True
  44.         Case Is > &HC, Is <= &H0
  45.             Exit Function
  46.         Case Else
  47.             If (lConvert(&H1) = &H2) Then
  48.                 If ((lConvert(&H2) Mod &H4) = &H0) Then
  49.                     If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1E)) Then isDate_BlackZX = True
  50.                 ElseIf ((lConvert(&H2) Mod 400) = &H0) Then
  51.                     If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1E)) Then isDate_BlackZX = True
  52.                 ElseIf ((lConvert(&H2) Mod 100) = &H0) Then
  53.                     If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1E)) Then isDate_BlackZX = True
  54.                 Else
  55.                     If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1D)) Then isDate_BlackZX = True
  56.                 End If
  57.             Else
  58.                 If ((lConvert(&H0) > &H0) And (lConvert(&H0) < &H1F)) Then isDate_BlackZX = True
  59.             End If
  60.     End Select
  61.  
  62. End Function
  63.  
  64.  

Temibles Lunas!¡.

Título: Re: [RETO] IsDate
Publicado por: Sanlegas en 29 Agosto 2011, 02:38 am
Código
  1. Public Function IsDate_T(ByRef Expresion As String) As Boolean
  2. On Error GoTo err
  3. Dim A           As Integer
  4. Dim B           As Integer
  5. Dim C           As Integer
  6. Dim P1          As Integer
  7. Dim P2          As Integer
  8. Dim F           As Boolean
  9.  
  10.             P1 = InStr(1, Expresion, "/")
  11.             If (Not CBool(P1)) Then Exit Function
  12.             P2 = InStr(P1 + 1, Expresion, "/")
  13.             If (Not CBool(P2)) Then Exit Function
  14.  
  15.             A = Mid(Expresion, 1, P1)
  16.             B = Mid(Expresion, P1 + 1, P2 - P1)
  17.             C = Mid(Expresion, P2 + 1, Len(Expresion))
  18.  
  19.             F = (((Not CBool((C Mod 4))) And CBool(C Mod 100)) Or (Not CBool(C Mod 400)))
  20.             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)))
  21. err:
  22. 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

Título: Re: [RETO] IsDate
Publicado por: 79137913 en 30 Agosto 2011, 19:21 pm
HOLA!!!

Alguien puede testear que es mas rapido (GoTo Fin o Exit Function)

GRACIAS POR LEER!!!

Título: Re: [RETO] IsDate
Publicado por: BlackZeroX en 30 Agosto 2011, 19:28 pm
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!¡.

Título: Re: [RETO] IsDate
Publicado por: 79137913 en 30 Agosto 2011, 19:47 pm
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:
Citar
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!!!


Título: Re: [RETO] IsDate
Publicado por: BlackZeroX en 1 Septiembre 2011, 07:46 am
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!¡.

Título: Re: [RETO] IsDate
Publicado por: raul338 en 3 Septiembre 2011, 04:44 am
Resultados parciales
Código:
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

Título: Re: [RETO] IsDate
Publicado por: ignorantev1.1 en 3 Septiembre 2011, 05:21 am
@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:

Título: Re: [RETO] IsDate
Publicado por: raul338 en 3 Septiembre 2011, 05:32 am
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
Código
  1. Public Function IsDate_r338(ByVal str As String) As Boolean
  2. If str = vbNullString Then Exit Function
  3.     Dim strp As Long
  4.     strp = StrPtr(str)
  5. If lstrlenW(strp) <> 10 Then Exit Function
  6.  
  7.     Dim j As Long, k As Long, dia As Long, mes As Long, año As Long, jp As Long
  8.  
  9.     jp = VarPtr(j)
  10.     For k = 0 To 18 Step 2
  11.         Call RtlMoveMemory(jp, strp + k, 1)
  12.         Select Case k / 2
  13.             Case 0
  14.                 If j < 48 And j > 51 Then Exit Function
  15.                 dia = (j - 48) * 10
  16.             Case 1
  17.                 If j < 48 And j > 57 Then Exit Function
  18.                 dia = dia + (j - 48)
  19.                 If dia = 0 Or dia > 31 Then Exit Function
  20.             Case 2, 5: If j <> 47 Then Exit Function
  21.             Case 3
  22.                 If j <> 48 And j <> 49 Then Exit Function
  23.                 mes = (j - 48) * 10
  24.             Case 4
  25.                 If j < 48 And j > 57 Then Exit Function
  26.                 mes = mes + (j - 48)
  27.                 If mes = 0 Or mes > 12 Then Exit Function
  28.                 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
  29.                 If mes = 2 And dia > 29 Then Exit Function
  30.             Case 6
  31.                 If j < 48 And j > 57 Then Exit Function
  32.                 año = (j - 48) * 1000
  33.             Case 7
  34.                 If j < 48 And j > 57 Then Exit Function
  35.                 año = año + (j - 48) * 100
  36.             Case 8
  37.                 If j < 48 And j > 57 Then Exit Function
  38.                 año = año + (j - 48) * 10
  39.             Case 9
  40.                 If j < 48 And j > 57 Then Exit Function
  41.                 año = año + (j - 48)
  42.  
  43.                 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
  44.         End Select
  45.     Next
  46.     IsDate_r338 = True
  47. End Function
  48.  

Título: Re: [RETO] IsDate
Publicado por: BlackZeroX en 3 Septiembre 2011, 08:36 am
.
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.

Código
  1.  
  2.     sTests = Split("31/07/2000|30/07/2000|01/02/2000|25/05/2002|15/07/2000|28/02/2001|" & _
  3.                     "31/05/2001|30/12/2011|29/02/2004|01/01/2001|31/12/9999|29/02/2012", "|")
  4.     sFalses = Split("01/00/2011|31/04/2001|00/12/2011|00/00/2011|01/13/2011|30/02/2001|y0/45/hola|" & _
  5.                     "29/02/2003|99/99/9999|32/12/9999|29/13/2000|LALA|00/00/0000|31/09/2011|y0/45/hola|", "|")
  6.  
  7.     Open App.Path & "\log.txt" For Output As #1
  8.     Call txt(" === Reto IsDate ====")
  9.     Call txt(Date$ & " " & Time$)
  10.  
  11.     Call txt("Testeo de calidad", True)
  12.     For i = 0 To UBound(sTests)
  13.         If modFunctions.heyIgnorante_isDate(sTests(i)) = False Then Call txt(sTests(i) & vbTab & "Ignorante v1.1 FAILS")
  14.         If modFunctions.IsDate_7913_v2(sTests(i)) = False Then Call txt(sTests(i) & vbTab & "79137913 FAILS")
  15.         If modFunctions.isDate_BlackZX(sTests(i)) = False Then Call txt(sTests(i) & vbTab & "BlackZeroX FAILS")
  16.         If modFunctions.isDate_edu(sTests(i)) = False Then Call txt(sTests(i) & vbTab & "$Edu$ FAILS")
  17.         If modFunctions.IsDate_T(sTests(i)) = False Then Call txt(sTests(i) & vbTab & "Tenient101 FAILS")
  18.         If modFunctions.IsDate_r338(sTests(i)) = False Then Call txt(sTests(i) & vbTab & "Raul338 FAILS")
  19.     Next
  20.  
  21.     Call txt("Testeo de falsos", True)
  22.     For i = 0 To UBound(sFalses)
  23.         If modFunctions.heyIgnorante_isDate(sFalses(i)) Then Call txt(sFalses(i) & vbTab & "Ignorante v1.1 FAILS")
  24.         If modFunctions.IsDate_7913_v2(sFalses(i)) Then Call txt(sFalses(i) & vbTab & "79137913 FAILS")
  25.         If modFunctions.isDate_BlackZX(sFalses(i)) Then Call txt(sFalses(i) & vbTab & "BlackZeroX FAILS")
  26.         If modFunctions.isDate_edu(sFalses(i)) Then Call txt(sFalses(i) & vbTab & "$Edu$ FAILS")
  27.         If modFunctions.IsDate_T(sFalses(i)) Then Call txt(sTests(i) & vbTab & "Tenient101 FAILS")
  28.         If modFunctions.IsDate_r338(sFalses(i)) Then Call txt(sFalses(i) & vbTab & "Raul338 FAILS")
  29.     Next
  30.  
  31.  

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...

Código:

 === 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!¡.

Título: Re: [RETO] IsDate
Publicado por: $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..

Título: Re: [RETO] IsDate
Publicado por: raul338 en 4 Septiembre 2011, 00:41 am
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

Código:
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$

Título: Re: [RETO] IsDate
Publicado por: $Edu$ en 4 Septiembre 2011, 01:20 am
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

Título: Re: [RETO] IsDate
Publicado por: BlackZeroX en 4 Septiembre 2011, 06:58 am
@$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!¡.

Título: Re: [RETO] IsDate
Publicado por: Psyke1 en 12 Septiembre 2011, 03:47 am
Un poco tarde... :silbar: aquí está la mía:

Código
  1. Option Explicit
  2. Private Const sMonths$ = "01 02 03 04 05 06 07 08 09 10 11 12"
  3. Private Const s31Months$ = " 1 3 5 7 8 01 03 05 08 10 12 "
  4. Private Const sDays$ = sMonths & " 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31"
  5.  
  6. '// Acepta formatos: DD/MM/YYYY, D/MM/YYYY y DD/M/YYYY.
  7. Public Static Function IsDate_Psyke1(ByRef sDate$) As Boolean
  8. Dim sDay$, sMonth$, sYear$, lp1&, lp2&
  9.     If LenB(sDate) < &H16 And LenB(sDate) > &HE Then
  10.         lp1 = InStrB(1, sDate, "/", vbBinaryCompare)
  11.         If lp1 = 0 Then Exit Function
  12.  
  13.         sDay = LeftB$(sDate, lp1 - 1)
  14.         If InStrB(1, sDays, sDay, vbBinaryCompare) Then
  15.             lp2 = InStrB(lp1 + 1, sDate, "/", vbBinaryCompare)
  16.             If lp2 = 0 Then Exit Function
  17.  
  18.             sMonth = MidB$(sDate, lp1 + 2, lp2 - lp1 - 2)
  19.             If InStrB(1, sMonths, sMonth, vbBinaryCompare) Then
  20.                 sYear = RightB$(sDate, 8)
  21.                 If Not (sYear Like "####") Then Exit Function
  22.  
  23.                 If InStrB(1, "02", sMonth, vbBinaryCompare) Then
  24.                     If InStrB(1, "29", sDay, vbBinaryCompare) Then
  25.                         IsDate_Psyke1 = ((sYear Mod &H4 = 0) And (sYear Mod &H64) Or (sYear Mod &H190 = 0))
  26.                         Exit Function
  27.                     ElseIf InStrB(1, "30", sDay, vbBinaryCompare) Then
  28.                         Exit Function
  29.                     End If
  30.                 ElseIf InStrB(1, "31", sDay, vbBinaryCompare) Then
  31.                     IsDate_Psyke1 = InstrB(1, s31Months, sMonth, vbBinaryCompare)
  32.                     Exit Function
  33.                 End If
  34.  
  35.                 IsDate_Psyke1 = True
  36.             End If
  37.         End If
  38.     End If
  39. End Function

Tests:
Código
  1. Private Sub Form_Load()
  2. Const sLine$ = "----------------------------------------"
  3.  
  4.     Debug.Print sLine; "TRUE"; sLine
  5.     Debug.Print IsDate_Psyke1("31/07/2000")
  6.     Debug.Print IsDate_Psyke1("29/02/2004")
  7.     Debug.Print IsDate_Psyke1("15/07/2000")
  8.     Debug.Print IsDate_Psyke1("30/12/2011")
  9.  
  10.     Debug.Print sLine; "FALSE"; sLine
  11.     Debug.Print IsDate_Psyke1("29/02/2003")
  12.     Debug.Print IsDate_Psyke1("01/13/2011")
  13.     Debug.Print IsDate_Psyke1("30/02/2001")
  14.     Debug.Print IsDate_Psyke1("00/12/2011")
  15.     Debug.Print IsDate_Psyke1("as/12/2000")
  16.     Debug.Print IsDate_Psyke1("13/as/2000")
  17.     Debug.Print IsDate_Psyke1("-31/44/2070")
  18.     Debug.Print IsDate_Psyke1("31/12/20s0")
  19. End Sub

Resultado:
Código:
----------------------------------------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:
Código:
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 :
Código
  1.     Debug.Print IsDate_r338("31/12/20f0")         ' = True.. xD
  2.     Debug.Print heyIgnorante_isDate("31/12/25y0") ' = True.. xD
  3.  

Por tanto las funciones que dan resultados correctos:
Código:
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

Título: Re: [RETO] IsDate
Publicado por: Sanlegas en 13 Septiembre 2011, 03:58 am
Yo igual repare la mia...  :rolleyes:

Código
  1. Public Function IsDate_T(ByRef Expresion As String) As Boolean
  2. On Error GoTo err
  3. Dim A           As Integer
  4. Dim B           As Integer
  5. Dim C           As Integer
  6. Dim P1          As Integer
  7. Dim P2          As Integer
  8. Dim F           As Boolean
  9. Dim F2          As Boolean
  10.  
  11.             P1 = InStr(1, Expresion, "/")
  12.             If (Not CBool(P1)) Then Exit Function
  13.             P2 = InStr(P1 + 1, Expresion, "/")
  14.             If (Not CBool(P2)) Then Exit Function
  15.  
  16.             A = Mid(Expresion, 1, P1 - 1)
  17.             B = Mid(Expresion, P1 + 1, P2 - P1 - 1)
  18.             C = Mid(Expresion, P2 + 1, Len(Expresion))
  19.  
  20.             If (A And &H20) Then Exit Function
  21.             If (C And &H8000) Then Exit Function
  22.  
  23.             If (B And &H8) Then
  24.                 P1 = (B - &H8)
  25.                 If (P1 And &H4) Then
  26.                     P1 = (P1 - &H4)
  27.                     If (P1 And &H1) Then
  28.                         Exit Function
  29.                     Else
  30.                         F2 = True
  31.                     End If
  32.                 Else
  33.                     If (P1 And &H2) Then
  34.                         P1 = (P1 - &H2)
  35.                         If (P1 Or &H0) = &H0 Then F2 = True
  36.                     Else
  37.                         If (P1 Or &H0) = &H0 Then F2 = True
  38.                     End If
  39.                 End If
  40.             Else
  41.                 If (B And &H4) Then
  42.                     P1 = (B - &H4)
  43.                     If (P1 And &H2) Then
  44.                         P1 = (P1 - &H2)
  45.                         If (P1 And &H1) Then F2 = True
  46.                     Else
  47.                         If (P1 And &H1) Then F2 = True
  48.                     End If
  49.                 Else
  50.                     If (B And &H2) Then
  51.                         P1 = (B - &H2)
  52.                         If (P1 And &H1) Then F2 = True
  53.                     Else
  54.                         If (B And &H1) Then F2 = True
  55.                     End If
  56.                 End If
  57.             End If
  58.  
  59.             If (C And &H2000) Then
  60.                 P1 = (P1 - &H2000)
  61.                 If (P1 And &H400) Then
  62.                     P1 = (P1 - &H400)
  63.                     If (P1 And &H200) Then
  64.                         P1 = (P1 - &H200)
  65.                         If (P1 And &H100) Then
  66.                             P1 = (P1 - &H100)
  67.                             If (P1 And &H10) Then Exit Function
  68.                         End If
  69.                     End If
  70.                 End If
  71.             End If
  72.  
  73.             F = (((Not CBool((C Mod &H4))) And CBool(C Mod &H64)) Or (Not CBool(C Mod &H190)))
  74.  
  75.             IsDate_T = True
  76.  
  77.             If (A And &H10) Then
  78.                 P1 = (A - &H10)
  79.                 If (P1 And &H10) Then
  80.                     If ((Not F2) And (Not F)) Then IsDate_T = False
  81.                 Else
  82.                     If (P1 And &H8) Then
  83.                         P1 = (P1 - &H8)
  84.                         If (P1 And &H4) Then
  85.                             P1 = (P1 - &H4)
  86.                             If P1 Then
  87.                                 If (B = &H2) Then
  88.                                     If (Not F) Then
  89.                                         IsDate_T = False
  90.                                     Else
  91.                                         If (Not (P1 = &H1)) Then IsDate_T = False
  92.                                     End If
  93.                                 Else
  94.                                     If (P1 And &H2) Then
  95.                                         P1 = (P1 - &H2)
  96.                                         If (P1 And &H1) Then
  97.                                             IsDate_T = F2
  98.                                         Else
  99.                                             If (P1 Or &H0) = &H0 Then
  100.                                                 IsDate_T = F2
  101.                                             Else
  102.  
  103.                                                 IsDate_T = Not F2
  104.                                             End If
  105.                                         End If
  106.                                     End If
  107.                                 End If
  108.                             End If
  109.                         End If
  110.                     End If
  111.                 End If
  112.             End If
  113. err:
  114. End Function

@Psyke1: "31/02/2011" = True  :o

Salu2!

Título: Re: [RETO] IsDate
Publicado por: Psyke1 en 13 Septiembre 2011, 07:34 am
Ook, gracias, se me escapó una cosa, sólo fue cambiar el orden de un If... :silbar:

DoEvents! :P

Título: Re: [RETO] IsDate
Publicado por: Psyke1 en 13 Septiembre 2011, 12:55 pm
Mi nueva minifunción (no es para ir rápido, pero creo que es la manera más corta de hacerlo):
Código
  1. Option Explicit
  2.  
  3. '// Acepta formatos: DD/MM/YYYY, D/MM/YYYY y DD/M/YYYY.
  4. Public Static Function IsDate_Psyke12(ByRef sDate$) As Boolean
  5. On Error Resume Next
  6.     IsDate_Psyke12 = InStrB(1, CDate(sDate), sDate, vbBinaryCompare)
  7. End Function

La más rápida que se me ocurre:
Código
  1. Option Explicit
  2.  
  3. '// Acepta formatos: DD/MM/YYYY, D/MM/YYYY y DD/M/YYYY.
  4. Public Static Function IsDate_Psyke13(ByRef sDate$) As Boolean
  5. Dim lDay&, lMonth&, lYear&, lp1&
  6. On Error GoTo DateError
  7.  
  8.     lp1 = InStrB(1, sDate, "/", vbBinaryCompare)
  9.     If lp1 = 0 Then Exit Function
  10.  
  11.     lYear = RightB$(sDate, 8)
  12.  
  13.     lDay = LeftB$(sDate, lp1 - 1)
  14.     If lDay > 31 Then Exit Function
  15.     If lDay < 1 Then Exit Function
  16.  
  17.     lMonth = MidB$(sDate, lp1 + 2, InStrB(lp1 + 1, sDate, "/", vbBinaryCompare) - lp1 - 2)
  18.     Select Case lMonth
  19.         Case Is > 12, Is < 1
  20.             Exit Function
  21.         Case 2
  22.             If lDay = 29 Then
  23.                 IsDate_Psyke13 = ((lYear Mod &H4 = 0) And (lYear Mod &H64) Or (lYear Mod &H190 = 0))
  24.                 Exit Function
  25.             ElseIf lDay > 29 Then
  26.                 Exit Function
  27.             End If
  28.         Case Else
  29.             If lDay = 31 Then
  30.                 Select Case lMonth
  31.                     Case 1,3,5,7,8,10,12
  32.                         IsDate_Psyke13 = True 
  33.                 End Select
  34.                 Exit Function
  35.             End If
  36.     End Select
  37.  
  38.     IsDate_Psyke13 = True
  39.     Exit Function
  40. DateError:
  41. End Function

@Tenient101
Quizás un poco larga, pero me gustó la idea, por cierto:
Código:
Testeo de calidad
==============================
30/07/2000	Tenient101 FAILS
30/12/2011	Tenient101 FAILS
31/12/9999	$Edu$ FAILS

Resultados:
Código:
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

Título: Re: [RETO] IsDate
Publicado por: Sanlegas en 13 Septiembre 2011, 18:06 pm
Ya esta corregida  :rolleyes:, pero dos funciones tuyas siguen dando fail

Citar
"31/11/2011" --- Psyke1
"31/11/2011" --- Psyke13

Salu2 !

Título: Re: [RETO] IsDate
Publicado por: Psyke1 en 13 Septiembre 2011, 18:38 pm
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


Powered by SMF 1.1.21 | SMF © 2006-2008, Simple Machines