Private Sub Form_Load()
Me.axcWebBrowser.Navigate "[URL unfurl="true"]http://www.bankrate.com/brm/rate/mtg_ratehome.asp?"[/URL] & _
"params=165000,CO,44&product=1&pType=f&refi=0&sort=3&points=6"
End Sub
Private Sub Command1_Click()
Dim colTables As Object
'Get the table with the data and output as a file
Set colTables = axcWebBrowser.Document.All.tags("TABLE")
CreateBarDelimitedFile colTables(22).innerHTML
Set colTables = Nothing
'Import the file
ImportData
End Sub
Sub CreateBarDelimitedFile(HTMLTable As String)
Dim blnCapture As Boolean, blnInTag As Boolean
Dim lngItem As Long
Dim intFile As Integer, intNestledTable As Integer
Dim strHTML As String, strOutput As String
intFile = FreeFile
Open CurrentProject.Path & "\Bankrate_webpull.txt" For Output As #intFile
'cycle trough the contents one character at a time
For lngItem = 1 To Len(HTMLTable)
'Starting a tag so ingore the character until text ends
If Mid(HTMLTable, lngItem, 1) = "<" Then
blnInTag = True
End If
'They nestled a table in the one we want, keep track to know
'when the current row ends
If Mid(HTMLTable, lngItem, 6) = "<TABLE" Then
intNestledTable = intNestledTable + 1
lngItem = lngItem + 6
End If
'Current character is not in a tag so check to see if it
'should be captured
If Not blnInTag Then
'Test to see if the current character begins a special character
If Mid(HTMLTable, lngItem, 1) = "&" Then
'Most* HTML special characters start with '&' and end ';' so
'skip over them
Do
lngItem = lngItem + 1
Loop Until Mid(HTMLTable, lngItem, 1) = ";"
Else
'it dosen't so capture the character
strOutput = strOutput & Mid(HTMLTable, lngItem, 1)
End If
End If
'we are at the end of a row so put in a delimiting character '|'
If Mid(HTMLTable, lngItem, 3) = "<TD" Then
strOutput = strOutput & "|"
lngItem = lngItem + 3
End If
'Cycled through all the nestled tables and the row delimiter
'has been reached so write to the output file
If Mid(HTMLTable, lngItem, 3) = "<TR" And intNestledTable = 0 Then
'to keep the output on the same line remove the line feeds
strOutput = Replace(strOutput, vbCrLf, "")
'Make sure there is data to write
If Len(strOutput) <> 0 Then
Print #intFile, strOutput
End If
'clear the output in preperation for the next line
strOutput = ""
lngItem = lngItem + 3
End If
'update the nested table pointer
If Mid(HTMLTable, lngItem, 8) = "</TABLE>" Then
intNestledTable = intNestledTable - 1
lngItem = lngItem + 8
End If
'Probably reached the end of the tag
If Mid(HTMLTable, lngItem, 1) = ">" Then
blnInTag = False
End If
Next lngItem
Close #intFile
End Sub
Sub ImportData()
On Error GoTo ImportData_Error
'This will load the data stored in the bar delimited text file
'CurrentProject.Path & "\Bankrate_webpull.txt" into table
'tblBankrate_webpull. Will create the table if it doesn't exist
Dim dbsCurrent As DAO.Database
Dim rstDestination As DAO.Recordset
Dim intFile As Integer
Dim stSQL As String
Dim strLine As String, strRecord() As String
intFile = FreeFile
Set dbsCurrent = CurrentDb
Set rstDestination = dbsCurrent.OpenRecordset("tblBankrate_webpull")
Open CurrentProject.Path & "\Bankrate_webpull.txt" For Input As #intFile
Do
Line Input #intFile, strLine
strRecord = Split(strLine, "|")
If IsDate(strRecord(6)) Then
With rstDestination
.AddNew
.Fields("Lender") = strRecord(3)
.Fields("RateDate") = strRecord(6)
.Fields("APR") = strRecord(7)
.Fields("Discount") = Left(strRecord(8), InStr(strRecord(8), "/") - 1)
.Fields("Points") = Mid(strRecord(8), InStr(strRecord(8), "/") + 1)
.Fields("Rate") = strRecord(9)
.Fields("Fees") = strRecord(10)
.Fields("Lock") = strRecord(11)
.Fields("Est_Payment") = strRecord(12)
.Fields("Comments") = strRecord(13)
.Update
End With
End If
Loop Until EOF(intFile)
Clean_Up:
Close #intFile
rstDestination.Close
Set rstDestination = Nothing
Set dbsCurrent = Nothing
Exit Sub
ImportData_Error:
Select Case Err.Number
Case 3078
'The Microsoft Jet database engine cannot find the input
'table or query 'tblBankrate_webpull'.
'Probably first run, create the table
CreateTable
Resume
Case 3022
rstDestination.CancelUpdate
Resume Next
Case Else
Debug.Print Err.Number, Err.Description
Err.Raise Err.Number
End Select
Resume Clean_Up
End Sub
Sub CreateTable()
'This is a run once procedure that will create a new table
'the first time the Button1 is clicked
Dim strSQL As String
strSQL = "CREATE TABLE tblBankrate_webpull (Lender char(50)," & _
" RateDate DateTime," & _
" APR double," & _
" Discount double," & _
" Points double, " & _
" Rate double," & _
" Fees currency," & _
" Lock integer," & _
" Est_Payment currency," & _
" Comments char," & _
" CONSTRAINT TableKeys PRIMARY KEY (Lender, RateDate));"
DoCmd.RunSQL strSQL
End Sub
