With some tweaking, this may help:
sResult = gfGetHTMLTableCellVal(WebB
Public Function gfGetHTMLTableCellVal(webX
Dim Tbl As HTMLTable
Dim trRow As HTMLTableRow
Dim trTD As HTMLTableCell
For Each Tbl In webX.Document.All
If UCase$(Tbl.tagName) = "TABLE" Then
If Tbl.rows.length > 0 Then
If bInStr Then
'Debug.Print Tbl.rows(lRow).cells(lCol)
'If InStr(1, Tbl.rows(lRow).cells(lCol)
If InStr(1, UCase(Tbl.innerText), UCase(sSearchString)) > 0 Then
'For Each trRow In Tbl.All
For Each trTD In Tbl.All
If InStr(1, UCase(trTD.innerText), UCase(sSearchString)) > 0 Then
gfGetHTMLTableCellVal = trTD.innerText
'trTD.scrollIntoView (trTD.scrollTop - 400)
trTD.scrollIntoView (trTD.scrollTop)
End If
Next
Exit For
End If
Else
'Debug.Print Mid(Tbl.rows(lRow).cells(l
If UCase(Mid(Tbl.rows(lRow).c
gfGetHTMLTableCellVal = Tbl.rows(lRow).cells(lCol)
Exit For
End If
End If
End If
End If
Next
End Function
Main Topics
Browse All Topics
by: wesbirdPosted on 2005-06-17 at 08:49:01ID: 14242172
Here's an example from something similar in access VBA which should help you to figure the DOM:
You must remember to include shdocvw.dll in your project references/components.
**************************
Option Compare Database
Dim WithEvents doc As HTMLDocument
Dim WithEvents win As HTMLWindow2
Dim cmd As ADODB.Command
Dim rs As ADODB.Recordset
Dim id As Long
Dim fn As Long
Function StartsLike(strRef, strTest) As Boolean
If Left(strTest, Len(strRef)) = strRef Then
StartsLike = True
Else
StartsLike = False
End If
End Function
Private Sub Command1_Click()
WebBrowser1.Navigate2 "http://www.yoursite.com/p
End Sub
Private Sub WebBrowser1_DownloadBegin(
Dim htm As IHTMLDocument2
Dim htmwin As IHTMLWindow2
Dim strArr As Variant
On Error Resume Next
Set doc = WebBrowser1.Document
Set win = htm.parentWindow
End Sub
Private Sub WebBrowser1_DocumentComple
Dim htm As IHTMLDocument2
Dim htmwin As IHTMLWindow2
Dim strArr As Variant
Dim hi As IHTMLElement
On Error Resume Next
Set doc = WebBrowser1.Document
Set cmd2 = New ADODB.Command
cmd2.ActiveConnection = CurrentProject.Connection
For Each hi In doc.body.all
If bKeep Then
If hi.nodeName = "TD" Then
If Trim(hi.innerText) <> "" Then
fn = fn + 1
If fn = 1 Then
cmd.CommandText = "INSERT INTO Addr (ID, Addr1 ) " & _
"VALUES( " & CStr(id) & ", " & Chr(34) & Trim(hi.innerText) & Chr(34) & ")"
Else
cmd.CommandText = "UPDATE Addr SET Addr" & CStr(fn) & " = " & Chr(34) & Trim(hi.innerText) & Chr(34) & " WHERE ID = " & CStr(id)
End If
cmd.Execute
End If
End If
End If
If hi.nodeName = "TD" Then
strTmp = ""
If StartsLike("Name", hi.innerText) Then
Debug.Print hi.nextSibling.innerText
bKeep = True
fn = 0
End If
End If
If hi.nodeName = "P" Then
If StartsLike("Organization",
Debug.Print
bKeep = False
End If
End If
Next hi
If Not rs.EOF Then
rs.MoveNext
WebBrowser1.Navigate2 "http://nextsite/nextpage.
id = id + 1
End If
' End If
Set cmd2 = Nothing
End Sub