[RESOLVED] Detect words in a listbox (Resolved)

Re: Detect words in a listbox (UNResolved)

Quote:
Originally posted by Nightwalker83
Hi,

I am trying to detect words that are in a listbox by typing a word in a textbox then click if the word is in the box.

VB Code:

Private Sub Command1_Click()
For b = 0 To frmSetup.Lstblock.ListCount
If Text1.Text = frmSetup.Lstblock.List(b) Then
MsgBox ("Word is not allowed")
Else
If Not Text1.Text = Text1.Text & frmSetup.Lstblock.List(b) Then
Exit Sub
End If
End If
Next b
frmSetup.Show
End Sub

This code works only when I type in the word that is the first word listed in the listbox. How can I make in so it checks for all the wors typed into the listbox?
rewriting the entire code from scratch is going overboard. maybe
you all should have debugged his current code. the Else clause
checked to see if the word was illegal against the first entry, and if
it wasn't , it EXITED THE SUB. that is the problem! The following small change will fix that.
VB Code:
Private Sub Command1_Click()
For b = 0 To frmSetup.Lstblock.ListCount
   If Text1.Text = frmSetup.Lstblock.List(b) Then
      MsgBox ("Word is not allowed")
      exit sub
   Else
   
End If
Next b
frmSetup.Show
End Sub

Aaron,

The Replace statement (above the Array Load) in the missLiss DataArrival Sub, isn't required..... if you don't write out
the vbCrLf in the Command3_Click event.

So, the reason why it wasn't detecting a single word - "beep"
was the Command3 event was appending a vbCrLf to the typed word.

Hence the Array held - "beep vbCrLf" which would result in a non-match.

Therefore, remove all the vbCrLf appends to the typed word,
prior to sending them (see below) and remove the Replace
statement above the Array load routine (in the messLiss Data arrival):
VB Code:
Private Sub Command3_Click()
 'Send a message
If messcon.State = 7 Then
User = frmProfile.txtHandle.Text & " " & "Says:" & " "
messcon.SendData "|MESSAGE|" & User & txtSay.Text ' & vbCrLf< ** Remove this****
Else
MsgBox (LoadResString(68 + i))
End If
txtMess.Text = txtMess.Text & User & txtSay.Text ' & vbCrLf< ** Remove this****
End Sub
(Also, a Carriage return IS being added when the txtMess box is loaded for the USER to see)

Bruce.

This will replace whole words only, if you'd like

VB Code:

Option Explicit
 
Private Sub Command1_Click()
 
    Dim sMyString       As String
    Dim sListArray()    As String
    Dim i               As Long
 
    ' This just adds stuff to the listbox.
    With List1
        .AddItem "fry"
        .AddItem "go"
        .AddItem "gumballs"
        .AddItem "hey"
        .AddItem "mamma"
        .AddItem "stick"
    End With
    
    ' This creates an array of listbox items because the
    ' ReplaceWholeWords function needs an array of
    ' replacement words.
    ReDim sListArray(List1.ListCount - 1)
    For i = 0 To List1.ListCount - 1
        sListArray(i) = List1.List(i)
    Next
        
    ' This would be the text that you get in (well, maybe...)
    sMyString = "Hey, sticky mamma! They are gonna go gobble " & _
                "Mamma's gumballs, and fry Daddy's Fish-Stick"
        
    ' This shows the unaltered string
    Text1.Text = sMyString
    
    ' Here we replace the "banned" words.
    ReplaceWholeWords sMyString, sListArray
    
    ' This shows the "declassified" string.
    Text2.Text = sMyString
        
 
End Sub
 
Function ReplaceWholeWords(ByRef Text As String, _
                           ByRef WordList() As String, _
                  Optional ByVal ReplaceChar As String = "*")
    
    ' Replaces whole words with the ReplaceCharacter.
    ' A whole word is considered to be any instance of the
    ' word that does not have a letter before or after it.
    ' Not case sensitive.
    ' Example: "Hello World!" with "world" in the
    ' word list and using default replacement character "*"
    ' returns "Hello *****!"
 
    Dim sWord       As String   ' A word from the replace list.
    Dim lWordLen    As Long     ' Length of the replace word.
    Dim lWordStart  As Long     ' Start of the found word.
    Dim lCharBefore As Long     ' ASCII value of character before found word.
    Dim lCharAfter  As Long     ' ASCII value of character after found word.
    Dim i           As Long     ' Loop counter.
 
    ' Pad the string with spaces so that there is always
    ' a before and after character.
    Text = " " & Text & " "
 
    ' Loop through the list of replacement words.
    For i = 0 To UBound(WordList)
        
        ' Get replacement word, length of the word, and
        ' the start of the first instance of the word in
        ' the text string.
        sWord = WordList(i)
        lWordLen = Len(sWord)
        lWordStart = InStr(1, Text, sWord, vbTextCompare)
        
        ' Check every instance of the found word.
        Do Until lWordStart = 0
            
            ' Get ASCII value of characters before and
            ' after found word.
            lCharBefore = Asc(UCase$(Mid$(Text, lWordStart - 1, 1)))
            lCharAfter = Asc(UCase$(Mid$(Text, lWordStart + lWordLen, 1)))
            
            ' Check if characters before and after found word
            ' are letters. If there are no letter on either side
            ' the it is a "whole" word.
            If (lCharBefore < 65 Or lCharBefore > 90) And _
               (lCharAfter < 65 Or lCharBefore > 90) Then
                ' Repalce found whole word with replacement characters.
                Mid$(Text, lWordStart, lWordLen) = String$(lWordLen, ReplaceChar)
            End If
            
            ' Find start of next instance of word.
            lWordStart = InStr(lWordStart + 1, Text, sWord, vbTextCompare)
        
        Loop
    
    Next
 
    ' Get rid of the padding that was added.
    Text = Mid$(Text, 2, Len(Text) - 2)
 
