Foro de elhacker.net

Function dejarNumeros(cadenaTexto As String) As String
  Const listaNumeros = "0123456789"
  Dim cadenaTemporal As String
  Dim i As Integer
 
  cadenaTexto = Trim$(cadenaTexto)
  If Len(cadenaTexto) = 0 Then
    Exit Function
  End If
 
  cadenaTemporal = ""
 
  For i = 1 To Len(cadenaTexto)
    If InStr(listaNumeros, Mid$(cadenaTexto, i, 1)) Then
      cadenaTemporal = cadenaTemporal + Mid$(cadenaTexto, i, 1)
    End If
  Next
  return cadenaTemporal
End Function

Private Sub Form_Load()
    Debug.Print SoloNumeros("P1rueba922")
End Sub
 
Public Function SoloNumeros(ByVal sCadena As String) As String
    Dim vItem       As Variant
    Dim bvBytes()   As Byte
 
    bvBytes = StrConv(sCadena, vbFromUnicode)
 
    For Each vItem In bvBytes
        If (48 <= vItem) And (vItem <= 57) Then
            SoloNumeros = SoloNumeros & Chr$(vItem)
        End If
    Next vItem
End Function

Option Explicit
 
Private Sub Form_Load()
    Debug.Print Only_Numbers("hola1 ¿que34 tal538?")
End Sub
 
Public Function Only_Numbers(ByVal sText As String) As String
    Dim sActualChar     As String * 1
    Dim lTotalChar      As Long
    Dim x               As Long
    lTotalChar = Len(sText)
    If lTotalChar > 0 Then
        For x = 1 To lTotalChar
            sActualChar = Mid$(sText, x, 1)
            If IsNumeric(sActualChar) Then Only_Numbers = Only_Numbers & sActualChar
        Next
    End If
End Function

'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel )            //
' //                                                            //
' // Web: http://InfrAngeluX.Sytes.Net/                         //
' //                                                            //
' // |-> Pueden Distribuir Este Código siempre y cuando         //
' // no se eliminen los créditos originales de este código      //
' // No importando que sea modificado/editado o engrandecido    //
' // o achicado, si es en base a este código                    //
' ////////////////////////////////////////////////////////////////
'
Option Explicit
 
Public Function GetArrayNumbersFromString(ByVal StrInput$, Optional ByVal SepDecimal$ = ".") As String()
Dim StrArray_TMPArrayNumers$()
Dim Lng_Pos&
Dim Lng_LenMid&
Dim Lng_PosIInArray&
Dim Lng_LenStr&
Dim Str_Tmp$
Dim Str_Char$
    Lng_LenStr& = Strings.Len(StrInput$)
    If Lng_LenStr& > 1 Then
        If Not Information.IsNumeric(StrInput$) Then
            Str_Char$ = Strings.Space$(1)
            For Lng_Pos& = 1 To Lng_LenStr&
                Str_Char$ = Strings.Mid$(StrInput$, Lng_Pos&, 1)
                If IsNumeric(Str_Char$) Or (Lng_LenMid& And Str_Char$ = SepDecimal$) Or (Lng_LenMid& = 0 And Str_Char$ = "-") Then
                    Lng_LenMid& = Lng_LenMid& + 1
                ElseIf Lng_LenMid& > 0 And Lng_Pos& <= Lng_LenStr& - 1 Then
                    If Lng_LenMid& = 1 And Strings.Mid$(StrInput$, Lng_Pos& - Lng_LenMid&, Lng_LenMid&) = "-" Then
                        Lng_LenMid& = 0
                    Else
                        ReDim Preserve StrArray_TMPArrayNumers$(Lng_PosIInArray&)
                        StrArray_TMPArrayNumers$(Lng_PosIInArray&) = Strings.Mid$(StrInput$, Lng_Pos& - Lng_LenMid&, Lng_LenMid&)
                        Lng_PosIInArray& = Lng_PosIInArray& + 1
                        Lng_LenMid& = 0
                    End If
                End If
            Next
            If Lng_LenMid& > 0 Then
                    ReDim Preserve StrArray_TMPArrayNumers$(Lng_PosIInArray&)
                    StrArray_TMPArrayNumers$(Lng_PosIInArray&) = Strings.Mid$(StrInput$, Lng_Pos& - Lng_LenMid&, Lng_LenStr&)
            End If
        Else
            ReDim StrArray_TMPArrayNumers$(Lng_PosIInArray&)
            StrArray_TMPArrayNumers$(Lng_PosIInArray&) = StrInput$
        End If
    End If
    GetArrayNumbersFromString = StrArray_TMPArrayNumers$()
End Function
 
 

 
    Const Str_Cadena$ = "123.4567.89.miguel angel000ort.....ega avila-a159.753jjj"
    MsgBox Strings.Join(GetArrayNumbersFromString(Str_Cadena$, ""), "-") & Constants.vbNewLine & _
           Strings.Join(GetArrayNumbersFromString(Str_Cadena$, "."), "-")
 
 

