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

[joaquim]

i'm doing the ExtendedSplit() function. these function is for separe all words\strings\symbols:

Public Function ExtendedSplit(ByVal Sentence As String) As String()
    Dim lngSentencePos As Long
    Dim lngStartWord As Long
    Dim strWord() As String
    Dim lngWordIndex As Long
    
    For lngSentencePos = 1 To Len(Sentence)
        If Mid(Sentence, lngSentencePos, 1) <> "" And lngStartWord = 0 Then
            lngStartWord = lngSentencePos
        ElseIf (Mid(Sentence, lngSentencePos, 1) = " " Or Mid(Sentence, lngSentencePos, 1) = "(" Or Mid(Sentence, lngSentencePos, 1) = "(" Or Mid(Sentence, lngSentencePos, 1) = "=" Or Mid(Sentence, lngSentencePos, 1) = "+" Or Mid(Sentence, lngSentencePos, 1) = """") And lngStartWord <> 0 Then
           ReDim Preserve strWord(lngWordIndex + 1)
           strWord(lngWordIndex) = Mid(Sentence, lngStartWord, lngSentencePos - 1)
           Debug.Print strWord(lngWordIndex)
           ReDim Preserve strWord(lngWordIndex + 1)
           strWord(lngWordIndex) = Mid(Sentence, lngSentencePos, 1)
           Debug.Print strWord(lngWordIndex)
           lngStartWord = 0
        End If
    Next lngSentencePos
    
    ExtendedSplit = strWord()
End Function

sample:

int soma(int a,int b)

words(0)="int"
words(1)="soma"
words(2)="("
words(3)="int"
words(4)="a"
words(5)=","
words(6)="int"
words(7)="b"
words(8)=")"

(maybe i can do for strings and comments(or ignore comments))
but can anyone tell me what i'm doing wrong please?

[SamOscarBrown]

Attachment 101085

Is this what you currently get as an output?

[SamOscarBrown]

Try this

Public Function ExtendedSplit(ByVal Sentence As String) As String()
Dim startlocation As Integer
Dim lenSentence As Integer
Dim words() As String
Dim x As Integer, y As Integer
Sentence = Label1.Caption
For x = 1 To Len(Sentence)
   ReDim words(x) As String
   startlocation = x
   If Mid(Sentence, x, 1) = " " Or Mid(Sentence, x, 1) = "(" Or Mid(Sentence, x, 1) = "," Or Mid(Sentence, x, 1) = ")" Then
      words(x) = Mid(Sentence, 1, startlocation - 1)
      If Mid(Sentence, startlocation, 1) <> " " Then
         words(x) = Mid(Sentence, startlocation, 1)
      End If
      Sentence = Mid(Sentence, x + 1)
       x = 1
    End If

Next x
End Function

Note---you can modify to add more symbols

[MarkT]

Here's a slightly different approach

Option Explicit

Private Sub Command1_Click()
Dim strParts() As String
Dim i As Integer

    strParts = ExtendedSplit("int soma(int a,int b)")
    
    For i = 0 To UBound(strParts)
        Debug.Print strParts(i)
    Next i
End Sub

Private Function ExtendedSplit(ByVal strInputString As String) As String()
Dim i As Integer

    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)
    
    ExtendedSplit = Split(strInputString, " ")
End Function

[SamOscarBrown]

@MarkT....yes, Split is a much better function than mid for something like this....the mid example is more difficult to modify when additional symbols are added. Good post.

[Max187Boucher]

Try this for a starter

Private Sub Command2_Click()
Dim sText As String
Dim Symbols As String
Dim i As Integer
    Symbols = " ~!@#$%^&*()_+`-=[];'\,./{}:|<>?" & Chr(34) & vbNewLine
    
    Do Until i = Len(Text1.Text)
    
        i = i + 1
        
        If InStr(1, Symbols, Mid(Text1.Text, i, 1)) Then
            If Len(sText) > 0 Then List1.AddItem sText
            sText = vbNullString
            If Not Mid(Text1.Text, i, 1) = Space(1) Then List1.AddItem Mid(Text1.Text, i, 1)
        Else
            sText = sText & Mid(Text1.Text, i, 1)
        End If
        
        DoEvents
        
    Loop
    
End Sub

Note:
Text1 will contain your text (sentences).
List1 will have the split words.
Command2 is the button you have to click to execute!

[Bonnie West]

but can anyone tell me what i'm doing wrong please?

... Mid(Sentence, lngSentencePos, 1) = "(" Or Mid(Sentence, lngSentencePos, 1) = "(" ...

Second character should probably be ")".



Here is yet another attempt at an extended Split function. This one closely imitates the intrinsic Split function. The only thing that was extended is that the Delimiters parameter accepts any number of a single character that will be used to delimit the word(s).

Public Function SplitEx(ByRef Expression As String, Optional ByRef Delimiters As String = " ()=+""", _
                                                    Optional ByVal Limit As Long = -1&, _
                                                    Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As String()
    Dim i As Long, CharCode As Long
    Dim bytExpress() As Byte

    Select Case True                                            'Select Case allows short-circuiting expressions
        Case LenB(Expression) = 0&, LenB(Delimiters) = 0&       'If either Expression or Delimiters is an empty string
            SplitEx = Split(Expression, Delimiters)             'return either an empty array or the entire expression
            Exit Function                                       'in a single-element array and exit early
    End Select

    bytExpress() = Expression                                   'Convert String to Byte array for faster processing than Mid$

    For i = 0& To UBound(bytExpress) - 1& Step 2&               'Iterate through each character
        CharCode = &H100& * bytExpress(i + 1&) Or bytExpress(i) 'Get character code via inline MakeWord(LoByte, HiByte)
        If InStr(1&, Delimiters, ChrW$(CharCode), Compare) Then 'Check if current character is a delimiter
            bytExpress(i) = 0                                   'Turn all delimiters to vbNullChar so that the
            bytExpress(i + 1&) = 0                              'Split function needs to be called only once
        End If
    Next

    SplitEx = Split(bytExpress(), vbNullChar, Limit, Compare)   'The Byte array is coerced to a String when passed
End Function

[joaquim]

Here's a slightly different approach

Option Explicit

Private Sub Command1_Click()
Dim strParts() As String
Dim i As Integer

    strParts = ExtendedSplit("int soma(int a,int b)")
    
    For i = 0 To UBound(strParts)
        Debug.Print strParts(i)
    Next i
End Sub

Private Function ExtendedSplit(ByVal strInputString As String) As String()
Dim i As Integer

    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)
    
    ExtendedSplit = Split(strInputString, " ")
