vbaexcelinternet-exploreroutlook

Copy contents of a webpage to Excel

My realtor sends me links to listings. There is no information in the email other than a link to his site.

I want to pull all of the particulars about each listing into Excel. MLS#, Address, # of bedrooms, price, etc.

I think I can figure out how to handle that once it is in Excel, but at the moment, I can't figure out how to do a select all on the IE page when I get there.

I have this code to get the link from Outlook into Excel:

Sub FollowLinkAddress()
Dim oDoc As Object
Dim h As Object
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String     
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
 
Set itm = ActiveInspector.CurrentItem
 If Application.ActiveExplorer.Selection.Count = 0 Then
     MsgBox "No Items selected!", vbCritical, "Error"
     Exit Sub
 End If
 On Error Resume Next
 Set xlApp = GetObject(, "Excel.Application")
 If Err <> 0 Then
     Application.StatusBar = "Please wait while Excel source is opened ... "
     Set xlApp = CreateObject("Excel.Application")
     bXStarted = True
 End If
 On Error GoTo 0
'Open Excel
Set xlWB = xlApp.Workbooks.Open("filepath")
Set xlSheet = xlWB.Sheets("Sheet1")
    rCount = xlSheet.UsedRange.Rows.Count
    'MsgBox rCount 'Used during testing
If itm.GetInspector.EditorType = olEditorWord Then
    Set oDoc = itm.GetInspector.WordEditor
    For Each h In oDoc.Hyperlinks
    'h.Follow
    'Process each selected record
       For Each olItem In Application.ActiveExplorer.Selection
         sText = olItem.Body
         vText = Split(sText, Chr(13))
         'MsgBox sText 'Again for testing
             'Check each line of text in the message body
                 For i = UBound(vText) To 0 Step -1
                      If InStr(1, vText(i), "sar.paragonrels.com/publink/default.aspx?GUID") > 0 Then
                        rCount = rCount + 1
                            vItem = Split(vText(i), Chr(34)) 'Chr34 is double quotes
                            xlSheet.Range("B" & rCount) = Trim(vItem(1))
                      End If
                 Next i
    '     xlWB.Save 
        Next olItem
    Next
End If

 If bXStarted Then
     xlApp.Quit
 End If
 Set xlApp = Nothing
 Set xlWB = Nothing
 Set xlSheet = Nothing
 Set olItem = Nothing
 End Sub

That part works if I run it from Outlook. I include it only because I'd eventually like to get the whole process into one place.

I was able to kluge together snippets from these links http://www.mrexcel.com/forum/excel-questions/534042-visual-basic-applications-copy-paste-not-web-query-open-web-page.html and http://www.jpsoftwaretech.com/excel-vba/automate-internet-explorer/ for the Excel portion:

Sub TestJH()
Dim Element As Object ' HTMLButtonElement
Dim btnInput As Object ' MSHTML.HTMLInputElement
Dim ElementCol As Object ' MSHTML.IHTMLElementCollection
Dim Link As Object ' MSHTML.HTMLAnchorElement
Dim strCountBody As Object
Dim lStartPos As Long
Dim lEndPos As Long
Dim TextIWant As String
Dim Lurl As String
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
Range("B7").Activate 'This is the link that is found at B7: http://sar.paragonrels.com/publink/default.aspx?GUID=bc3565b3-4b55-46e1-94bf-b8b68ee32ada&Report=Yes

Lurl = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate ' I want to paste the result in C7
IE.Visible = True
    With IE
    IE.Navigate Lurl
    On Error Resume Next
            Do While .ReadyState <> 4 Or .Busy
            Application.Wait (1)
            If Err.Number = -2147417848 Then Exit Do 'In case of client disconnect
            Loop
            On Error GoTo 0
'IE.ExecWB OLECMDID_SELECTALL, OLECMDEXECOPT_DONTPROMPTUSER
'IE.ExecWB OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT

' grab some text from the body
strCountBody = IE.Document.body.innerText
lStartPos = InStr(1, strCountBody, "View")
lEndPos = lStartPos + 1
TextIWant = Mid$(strCountBody, lStartPos, lEndPos - lStartPos)
ActiveSheet.Paste
End With
Set IE = Nothing
    
Loop

End Sub

It gives me

Run-time error '91':
Object variable or With block variable not set

at

strCountBody = IE.Document.body.innerText

I can click on the page and select all. Is there a way to get VBA to do the same thing?

Something I read made me think that the site may be using frames, but I don't know how to account for that.

How do I copy and paste the contents of a webpage.

Solution 
  • Sub TestJH()
Dim Element As Object ' HTMLButtonElement
Dim btnInput As Object ' MSHTML.HTMLInputElement
Dim ElementCol As Object ' MSHTML.IHTMLElementCollection
Dim Link As Object ' MSHTML.HTMLAnchorElement
Dim strCountBody As String
Dim lStartPos As Long
Dim lEndPos As Long
Dim TextIWant As String
Dim Lurl As String
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
Range("B7").Activate 'This is the link that is found at B7: http://sar.paragonrels.com/publink/default.aspx?GUID=bc3565b3-4b55-46e1-94bf-b8b68ee32ada&Report=Yes

Lurl = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate ' I want to paste the result in C7
IE.Visible = True
    With IE
    IE.navigate Lurl
    On Error Resume Next
            Do While .ReadyState <> 4 Or .Busy
            Application.Wait (1)
            If Err.Number = -2147417848 Then Exit Do 'In case of client disconnect
            Loop
            IE.navigate IE.document.frames.Item(3).Location
            Do While .ReadyState <> 4 Or .Busy
            Application.Wait (1)
            If Err.Number = -2147417848 Then Exit Do 'In case of client disconnect
            Loop
            On Error GoTo 0
'IE.ExecWB OLECMDID_SELECTALL, OLECMDEXECOPT_DONTPROMPTUSER
'IE.ExecWB OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT

' grab some text from the body
strCountBody = IE.document.body.innerText
lStartPos = InStr(1, strCountBody, "View")
lEndPos = lStartPos + 1
TextIWant = Mid$(strCountBody, lStartPos, lEndPos - lStartPos)
ActiveCell = TextIWant
End With
IE.Quit
Set IE = Nothing

End Sub

    I did the following: