Autor
Podrias dejar tus Test aqui pegados (Codigos de prueba), a mi en esos strings no me marca errores (3.0 en adelante).
Edito:
Verison en C
http://foro.elhacker.net/programacion_cc/cisnumeric_vb6_a_c-t336564.0.html
Pongo la version 4.1
Fix para el numero Hexadecimal &H00000000000000000000000000000000000000000000000000000000000000000000000 y similares.
Código
String con las que se probo:
Código:
Option Explicit
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal pDst As Long, ByVal pSrc As Long, ByVal ByteLen As Long)
Private Declare Function WaitMessage Lib "user32" () As Long
Enum eTime
Horas = 3600
Minutos = 60
Segundos = 1
End Enum
Public Sub Wait(ByVal vToWait&, Optional ByVal ThisWait As eTime = Segundos, Optional ByVal UseAllProc As Boolean = False)
Dim vDateE As Date
vDateE = DateAdd("s", vToWait& * (ThisWait + 0), Time)
Do While vDateE > Time
Call WaitMessage
If Not UseAllProc Then DoEvents
Loop
End Sub
Private Sub Form_Click()
Dim laux0 As Long
Dim i As Long
Dim bRes As Boolean
Dim spli() As String
Dim ctmr As CTiming
Show
Call Wait(1, Segundos, False)
Set ctmr = New CTiming
' // Test Fiabilidad.
spli = Split("&H999999999999999999" & Chr(0) & "999999999999999999999999999|&H00000000000000000000" & Chr(0) & "000000000000000000000000000000000000" & _
"|5,6,.6 |,7.88| .56788|&H9999999999999999999999999999999999999999999999999|&H00000000000000000000000000000000000000000000000000000000000" & _
"|45,0,4,3|44,.0144,0|44.,0,0,0,0,0,0,0,1|1d-12|10.45e.10|1.112.45|1.224e+-10.12" & _
"||45.01anonymouse|usuarios elhacker 45.1| 45.01 " & Chr(0) & "anonymouse" & _
"|1..3|" & Chr(0) & Chr(0) & Chr(0) & "0.0" & _
"|&H221231321| &H2212313215646546546546516516512|9999999999999999999999999999999999999999999999999999| 0. 0|3" & Chr(10) & "0|3000" & Chr(10) & "0| &H1000000000| s &H1000000000" & _
"| +. &H1000000000| +. &H1000000000| +.a &H1000000000| +.a &H100000000v| +.a &H1000000 00v" & _
"|&H1000000 00v|&H1000000 00|+1.0e45|+e1. .2|+0e+11|.+0e+11|+1.0d45|+d1. .2|+0d+11|.+0d+11|" & _
"|+1. .2|0|+0.|+. 0|+|+ 0|" & Chr(10) & "-0|." & vbTab & " .+0|.0" & vbTab & vbNewLine & vbTab & vbNewLine & vbTab & vbNewLine & " .+0" & _
"|" & vbTab & vbNewLine & vbTab & vbNewLine & vbTab & vbNewLine & " +.0 " & _
"|" & vbTab & vbNewLine & vbTab & vbNewLine & vbTab & vbNewLine & " +00.0 " & _
"|" & vbTab & vbNewLine & vbTab & vbNewLine & vbTab & vbNewLine & " --.0 " & _
"|" & vbTab & Space(10) & vbNewLine & " +-+-.+.0|" & vbTab & " +.0", "|")
' // Test de Fiabilidad...
For i = 0 To UBound(spli)
bRes = IsNumeric(spli(i))
If Not (bRes = isNumeric_Black(spli(i))) Then
Debug.Print "Error: isNumeric_Black (""" & spli(i) & """)"
End If
If Not (bRes = Is_NumberT(spli(i))) Then
Debug.Print "Error: Is_NumberT (""" & spli(i) & """)"
End If
If Not (bRes = IsNumeric_TGa(spli(i))) Then
Debug.Print "Error: IsNumeric_TGa (""" & spli(i) & """)"
End If
If Not (bRes = IsNumeric_r338v3(spli(i))) Then
Debug.Print "Error: IsNumeric_r338v3(""" & spli(i) & """)"
End If
If Not (bRes = IsNumeric_LeandroA(spli(i))) Then
Debug.Print "Error: IsNumeric_LeandroA(""" & spli(i) & """)"
End If
If Not (bRes = IsNumeric_7913(spli(i))) Then
Debug.Print "Error: IsNumeric_7913(""" & spli(i) & """)"
End If
Next
Me.AutoRedraw = True
' // Test de tiempos entre usuarios junto con isNumeric().
ctmr.Reset
For laux0 = 1 To 1000
For i = 0 To UBound(spli)
IsNumeric spli(i)
Next
Next laux0
Me.Print "IsNumeric()", ctmr.sElapsed
Call Wait(1, Segundos, False)
ctmr.Reset
For laux0 = 1 To 1000
For i = 0 To UBound(spli)
Is_NumberT spli(i)
Next
Next laux0
Me.Print "Is_NumberT()", ctmr.sElapsed
Call Wait(1, Segundos, False)
ctmr.Reset
For laux0 = 1 To 1000
For i = 0 To UBound(spli)
isNumeric_Black spli(i)
Next
Next laux0
Me.Print "IsNumeric_Black()", ctmr.sElapsed
Call Wait(1, Segundos, False)
ctmr.Reset
For laux0 = 1 To 1000
For i = 0 To UBound(spli)
IsNumeric_TGa spli(i)
Next
Next laux0
Me.Print "IsNumeric_TGa()", ctmr.sElapsed
Call Wait(1, Segundos, False)
ctmr.Reset
For laux0 = 1 To 1000
For i = 0 To UBound(spli)
IsNumeric_7913 spli(i)
Next
Next laux0
Me.Print "IsNumeric_7913()", ctmr.sElapsed
Call Wait(1, Segundos, False)
ctmr.Reset
For laux0 = 1 To (1000 / 10) ' // Divio entre 10 por que es mas lenta...
For i = 0 To UBound(spli)
IsNumeric_r338v3 spli(i)
Next
Next laux0
Me.Print "IsNumeric_r338v3()", ctmr.sElapsed
Call Wait(1, Segundos, False)
Me.Print "Finalizado"
Set ctmr = Nothing
Show
SetFocus
End Sub
Public Function isNumeric_Black(ByRef sString As String) As Boolean
' // Version 5.0
Dim lPos As Long ' // For Next.
Dim lLn As Long ' // Longitud de sString.
Dim lData As Long ' // Xor, Switcher, Contador (QWord).
Dim lChar As Long ' // 2 Caracteres.
Dim pChar As Long ' // Puntero a lChar
Dim pString As Long ' // Puntero al parametro de funcion {sString}
Const PUNTO_DECIMAL As Long = &H10000
Const SIGNO_SRC As Long = &H20000
Const NUMBER_HEX As Long = &H40000
Const NUMBER_HEX_ZERO As Long = &H80000
Const NUMBER_HEX_FLAGS As Long = NUMBER_HEX Or NUMBER_HEX_ZERO
Const NUMBER_POW As Long = &H100000
Const NUMBER_POW_FINISH As Long = &H200000
Const NUMBER_POW_FLAGS As Long = NUMBER_POW Or NUMBER_POW_FINISH
Const NUMBER_OF_OK As Long = &H400000
Const NUMBER_OF_FINISH As Long = &H800000
Const NUMBER_OF_FLAGS As Long = NUMBER_OF_OK Or NUMBER_OF_FINISH
lLn = Len(sString)
If (lLn = &H0) Then Exit Function
lLn = ((lLn + lLn) - &H1)
pChar = VarPtr(lChar)
pString = StrPtr(sString)
For lPos = &H0 To lLn Step &H2
If ((lData And &HFF000000) = &HFF000000) Then
lChar = ((lChar And &HFF0000) \ &H10000) ' lchar = ((lchar & 0xff0000) >> 0x10000); // Lastima con la divicion se alentisa la funcion...
Else
RtlMoveMemory pChar, pString, &H4 ' // alentisa la funcion....
pString = (pString + &H4)
End If
lData = (lData Xor &HFF000000)
' // Ceros a la izquierda
If ((lData And NUMBER_HEX) = NUMBER_HEX) Then
If (((lChar And &HFF) >= &H30) And ((lChar And &HFF) <= &H39)) Or _
(((lChar And &HFF) >= &H61) And ((lChar And &HFF) <= &H66)) Or _
(((lChar And &HFF) >= &H41) And ((lChar And &HFF) <= &H46)) Then ' // Numeros Hexadecimales
If ((lData And NUMBER_OF_FLAGS) = &H0) Then
If ((lChar And &HFF) = &H30) Then
lData = (lData Or NUMBER_HEX_ZERO)
Else
lData = (lData Or NUMBER_OF_OK)
End If
End If
Select Case (lData And NUMBER_OF_FLAGS)
Case NUMBER_OF_OK
lData = (lData + &H1)
If ((lData And &HFF) = &H11) Then Exit Function ' // QWord (Max Double)
lData = (lData Or NUMBER_OF_OK)
If ((lData Or NUMBER_HEX_FLAGS) = NUMBER_HEX_FLAGS) Then lData = (lData Xor NUMBER_HEX_ZERO)
Case NUMBER_OF_FINISH, NUMBER_OF_FLAGS
Exit Function
End Select
Else
Select Case (lChar And &HFF)
Case &H9, &HA, &HB, &HC, &HD, &H24, &H20, &HA0 ' // Espacios en Blanco
If ((lData Or NUMBER_HEX_FLAGS) = NUMBER_HEX_FLAGS) Then lData = ((lData Xor NUMBER_HEX_ZERO) Or NUMBER_OF_OK)
If ((lData And NUMBER_OF_FLAGS) = NUMBER_OF_OK) Then lData = (lData Or NUMBER_OF_FINISH)
Case &H0 ' // NULL Indica que se termina la cadena.
If ((lData And NUMBER_OF_FLAGS) = NUMBER_OF_FINISH) Then Exit Function
Exit For
Case Else
Exit Function
End Select
End If
Else
If ((lChar And &HFF) >= &H30) And ((lChar And &HFF) <= &H39) Then
lData = (lData Or NUMBER_OF_OK)
If ((lData And NUMBER_OF_FINISH) = NUMBER_OF_FINISH) Then Exit Function
If ((lData And NUMBER_POW_FLAGS) = NUMBER_POW) Then lData = (lData Or NUMBER_POW_FINISH)
Else
Select Case (lChar And &HFF)
Case &H0 ' // NULL Indica que se termina la cadena.
If ((lData And NUMBER_POW_FLAGS) = NUMBER_POW) Then Exit Function
Exit For
Case &H2E ' // "." Solo 1
If ((lData And NUMBER_POW_FLAGS) = NUMBER_POW) Then Exit Function
If ((lData And NUMBER_OF_FINISH) = NUMBER_OF_FINISH) Then Exit Function
If ((lData And PUNTO_DECIMAL) = PUNTO_DECIMAL) Then Exit Function
lData = (lData Or PUNTO_DECIMAL)
Case &H2B, &H2D ' // "+|-" Solo 1
If ((lData And NUMBER_POW_FLAGS) = NUMBER_POW) Then
lData = (lData Or NUMBER_POW_FINISH)
Else
If ((lData And NUMBER_OF_OK) = NUMBER_OF_OK) Then Exit Function
If ((lData And PUNTO_DECIMAL) = PUNTO_DECIMAL) Then Exit Function
If ((lData And SIGNO_SRC) = SIGNO_SRC) Then Exit Function
End If
If ((lData And NUMBER_OF_FINISH) = NUMBER_OF_FINISH) Then Exit Function
lData = (lData Or SIGNO_SRC)
Case &H2C
If Not ((lData And NUMBER_OF_OK) = NUMBER_OF_OK) Then Exit Function
If ((lData And NUMBER_POW_FLAGS) = NUMBER_POW) Then Exit Function
Case &H9, &HA, &HB, &HC, &HD, &H24 ' // Solo se permiten al inicio de un Numero (Espacios en Blanco).
If ((lData And PUNTO_DECIMAL) = PUNTO_DECIMAL) Then Exit Function
If ((lData And NUMBER_OF_FINISH) = NUMBER_OF_FINISH) Then Exit Function
If ((lData And NUMBER_OF_OK) = NUMBER_OF_OK) Then Exit Function
If ((lData And NUMBER_POW_FLAGS) = NUMBER_POW) Then Exit Function
Case &HA0, &H20 ' // Se permiten al Inicio/final de un numero.
If ((lData And NUMBER_OF_OK) = NUMBER_OF_OK) Then
lData = (lData Or NUMBER_OF_FINISH)
Else
If ((lData And PUNTO_DECIMAL) = PUNTO_DECIMAL) Then Exit Function
If ((lData And NUMBER_POW_FLAGS) = NUMBER_POW) Then Exit Function
End If
Case &H26 ' // Es un Numero Hexadecimal
If ((lData And NUMBER_OF_FINISH) = NUMBER_OF_FINISH) Then Exit Function
If ((lData And NUMBER_OF_OK) = NUMBER_OF_OK) Then Exit Function
If ((lData And SIGNO_SRC) = SIGNO_SRC) Then Exit Function
If ((lData And PUNTO_DECIMAL) = PUNTO_DECIMAL) Then Exit Function
If ((lData And NUMBER_POW_FLAGS) = NUMBER_POW) Then Exit Function
If ((lData And &HFF000000) = &HFF000000) Then
lChar = (lChar And &HFF0000) \ &H10000
Else
RtlMoveMemory pChar, (pString + &H4), &H4 ' // alentisa la funcion....
End If
If ((lChar And &HFF) = &H48) Or ((lChar And &HFF) = &H68) Then
lData = (lData Or NUMBER_HEX)
lPos = (lPos + &H2)
'pString = (pString + &H4)
lData = (lData Xor &HFF000000)
End If
Case &H44, &H45, &H64, &H65 ' // Numeros en Formato ###e-###, ###e+###
If ((lData And NUMBER_OF_FINISH) = NUMBER_OF_FINISH) Then Exit Function
If ((lData And NUMBER_POW) = NUMBER_POW) Then Exit Function
If ((lData And NUMBER_OF_OK) = NUMBER_OF_OK) Then
lData = (lData Or NUMBER_POW)
If ((lData And SIGNO_SRC) = SIGNO_SRC) Then lData = (lData Xor SIGNO_SRC) ' // Permitimos nuevamente los signos "+" y "-".
Else
Exit Function
End If
Case Else
Exit Function
End Select
End If
End If
Next
Select Case (lData And NUMBER_OF_FLAGS)
Case NUMBER_OF_OK, NUMBER_OF_FLAGS: isNumeric_Black = True
Case Else
Select Case (lData And NUMBER_HEX_FLAGS)
Case NUMBER_HEX_FLAGS: isNumeric_Black = True
End Select
End Select
End Function
Public Function Is_NumberT(ByRef str As String) As Boolean
On Error GoTo err
str = str + 0
Is_NumberT = True
Exit Function
err:
End Function
Private Function IsNumeric_TGa(str As String) As Boolean
Dim sAux As String
Dim lPos As Long, lCont As Long, lAsc As Long
lPos = 1
Do While lPos <= Len(str)
IsNumeric_TGa = True
sAux = Mid$(str, lPos, 1)
lAsc = Asc(sAux)
If (lAsc >= 48 And lAsc <= 57) Or (lAsc >= 43 And lAsc <= 46) Then
If lAsc = 44 Then
lCont = lCont + 1
If lCont > 1 Then
IsNumeric_TGa = False
Exit Function
End If
End If
Else
IsNumeric_TGa = False
Exit Function
End If
lPos = lPos + 1
Loop
End Function
Private Function IsNumeric_r338v3(ByVal str As String) As Boolean
Const vbSpace As String = " "
Dim cReg As Object
Set cReg = CreateObject("VBScript.RegExp")
str = Replace$(str, vbCr, vbSpace)
str = Replace$(str, vbLf, vbSpace)
str = Replace$(str, vbTab, vbNullString)
str = Trim$(str)
If str = vbNullString Or str = "+" Or str = "-" Then Exit Function
With cReg
' Hexadecimal y Notacion cientifica
.Pattern = "^(?:&H[\dA-F]{1,16}|[+\-]?\d(?:\.\d+)?[de][+\-]?\d+)$"
.Global = True
.IgnoreCase = True
End With
IsNumeric_r338v3 = cReg.Test(str)
If Not IsNumeric_r338v3 Then
' Testeamos con . como separador de miles y , como separador de decimales
' Personalmente seria para mi "^[+\-]?(?:\d{1,3}(?:\.\d{3})*|\d*)\,?\d*$"
' ya que 133.23.330 no es un numero aunque IsNumeric diga que si ¬¬
cReg.Pattern = "^[+\-]?\s*(?:\d{1,3}(?:\.\d{1,3})*|\d*)\,?\d*$"
IsNumeric_r338v3 = cReg.Test(str)
If Not IsNumeric_r338v3 Then
str = Replace$(str, "..", vbNullString)
' Testeamos con , como separador de miles y . como separador de decimales
cReg.Pattern = "^[+\-]?\s*(?:\d{1,3}(?:\,\d{3})*|\d+)\.?\d*$"
IsNumeric_r338v3 = cReg.Test(str)
End If
End If
Set cReg = Nothing
End Function
Private Function IsNumeric_LeandroA(expression) As Boolean
Select Case VarType(expression)
Case vbBoolean, vbByte, vbInteger, vbLong, vbCurrency, vbDecimal, vbDouble, vbNull, vbEmpty, vbError
IsNumeric_LeandroA = True
Case vbArray, vbDataObject, vbDate, vbObject, vbUserDefinedType
IsNumeric_LeandroA = False
Case vbString
If Val(expression) <> 0 Then
IsNumeric_LeandroA = True
Else
On Error Resume Next
IsNumeric_LeandroA = Abs(expression) + 1
End If
End Select
End Function
Private Function IsNumeric_7913(str As String) As Boolean
Dim x As Double
On Error GoTo Nonum
x = str
IsNumeric_7913 = True
Nonum:
End Function
OutPut:
Código:
Error: IsNumeric_TGa (",7.88")
Error: IsNumeric_LeandroA("10.45e.10")
Error: IsNumeric_TGa ("1.112.45")
Error: IsNumeric_r338v3("1.112.45")
Error: IsNumeric_LeandroA("1.112.45")
Error: IsNumeric_LeandroA("1.224e+-10.12")
Error: IsNumeric_LeandroA("45.01anonymouse")
Error: IsNumeric_TGa ("1..3")
Error: IsNumeric_r338v3("1..3")
Error: IsNumeric_LeandroA("1..3")
Error: IsNumeric_TGa ("1E+52")
Error: IsNumeric_LeandroA("3
0")
Error: IsNumeric_LeandroA("3000
0")
Error: IsNumeric_TGa ("1E+45")
Error: IsNumeric_TGa ("1E+45")
Error: IsNumeric_LeandroA("+1. .2")
Error: IsNumeric_TGa ("+")
Nota: La funcion IsNumeric_LeandroA Sufre Desbodamiento con la string &H999999999999999999" & Chr(0) & "999999999999999999999999999
Temibles Lunas!¡.
.
En línea