End Function

i love it... thanks for all
i must update it for strings(for put the entire string in same index), but it's great.. thanks for all
thanks to all

[Max187Boucher]

I haven't tried Sam's or Bonnie's but Max (mine) vs MarkT's has a big difference in performance.



Edit:
I forgot to remove the DoEvents in both haha this was the result after MarkT was 3 seconds, Max was 1 second
Still 2 seconds faster for a loop of 10000

[MarkT]

I haven't tried Sam's or Bonnie's but Max (mine) vs MarkT's has a big difference in performance.

Edit:
I forgot to remove the DoEvents in both haha this was the result after MarkT was 3 seconds, Max was 1 second
Still 2 seconds faster for a loop of 10000

Or in other words, for one time through the code mine is .0002 seconds slower?

[Max187Boucher]

Jusy saying... using mid() was faster.

[SamOscarBrown]

Verly interestink (Arte Johnson, "Laugh-In")!

[joaquim]

from MarkT's function: anyone can advice me for put the entire string in index?

sample:

write("hello world")


words(0)="write"
words(1)="("
words(2)=""hello world""
wrods(3)=")"

can anyone advice how can i do these?

[Bonnie West]

words(0) = "write"
words(1) = "("
words(2) = """hello world"""
words(3) = ")"

[joaquim]

words(0) = "write"
words(1) = "("
words(2) = """hello world"""
words(3) = ")"

i understand what you did
i know that strings in VB6 the quotes are represented by double quotes. what i don't know is, with MarkT's function catch it in that way
or maybe i know
doing a second array and testing the 1st array
maybe doing that i can test the coments too... then i will do it

[MarkT]

I'm not sure I understand the goal.

Are you trying to return everything in quotes as a single array item?

[joaquim]

I'm not sure I understand the goal.

Are you trying to return everything in quotes as a single array item?

yes my friend
(sorry my bad english;()

[Zvoni]

Kind of reminds me that he's trying to do something like this here: http://vb.mvps.org/hardcore/
Look at Chapter 5 - "Code Review"

I just happen to have the mentioned source-code-files "parse.bas" and "parse.cls" mentioned on the page "Fastest versus safest"

[joaquim]

Kind of reminds me that he's trying to do something like this here: http://vb.mvps.org/hardcore/
Look at Chapter 5 - "Code Review"

I just happen to have the mentioned source-code-files "parse.bas" and "parse.cls" mentioned on the page "Fastest versus safest"

hey.. have you enter in link? why i get 1 strange message\question?

[Zvoni]

hey.. have you enter in link? why i get 1 strange message\question?

opens fine for me. you must have Java enabled for that page.

EDIT: If you can't find the mentioned source-files, i can post the relevant code here, but i want an OK from the Moderators of this forum, that it's OK to post McKinney's Code (i would just throw out some unnecessary lines)

[joaquim]

opens fine for me. you must have Java enabled for that page

sorry... don't seems be java
that's why i don't execute
but i think i understand what you mean: the Hardcode VB6 it's a book. and you said for i see the chapter 5. i don't have sure if i have the book, but i will try see it
thanks

[Zvoni]

The chapter is basically a discussion about parsing strings (what you're trying to do here). The mentioned source-files contain a ready-to-use solution to your problem, but since it's not my code i want the OK from the Mod's to proceed

[MarkT]

Does this do it?

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]

Does this do it?

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]

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

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]

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

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

[Zvoni]

I would be intersted if someone did a performance-test on Mark's and "my" solution (better said: Credit's for the Code go to Bruce McKinney, i just added the part to catch the separators. I've researched it in Bruce's Book: His code is free to use as long as you don't change the whole component)