highlight search words

lucian · June 20th, 2003, 06:46 PM

I am working on this in the last three days and it does not seems toget anywhere with it.
I made so many changes that I am loosing track of them myself.
I am looking for some help here if possible.

I have this search page that I would like to change the search words in bold but it only works if the customer enters only one word or if the sentence he's using is exactly the same(Ucase or Lcase) in the second or third... word.
I enclose my code hopping that somebody could help.

<%
Dim CompType, t3_advSearch_String
'Store type of query in CompType ie All Words/OR, Any Word/AND or Exact Phrase/EXACT
CompType = Request("CompType")
SearchColumn = "ProductName + Description"

SearchField = "zzz"
if(Request("SearchParam") <> "") then SearchField = Request("SearchParam")
'Remove any single quotes from search field to eliminate potential errors.
SearchField = Replace(SearchField, "'", "")

'Checks the CompType, Executes this code if the option All words or Any Word is chosen
if(CompType <> "EXACT") then
 t3_advSearch_String = "WHERE " & SearchColumn & " LIKE '%"
 'Splits the search criteria into seperate words and stores them in an Array
 SearchArray=Split(SearchField," ")
 for i = 0 to Ubound(SearchArray)
 if i > 0 then
 'Builds the sql statement using the CompType to substitute AND/OR
 t3_advSearch_String = t3_advSearch_String & " " & CompType & " " & SearchColumn & " LIKE '%"& SearchArray(i) & "%'"
 else
 'Ends the sql statement if there is only one word
 t3_advSearch_String = t3_advSearch_String & SearchArray(i) & "%' "
 end if
 next

else
 t3_advSearch_String = "WHERE " & SearchColumn & " LIKE '%" & SearchField & "%' "
end if
%>
<%
Dim rsSearch__t3_String
'rsSearch__t3_String = "WHERE ID=1"
if (t3_advSearch_String <> "") then rsSearch__t3_String = t3_advSearch_String
%>

............................

<% Dim strInputText
 strInputText = Request("SearchParam")

' I wrapped these into functions so you can reuse them.
'**** Begin Functions ***********************************
Function GetWordCount(strInput)
 Dim strCount

 ' Deal with tabs and carriage returns
 ' by replacing them with spaces.
 strCount = Replace(strInput, vbTab, " ")
 strCount = Replace(strCount, vbCr, " ")
 strCount = Replace(strCount, vbLf, " ")

 ' Remove leading and trailing spaces
 strCount = Trim(strCount)

 ' Combine multiple spaces down to single ones
 Do While InStr(1, strCount, " ", 1) <> 0
 strCount = Replace(strCount, " ", " ")
 Loop

 ' Get a count by splitting the string into an array
 ' and retreiving the number of elements in it.
 ' I add one to deal with the 0 lower bound.
 GetWordCount = UBound(Split(strCount, " ", -1, 1)) + 1
End Function ' GetWordCount
If strInputText = " " Then
strInputText = "AAA"
else
Response.Write GetWordCount(strInputText)
End If
'**** End Functions *************************************
Function ReplaceWords(str,word)

 word = SearchField
 strTemp = str

 strTemp = replace(strTemp,LCase(word),("" & LCase(word) & ""))
 strTemp = replace(strTemp,UCase(word),("" & UCase(word) & ""))
 For Each Item In SearchArray
 str = Left(word,1)
 str = UCase(str) & Right(word, len(word)-1)
 strTemp = replace(strTemp,str,("" & str & ""))
 ReplaceWords = strTemp
 Next
End Function
%>

lucian · June 22nd, 2003, 10:48 AM

I made the following changes and works fine, but I can manage the extra spaces between words.
Any Ideeas?

<%
Dim CompType, t3_advSearch_String
'Store type of query in CompType ie All Words/OR, Any Word/AND or Exact Phrase/EXACT
CompType = Request("CompType")
SearchColumn = "ProductName + Description"

SearchField = "zzz"
if(Request("SearchParam") <> "") then SearchField = Request("SearchParam")
'Remove any single quotes from search field to eliminate potential errors.
SearchField = Replace(SearchField, "'", "")