Public Function ExtractNumbers(ByVal sString As String, Optional bReturnAsString As Boolean = False) As Collection
    Dim cTemp   As New Collection
    Dim sTemp   As String
    Dim sChar   As String * 1
    Dim i       As Long
 
    sString = Replace$(sString, ",", ".")
 
    For i = 1 To Len(sString)
        sChar = Mid$(sString, i, 1)
        Do While (sChar Like "#") Or (sChar = ".")
            sTemp = sTemp & sChar
            i = i + 1
            sChar = Mid$(sString, i, 1)
        Loop
        If Val(sTemp) Then
            cTemp.Add IIf((bReturnAsString = False), Val(sTemp), sTemp)
        End If
        sTemp = vbNullString
    Next i
 
    Set ExtractNumbers = cTemp
End Function

Private Sub Form_Load()
    Dim vItem   As Variant
    
    For Each vItem In ExtractNumbers("Estoy provando la extracción de números como 1992, también la extracción de números decimales: 3,1415 o 3.1415")
        Debug.Print vItem
    Next vItem
End Sub

 
Public Function GetNumeros(text As String) As Collection
    ' Incluir en las referencias: Microsoft VBScritp Regular Expressions 5.5
    ' Obtener numeros, mediante expresiones regulares. By Raul338
    On Error GoTo err
    Dim cTemp As New Collection
    Dim objRegExp As RegExp
    Dim objMatch As Match
    Dim objMatches
 
    Set objRegExp = New RegExp
    Dim patron As String
 
    'patron = "(\d+)"                            ' Numeros enteros
    'patron = "(\d+(?:[\.,]\d+)?)"                ' Numeros con/sin decimales
    patron = "(\d{1,3}(\.\d{3})+(?:,\d+)?|\d+(?:,\d+)?)"   ' Numeros con separador de miles (.) con/sin decimales (,)
    'patron = "(\d{1,3}(\,\d{3})+(?:\.\d+)?|\d+(?:\.\d+)?)"   ' Numeros con separador de miles (,) con/sin decimales (.)
    'patron = "(\d+[,.]\d+)"                        ' Numeros con decimales
 
    objRegExp.Pattern = patron
    objRegExp.Global = True
 
    Set objMatches = objRegExp.Execute(text)
 
    For Each objMatch In objMatches
        cTemp.Add objMatch.Value
     Next
    Set GetNumeros = cTemp
    Exit Function
err:
    ' Aca tira error en caso de que metan mal la mano en las expresiones regulares xD
End Function
 

Private Sub Form_Load()
    Dim item As Variant
    Dim s As String
    s = "Estoy provando la extracción de números como 1992, también la extracción de números decimales: 3,1415"
    s = s & "Tambien puedo decir que tengo 1000000,24 dolares o 1.123.456,78 euros (?)"
    For Each item In GetNumeros(s)
        Debug.Print item
    Next
End Sub
 

 
    Dim cTemp       As New Collection
    Dim objRegExp   As Object 'RegExp
    Dim objMatch    As Object 'Match
    Dim objMatches  As Object
    Dim patron      As String
 
    Set objRegExp = CreateObject("VBScript.RegExp") 'New RegExp
 
 

Option Explicit
 
Public Function Get_Only_Numbers(ByVal sText As String) As String()
    Const sDecimals             As String = ",.'"
    Dim sNumbersArray()         As String
    Dim sActualChar             As String * 1
    Dim sNextChar               As String * 1
    Dim sPreviousChar           As String * 1
    Dim bAcceptString           As Boolean
    Dim lTotalChar              As Long
    Dim x                       As Long
    Dim y                       As Long
 
    lTotalChar = Len(sText)
    If lTotalChar > 0 Then
        ReDim sNumbersArray(0)
        For x = 1 To lTotalChar
            If x > 1 Then sPreviousChar = Mid$(sText, x - 1, 1)
            sActualChar = Mid$(sText, x, 1): sNextChar = Mid$(sText, x + 1, 1)
            If ((sActualChar = Chr$(45) Or InStr(sDecimals, sActualChar) > 0 And IsNumeric(sPreviousChar)) _
            And IsNumeric(sNextChar)) Or (IsNumeric(sActualChar)) Then
                bAcceptString = True
            Else
                If bAcceptString = True Then y = y + 1: ReDim Preserve sNumbersArray(y): bAcceptString = False
            End If
            If bAcceptString = True Then sNumbersArray(y) = sNumbersArray(y) & sActualChar
        Next x
        Get_Only_Numbers = sNumbersArray()
        Erase sNumbersArray
    End If
End Function
 
Private Sub Form_Load()
    Dim vItem                 As Variant
    Dim sStringToAnalyze      As String
 
    sStringToAnalyze = "Estoy provando la extracción de números como 1992, también la extracción de números decimales: 3,1415 o 3.1415"
    sStringToAnalyze = sStringToAnalyze & "También puedo decir que tengo 1000000,24 dólares o 1.123.456,78 euros (?)"
    sStringToAnalyze = sStringToAnalyze & "Pero mi función también reconoce numeros como el -2344 y 5'567 y no los confunde con m.456 ni con -a89 ... =)"
    For Each vItem In Get_Only_Numbers(sStringToAnalyze): Debug.Print vItem: Next
End Sub