[RETO] IsDate

[BlackZeroX]

.
Aquí les dejo mi codigo... esta bastante legible...

Código (vb) [Seleccionar] Expandir



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.

Código (vb) [Seleccionar] Expandir



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

[Sanlegas]

Código (vb) [Seleccionar] Expandir

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 !  

[79137913]

HOLA!!!

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

GRACIAS POR LEER!!!

[BlackZeroX]

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

[79137913]

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

[BlackZeroX]

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

[raul338]

Resultados parciales

Código [Seleccionar] Expandir


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

[ignorantev1.1]

@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"? 

[raul338]

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

Código (vb) [Seleccionar] Expandir


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


[BlackZeroX]

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

Código (vb) [Seleccionar] Expandir



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

Código [Seleccionar] Expandir



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