[RESOLVED] [VB6] - separe all words and symbols

**MarkT** · Jun 13th, 2013, 09:35 AM

Does this do it?

Code:

Private Function ExtendedSplit(ByVal strInputString As String) As String()
Dim i As Integer
Dim objRegExp
Dim objMatch
Dim colMatches
Dim strTestInput As String
Dim strOldValue As String
Dim strNewValue As String
Dim tempArr() As String
    
    ' Create a regular expression object.
    Set objRegExp = CreateObject("VBScript.RegExp")
    
    'Set the pattern.
    objRegExp.Pattern = "\"".*?\"""
    
    'Set global applicability.
    objRegExp.Global = True
    
    'Test whether the String can be compared.
    If (objRegExp.Test(strInputString) = True) Then
        'Get the matches.
        Set colMatches = objRegExp.Execute(strInputString)
        
        Debug.Print strInputString
        
        ' Iterate Matches collection.
        For Each objMatch In colMatches
            strOldValue = objMatch.Value
            strNewValue = Replace(strOldValue, Chr(34), Chr(128))
            strNewValue = Replace(strNewValue, Chr(32), Chr(129))
            'Debug.Print objMatch.Value
            
            strInputString = Replace(strInputString, strOldValue, strNewValue)
        Next
        
        Debug.Print strInputString
    End If
    
    For i = 1 To 127
        Select Case i
            Case 1 To 47, 59 To 64, 91 To 96, 123 To 127
                strInputString = Replace(strInputString, Chr(i), " " & Chr(i) & " ")
        End Select
    Next i
    
    Do While InStr(strInputString, Space(2))
        strInputString = Replace(strInputString, Space(2), Space(1))
    Loop
    
    strInputString = Trim(strInputString)
    tempArr = Split(strInputString, " ")
    
    For i = 0 To UBound(tempArr)
        tempArr(i) = Replace(tempArr(i), Chr(128), Chr(34))
        tempArr(i) = Replace(tempArr(i), Chr(129), Chr(32))
    Next i
    
    ExtendedSplit = tempArr
End Function

**joaquim** · Jun 13th, 2013, 09:41 AM

Originally Posted by MarkT

Does this do it?

Code:

Private Function ExtendedSplit(ByVal strInputString As String) As String()
Dim i As Integer
Dim objRegExp
Dim objMatch
Dim colMatches
Dim strTestInput As String
Dim strOldValue As String
Dim strNewValue As String
Dim tempArr() As String
    
    ' Create a regular expression object.
    Set objRegExp = CreateObject("VBScript.RegExp")
    
    'Set the pattern.
    objRegExp.Pattern = "\"".*?\"""
    
    'Set global applicability.
    objRegExp.Global = True
    
    'Test whether the String can be compared.
    If (objRegExp.Test(strInputString) = True) Then
        'Get the matches.
        Set colMatches = objRegExp.Execute(strInputString)
        
        Debug.Print strInputString
        
        ' Iterate Matches collection.
        For Each objMatch In colMatches
            strOldValue = objMatch.Value
            strNewValue = Replace(strOldValue, Chr(34), Chr(128))
            strNewValue = Replace(strNewValue, Chr(32), Chr(129))
            'Debug.Print objMatch.Value
            
            strInputString = Replace(strInputString, strOldValue, strNewValue)
        Next
        
        Debug.Print strInputString
    End If
    
    For i = 1 To 127
        Select Case i
            Case 1 To 47, 59 To 64, 91 To 96, 123 To 127
                strInputString = Replace(strInputString, Chr(i), " " & Chr(i) & " ")
        End Select
    Next i
    
    Do While InStr(strInputString, Space(2))
        strInputString = Replace(strInputString, Space(2), Space(1))
    Loop
    
    strInputString = Trim(strInputString)
    tempArr = Split(strInputString, " ")
    
    For i = 0 To UBound(tempArr)
        tempArr(i) = Replace(tempArr(i), Chr(128), Chr(34))
        tempArr(i) = Replace(tempArr(i), Chr(129), Chr(32))
    Next i
    
    ExtendedSplit = tempArr
End Function

yes. .thanks for all.. realy.. thanks

**Zvoni** · Jun 14th, 2013, 05:20 AM

I couldn't resist

I'm pretty sure a lot of people see the usage in parsing Command-Line-Arguments

Code:

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function StrSpn Lib "SHLWAPI" Alias "StrSpnW" (ByVal psz As Long, ByVal pszSet As Long) As Long
Private Declare Function StrCSpn Lib "SHLWAPI" Alias "StrCSpnW" (ByVal lpStr As Long, ByVal lpSet As Long) As Long

Private Const sEmpty = ""
Private Const sQuote2 = """"
Private Const chQuote = 34  ' Asc("""")
Private Const Separator As String = "();, +-*/" & sQuote2
'private const MyString As String = "int soma(int a,int b)"
Private Const MyString As String = "write(""Hello World"")"

Sub main()
Dim Result As String
    
    Result = GetQToken(MyString, Separator)
    
    Debug.Print Result
    
    Do
        'second and consecutive calls with empty string
        Result = GetQToken(sEmpty, Separator)
        
        If Result <> " " And Result <> sEmpty Then Debug.Print Result
    
    Loop Until Result = ""
    

