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