'Checks the CompType, Executes this code if the option All words or Any Word is chosen
if(CompType <> "EXACT") then
 t3_advSearch_String = "WHERE " & SearchColumn & " LIKE '%"
 'Splits the search criteria into seperate words and stores them in an Array
 SearchArray=Split(SearchField," ")
 for i = 0 to Ubound(SearchArray)
 if i > 0 then
 'Builds the sql statement using the CompType to substitute AND/OR
 t3_advSearch_String = t3_advSearch_String & " " & CompType & " " & SearchColumn & " LIKE '%"& SearchArray(i) & "%'"
 else
 'Ends the sql statement if there is only one word
 t3_advSearch_String = t3_advSearch_String & SearchArray(i) & "%' "
 end if
 next

else
 t3_advSearch_String = "WHERE " & SearchColumn & " LIKE '%" & SearchField & "%' "
end if
%>
..............
<style type="text/css">

</style>

<%
Function ReplaceWords(SearchText,ReplaceText)
arrTemp = Split(Request("SearchParam"), " ")
For i = 0 to UBOUND(arrTemp)
 ReplaceText = replace(ReplaceText,LCase(arrTemp(i)),("" & LCase(arrTemp(i)) & ""))
 ReplaceText = replace(ReplaceText,UCase(arrTemp(i)),("" & UCase(arrTemp(i)) & ""))

 str = Left(arrTemp(i),1)
 str = UCase(str) & Right(arrTemp(i), len(arrTemp(i)) -1)
 ReplaceText = replace(ReplaceText,str,("" & str & ""))
Next
 ReplaceWords = ReplaceText
End Function
%>
.........
<%strSearch = Request("SearchParam")
 strText = (rsSearch.Fields.Item("ProductName").Value)
 strText = ReplaceWords(strSearch, strText)
 Response.Write "" & strText & ""
%>

NotNowJohn · June 22nd, 2003, 01:19 PM

For removing extra spaces betwwen the words u can use this function:

Code:

Function RemoveExtraSpaces(orig_string)
    Do While InStr(1, orig_string, "  ")
      orig_string = Replace(orig_string, "  ", " ")
    Loop
    RemoveExtraSpaces=orig_string
End Function

...but the Soon is eclipsed by the Moon

lucian · June 22nd, 2003, 02:05 PM

Tat works but it does not highlight the words anymore.
Any Ideas?

NotNowJohn · June 22nd, 2003, 03:34 PM

Hmm.. try this:

Code:

Function RemoveExtraSpaces(orig_string)
    Do While InStr(1, orig_string, "  ")
      orig_string = Replace(orig_string, "  ", " ")
    Loop
    RemoveExtraSpaces=orig_string
End Function

Function HighlightWords(SearchText,ReplaceText)
    arrTemp = Split(SearchText, " ")
    For i = 0 to UBOUND(arrTemp)
    new_word="<b><span class=highlight>" & arrTemp(i) & "</span></b>"
        ReplaceText = Replace(ReplaceText,arrTemp(i),new_word)
    Next
    HighlightWords = ReplaceText
End Function
'usage:
text="this is a text you want to highlight"
hl_words="text   you "
'highlighted text:
Response.Write HighlightWords(RemoveExtraSpaces(hl_words),text)

...but the Soon is eclipsed by the Moon

lucian · June 22nd, 2003, 06:39 PM

I made few modification but without success as it highlights everything from were it finds the word down.

<%
Function RemoveExtraSpaces(orig_string)
 Do While InStr(1, orig_string, " ")
 orig_string = Replace(orig_string, " ", " ")
 Loop
 RemoveExtraSpaces=orig_string
End Function

Function HighlightWords(SearchText,ReplaceText)
 arrTemp = Split(SearchText, " ")
 For i = 0 to UBOUND(arrTemp)
 ReplaceText = replace(ReplaceText,LCase(arrTemp(i)),("" & LCase(arrTemp(i)) & ""))
 ReplaceText = replace(ReplaceText,UCase(arrTemp(i)),("" & UCase(arrTemp(i)) & ""))
 new_word = Left(arrTemp(i),1)
 new_word="" & arrTemp(i) & ""
 ReplaceText = Replace(ReplaceText,arrTemp(i),new_word)
 Next
 HighlightWords = ReplaceText
End Function

hl_words=Request("SearchParam")
%>

I think it's a matter of triming in the right place.

lucian · June 23rd, 2003, 02:02 AM

Sorry about the last reply. I went to bed, I wake-up and I relise I forgot to close the tag on ht e two line I added. what an idiot.