End Sub

' New GetQToken uses faster StrSpn and StrCSpn from SHLWAPI.DLL
Function GetQToken(sTarget As String, sSeps As String) As String
    ' GetQToken = sEmpty
    
    
    ' Note that sSave, pSave, pCur, and cSave must be static between calls
    Static sSave As String, pSave As Long, pCur As Long, cSave As Long
    ' First time through save start and length of string
    If sTarget <> sEmpty Then
        ' Save in case sTarget is moveable string (Command$)
        sSave = sTarget
        pSave = StrPtr(sSave)
        pCur = pSave
        cSave = Len(sSave)
    Else
        ' Quit if past end (also catches null or empty target)
        If pCur >= pSave + (cSave * 2) Then Exit Function
    End If
    
    Dim pSeps As Long
    pSeps = StrPtr(sSeps)

    ' Get current character
    Dim c As Long
    ' Find start of next token
    c = StrSpn(pCur, pSeps)
    ' Set position to start of token
    If c Then
            'catching the separators
            GetQToken = String$(1, 0)
            CopyMemory ByVal StrPtr(GetQToken), ByVal pCur, 2
            pCur = pCur + 2
            Exit Function
        
    End If
    
    Dim ch As Integer
    CopyMemory ch, ByVal pCur - 2, 2
    ' Check first character for quote, then find end of token
    If ch = chQuote Then
        c = StrCSpn(pCur, StrPtr(sQuote2))
    Else
        c = StrCSpn(pCur, pSeps)
    End If
    ' If token length is zero, we're at end
    If c = 0 Then Exit Function
    
    ' Cut token out of target string
    GetQToken = String$(c, 0)
    CopyMemory ByVal StrPtr(GetQToken), ByVal pCur, c * 2
    ' Set new starting position
    pCur = pCur + (c * 2)

End Function

**joaquim** · Jun 14th, 2013, 05:28 AM

Originally Posted by Zvoni

I couldn't resist

I'm pretty sure a lot of people see the usage in parsing Command-Line-Arguments

Code:

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function StrSpn Lib "SHLWAPI" Alias "StrSpnW" (ByVal psz As Long, ByVal pszSet As Long) As Long
Private Declare Function StrCSpn Lib "SHLWAPI" Alias "StrCSpnW" (ByVal lpStr As Long, ByVal lpSet As Long) As Long

Private Const sEmpty = ""
Private Const sQuote2 = """"
Private Const chQuote = 34  ' Asc("""")
Private Const Separator As String = "();, +-*/" & sQuote2
'private const MyString As String = "int soma(int a,int b)"
Private Const MyString As String = "write(""Hello World"")"

Sub main()
Dim Result As String
    
    Result = GetQToken(MyString, Separator)
    
    Debug.Print Result
    
    Do
        'second and consecutive calls with empty string
        Result = GetQToken(sEmpty, Separator)
        
        If Result <> " " And Result <> sEmpty Then Debug.Print Result
    
    Loop Until Result = ""
    

End Sub

' New GetQToken uses faster StrSpn and StrCSpn from SHLWAPI.DLL
Function GetQToken(sTarget As String, sSeps As String) As String
    ' GetQToken = sEmpty
    
    
    ' Note that sSave, pSave, pCur, and cSave must be static between calls
    Static sSave As String, pSave As Long, pCur As Long, cSave As Long
    ' First time through save start and length of string
    If sTarget <> sEmpty Then
        ' Save in case sTarget is moveable string (Command$)
        sSave = sTarget
        pSave = StrPtr(sSave)
        pCur = pSave
        cSave = Len(sSave)
    Else
        ' Quit if past end (also catches null or empty target)
        If pCur >= pSave + (cSave * 2) Then Exit Function
    End If
    
    Dim pSeps As Long
    pSeps = StrPtr(sSeps)

    ' Get current character
    Dim c As Long
    ' Find start of next token
    c = StrSpn(pCur, pSeps)
    ' Set position to start of token
    If c Then
            'catching the separators
            GetQToken = String$(1, 0)
            CopyMemory ByVal StrPtr(GetQToken), ByVal pCur, 2
            pCur = pCur + 2
            Exit Function
        
    End If
    
    Dim ch As Integer
    CopyMemory ch, ByVal pCur - 2, 2
    ' Check first character for quote, then find end of token
    If ch = chQuote Then
        c = StrCSpn(pCur, StrPtr(sQuote2))
    Else
        c = StrCSpn(pCur, pSeps)
    End If
    ' If token length is zero, we're at end
    If c = 0 Then Exit Function
    
    ' Cut token out of target string
    GetQToken = String$(c, 0)
    CopyMemory ByVal StrPtr(GetQToken), ByVal pCur, c * 2
    ' Set new starting position
    pCur = pCur + (c * 2)

End Function

thanks for share

Thread: [RESOLVED] [VB6] - separe all words and symbols

Thread Tools

Display

Hybrid View

Re: [RESOLVED] [VB6] - separe all words and symbols

Re: [RESOLVED] [VB6] - separe all words and symbols

Re: [RESOLVED] [VB6] - separe all words and symbols

Re: [RESOLVED] [VB6] - separe all words and symbols

Posting Permissions