Tema destacado: Grupo de  acebook de elhacker.net
 Autor
|
Tema: [RETO] IsDate (Leído 2,677 veces)
|
|
raul338
|
Bueno, para seguir con esto de los retos y hacer que haya mas actividad competitiva y cooperativa (y no tantas dudas  ) 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 utilizada en otros retos (Ver ejemplo de como se utiliza)
- 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
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   y repito No te inhibes, mientras mas concursantes participen, mejor!
|
|
|
|
« Última modificación: 28 Agosto 2011, 22:31 por raul338 »
|
En línea
|
|
|
|
BlackZeroX (Astaroth)
Wiki
 Desconectado
Mensajes: 2.832
I'Love...!¡.
|
.
Espacios en blanco?... = valen o se descartan...
Dulces Lunas!¡.
|
|
|
|
|
En línea
|
|
|
|
ignorantev1.1
Desconectado
Mensajes: 424
/\ Así acabo cuando quiero programar...
|
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▓▓▒▒░░
|
|
|
|
« Última modificación: 3 Septiembre 2011, 05:22 por ignorantev1.1 »
|
En línea
|
|
|
|
RHL
Desconectado
Mensajes: 968
mental
|
bueno yo creo que la funcion debe de tener las misma caracteristicas de la funcion isdate sino no se llamara del todo reemplazo de la funcion y pienso que raul338 dio informacion adicional acerca de la funcion isdate y no creo que no se referia a restricciones o adiciones a nuestra funcion |
|
|
|
|
En línea
|
|
|
|
|
raul338
|
Espacios en blanco?... = valen o se descartan...
Sin espacios.. solo numeros y "/" bueno yo creo que la funcion debe de tener las misma caracteristicas de la funcion isdate sino no se llamara del todo reemplazo de la funcion Pero no puse que sea "reemplazo" Ahi agrego un edit sobre el "/"
|
|
|
|
|
En línea
|
|
|
|
RHL
Desconectado
Mensajes: 968
mental
|
Sin espacios.. solo numeros y "/" Pero no puse que sea "reemplazo" "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'
|
|
|
|
|
En línea
|
|
|
|
|
raul338
|
@Raul100: No era la intencion Ahi puse un codigo para obtener el formato y el separador, por si alguien quiere experimentar a futuro |
|
|
|
|
En línea
|
|
|
|
79137913
Desconectado
Mensajes: 780
4 Esquinas
|
HOLA!!! Me puse a ver que podia hacer y salio esto: Uso GoTos no me reten / Ofuscando codigo / 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!!! |
|
|
|
« Última modificación: 1 Septiembre 2011, 15:22 por 79137913 »
|
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* Resumenes Cs.Economicas |
|
|
$Edu$
Desconectado
Mensajes: 1.416
|
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 |
|
|
|
« Última modificación: 28 Agosto 2011, 22:52 por $Edu$ »
|
En línea
|
"Todos somos muy ignorantes. Lo que ocurre es que no todos ignoramos las mismas cosas." - Albert Einstein.
|
|
|
BlackZeroX (Astaroth)
Wiki
Desconectado
Mensajes: 2.832
I'Love...!¡.
|
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!¡.
|
|
|
|
« Última modificación: 29 Agosto 2011, 00:44 por BlackZeroX▓▓▒▒░░ »
|
En línea
|
|
|
|
BlackZeroX (Astaroth)
Wiki
Desconectado
Mensajes: 2.832
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 por BlackZeroX▓▓▒▒░░ »
|
En línea
|
|
|
|
Tenient101
Desconectado
Mensajes: 127
|
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 por Tenient101 »
|
En línea
|
|
|
|
79137913
Desconectado
Mensajes: 780
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* Resumenes Cs.Economicas |
|
|
BlackZeroX (Astaroth)
Wiki
Desconectado
Mensajes: 2.832
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 por BlackZeroX▓▓▒▒░░ »
|
En línea
|
|
|
|
79137913
Desconectado
Mensajes: 780
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* Resumenes Cs.Economicas |
|
|
|
 |