Thanks work perfect.

NotNowJohn · June 23rd, 2003, 02:54 AM

Well,
If some of the following words(span, class, highlight) occurs in the search string this function will not highlight this words correctly. In order ot work properly you can modify this func(without the parsing of input string):

Code:

Function HighlightWords2(SearchText,ReplaceText)
    arrTemp = Split(SearchText, " ")
    For i = 0 to UBOUND(arrTemp)
    new_word="#1" & arrTemp(i) & "#2"
        ReplaceText = Replace(ReplaceText,arrTemp(i),new_word)
    Next
    ReplaceText=Relace(ReplaceText,"#1","<b><span class=highlight>")
    ReplaceText=Relace(ReplaceText,"#2","</span></b>")
    HighlightWords2 = ReplaceText
End Function

...but the Soon is eclipsed by the Moon

lucian · June 23rd, 2003, 05:08 AM

I tryied those words and it does not seem to return anything bad.

Somebody said that to me before but I can not understand the meaning of it.

Anyhow, that's how the code looks like at the present which works fine:

...........
<%
Function RemoveExtraSpaces(orig_string)
 Do While InStr(1, orig_string, " ")
 orig_string = Replace(orig_string, " ", " ")
 Loop
 RemoveExtraSpaces=orig_string
End Function

Function HighlightWords(SearchText,ReplaceText)
 arrTemp = Split(SearchText, " ")
 For i = 0 to UBOUND(arrTemp)
 ReplaceText = replace(ReplaceText,LCase(arrTemp(i)),("" & LCase(arrTemp(i)) & ""))
 ReplaceText = replace(ReplaceText,UCase(arrTemp(i)),("" & UCase(arrTemp(i)) & ""))
 strS = Left(arrTemp(i),1)
 strS = UCase(strS) & Right(arrTemp(i),len(arrTemp(i))-1)
 new_word="" & strS & ""
 ReplaceText = Replace(ReplaceText,strS,new_word)
 Next
 HighlightWords = ReplaceText
End Function

hl_words=Request("SearchParam")
%>
..................
<%
 text = (rsSearch.Fields.Item("ProductName").Value)
 hl_words=Request("SearchParam")
'highlighted text:
Response.Write HighlightWords(RemoveExtraSpaces(hl_words),text)
%>

Thanks for everything and your help was really appreciated.

Louie

UHsoccer · August 27th, 2005, 09:32 AM

I just read your extensive discussion on replacing and thought you might be able to help me with the following:

From and Excel VB macro, I open a word document with many codes that I then replace with the actual text. Since it includes optional codes, I delete them with a blank space. Here is a sample of codes:

Document text start
XXrep1
XXrep2
XXrep3
XXrep4
XXrep5
Document text end

If I only use XXrep1="New TexT" and XXrep3="More Replaced text", it looks like

Document text start
New text

More Replaced text

Document text end

This is what I would like to see

Document text start
New text
More Replaced text
Document text end

How do I also remove the carriage return from the unused codes (2,4,5)?

Here is the code to replace unused codes
for jus = 1 To 5
        strFind = "XXrep" & jus & vbCr
        strReplace = ""
        Create_Word_Document_ReplaceText strFind, strReplace
Next jus

Instead of "vbcr" I also tried chr(10)

here are other combination that do not do anything

strFind = " " & vbCr & " " & vbCr
strFind = " " & Chr(10) & " " & Chr(10)

Here is the sub

    Sub Create_Word_Document_ReplaceText(ByVal strFind As String, ByVal strReplace As String)

' removed from "with wdDoc.Content.Find"
' .Font.Underline = wdUnderlineSingle
' .Font.Color = wdColorBlue
' .MatchWildcards = False ' HFV
' .MatchSoundsLike = False ' HFV
' .MatchAllWordForms = False ' HFV
         ' .ParagraphFormat = True ' HFV

        Dim errrCode As Integer
        wdDoc.Content.Select
        With wdDoc.Content.Find
            .ClearFormatting
            .Forward = True
            .MatchCase = True
            .MatchWholeWord = True
            .Wrap = wdFindContinue
            .Execute FindText:=strFind, _
               Replace:=wdReplaceAll, ReplaceWith:=strReplace
        End With
     Exit Sub
    End Sub