End Function

Bruce,

I solved the problem using:

VB Code:

Private Sub Command3_Click()
 'Send a message
If messcon.State = sckConnected Then
User = frmProfile.txtHandle.Text & " " & "Says:" & " "
messcon.SendData "|MESSAGE|" & User & txtSay.Text
txtMess.Text = txtMess.Text & User & txtSay.Text & vbCrLf ' This vbcrlf is needed so the client sending the data also goes to the next line. 
Else
MsgBox (LoadResString(68 + i))
End If
End Sub

Quote:

Originally posted by WorkHorse
This will replace whole words only, if you'd like

VB Code:

Option Explicit

Private Sub Command1_Click()

Dim sMyString As String
Dim sListArray() As String
Dim i As Long

' This just adds stuff to the listbox.
With List1
.AddItem "fry"
.AddItem "go"
.AddItem "gumballs"
.AddItem "hey"
.AddItem "mamma"
.AddItem "stick"
End With

' This creates an array of listbox items because the
' ReplaceWholeWords function needs an array of
' replacement words.
ReDim sListArray(List1.ListCount - 1)
For i = 0 To List1.ListCount - 1
sListArray(i) = List1.List(i)
Next

' This would be the text that you get in (well, maybe...)
sMyString = "Hey, sticky mamma! They are gonna go gobble " & _
"Mamma's gumballs, and fry Daddy's Fish-Stick"

' This shows the unaltered string
Text1.Text = sMyString

' Here we replace the "banned" words.
ReplaceWholeWords sMyString, sListArray

' This shows the "declassified" string.
Text2.Text = sMyString

End Sub

Function ReplaceWholeWords(ByRef Text As String, _
ByRef WordList() As String, _
Optional ByVal ReplaceChar As String = "*")

' Replaces whole words with the ReplaceCharacter.
' A whole word is considered to be any instance of the
' word that does not have a letter before or after it.
' Not case sensitive.
' Example: "Hello World!" with "world" in the
' word list and using default replacement character "*"
' returns "Hello *****!"

Dim sWord As String ' A word from the replace list.
Dim lWordLen As Long ' Length of the replace word.
Dim lWordStart As Long ' Start of the found word.
Dim lCharBefore As Long ' ASCII value of character before found word.
Dim lCharAfter As Long ' ASCII value of character after found word.
Dim i As Long ' Loop counter.

' Pad the string with spaces so that there is always
' a before and after character.
Text = " " & Text & " "

' Loop through the list of replacement words.
For i = 0 To UBound(WordList)

' Get replacement word, length of the word, and
' the start of the first instance of the word in
' the text string.
sWord = WordList(i)
lWordLen = Len(sWord)
lWordStart = InStr(1, Text, sWord, vbTextCompare)

' Check every instance of the found word.
Do Until lWordStart = 0

' Get ASCII value of characters before and
' after found word.
lCharBefore = Asc(UCase$(Mid$(Text, lWordStart - 1, 1)))
lCharAfter = Asc(UCase$(Mid$(Text, lWordStart + lWordLen, 1)))

' Check if characters before and after found word
' are letters. If there are no letter on either side
' the it is a "whole" word.
If (lCharBefore < 65 Or lCharBefore > 90) And _
(lCharAfter < 65 Or lCharBefore > 90) Then
' Repalce found whole word with replacement characters.
Mid$(Text, lWordStart, lWordLen) = String$(lWordLen, "*")
End If

' Find start of next instance of word.
lWordStart = InStr(lWordStart + 1, Text, sWord, vbTextCompare)

Loop

Next

' Get rid of the padding that was added.
Text = Mid$(Text, 2, Len(Text) - 2)

End Function

I have already done what you're suggesting:

And...

Look at the User = frmProfile.txtHandle.Text & " " & "Says:" & " "
You are ADDING " " (space) prior to sending the string.....

That is why we needed to Replace the " " with "" in the
missLissDataArrival too.

I would personaly not send the space, so I didn't need to
remove it on the other end - similar to not sending the vbCrlf :)

Bruce.

Quote:

Originally posted by WorkHorse

Thanks for the input WokHorse,

The problems were that a vbCrLf and a space were being sent
over in the message string. So that made it difficult to get a match
on the other end. :)

I guess it was a simple debug :eek: at the end of te day.

Bruce.