WebBrowser控件中实现查找关键字和高亮关键字

VB在WebBrowser控件中实现查找关键字和高亮关键字

Dim webdoc As HTMLDocument Dim texbody As HTMLBody Dim Rng As IHTMLTxtRange Dim Str1 as String,Str2 as String Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant) '将webdoc设置到被WebBrowser的Document属性返回的文挡对象中 Set webdoc = WebBrowser1.document End Sub Private Sub Form_Load() WebBrowser1.navigate "http://search.msn.com/results.asp?q=wordlist" End Sub Private Sub Command2_Click() '高亮显示关键字 On Error Resume Next Set texbody = webdoc.body Set Rng = texbody.createTextRange() Do While Rng.findText(Text1.Text) <> False Rng.findText Text1.Text Rng.Select Rng.pasteHTML "<span style='background:Blue'>" + Text1.Text + "</span>" ' '用IHTMLTxtRange的execCommand方法可以实现加粗等功能，如： 'Rng.execCommand "bold" 'Rng.execCommand "underline" 'Rng.execCommand "italic" '参看MSDN>DHTML Reference>Command Identifers ' Rng.collapse False Loop Rng.collapse True End Sub Private Sub Command2_Click() call FindWord(Text1.text,webdoc,Str1,Str2) end sub FindWord函数还有一点问题，就是在个别页面查找关键字时要几次，不晓得是什么原因,我看那些出名的浏览器都有这个问题,比如360，世界之窗等！ '************************************************************************* '**函 数 名：FindWord '**输    入：Word(String)              - '**        ：nDoc(MSHTML.HTMLDocument) - '**        ：nPosBM(String)            - '**        ：nPosBM1(String)           - '**输    出：(Boolean) - '**功能描述：搜索并选择HTML文档,使用该函数前须引用MSHTML.tlb '**          （工程-引用- Microsoft HTML Object Library） '**全局变量： '**调用模块： '**作    者：未知 '**日    期：2009-01-01 15:42:45 '**修 改 人：陈峰 '**日    期： '**版    本：V1.0.0 '************************************************************************* Public Function FindWord(Word As String, nDoc As MSHTML.HTMLDocument, nPosBM As String, nPosBM1 As String) As Boolean     Dim texbody As HTMLBody     Dim Rng As MSHTML.IHTMLTxtRange     Dim Rng1 As MSHTML.IHTMLTxtRange                                                                                              On Error Resume Next     Set texbody = nDoc.body     Set Rng = texbody.createTextRange()     Set Rng1 = texbody.createTextRange()     If LenB(nPosBM) > 0 Then         Rng.moveToBookmark (nPosBM)         Rng.moveStart "character", 1         Rng1.moveToBookmark (nPosBM1)         Rng1.moveStart "character", 1     End If     If Rng.findText(Word) Then         nPosBM = Rng.getBookmark         Rng.Select         FindWord = True '----------------处理搜索到最后时，标志位还没有返回顶部，这里用移位搜索来解决--------------         If LenB(nPosBM1) = 0 Then   '如果nPosBM1=空             nPosBM1 = Rng.getBookmark '将nPosBM1=Rng搜索第一次的字符位             Rng1.moveToBookmark (nPosBM1) 'Rng1搜索第一次的标志为移动到nPosBM1字符首位             Rng1.moveStart "character", 1         End If         If Rng1.findText(Word) Then             nPosBM1 = Rng1.getBookmark             FindWord = True         Else             nPosBM1 = vbNullString             nPosBM = vbNullString             FindWord = True         End If     Else         nPosBM = vbNullString         FindWord = False     End If End Function