VBA 从 Outlook 到 Excel 到 IE 并返回到 Excel

Question

这是我第一次 post 使用 Whosebug，所以请放轻松。我知道 VBA 足够危险，主要是 Excel，到目前为止，我通常能够将代码片段拼凑在一起以完成我需要的事情。

我当前的编程问题是，我的房地产经纪人每天都会向我发送 link 列表，但是电子邮件中除了 link 到他的站点之外没有任何信息。我希望能够将每个列表的所有详细信息提取到 Excel 中。（MLS#、地址、卧室数量、价格等）我想一旦它进入 Excel，我就能想出如何处理它，但目前，我不知道如何做select 当我到达那里时，所有内容都在 IE 页面上。我有这段代码可以从 Outlook 中获取 link 到 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

如果我从 Outlook 中运行那部分工作正常。我把它包括在内只是因为我最终想把整个过程放在一个地方。

我能够将这些 link 中的片段拼凑在一起 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/ 这是我现在的 Excel 部分：

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

问题是它给我“运行-time error '91': 未在 "strCountBody = IE.Document.body.innerText"

处设置对象变量或 With 块变量

我可以点击页面和 select 所有，那么有没有办法让 VBA 做同样的事情？我读到的东西让我认为该网站可能正在使用框架，但我不知道如何解释。最后，我想看看我是否可以从 VBA 的一个实例运行整个过程，但现在，我真的需要弄清楚如何复制和粘贴网页内容。有人可以帮忙吗？

TIA！

Answer 1

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

我做了以下事情：

删除了末尾的Loop
将 strCountBody 更改为字符串类型
设置ActiveCell = TextIWant而不是粘贴
处理了 HTML 帧

VBA 从 Outlook 到 Excel 到 IE 并返回到 Excel

VBA Hand-off from Outlook to Excel to IE and back to Excel

excel

outlook

internet-explorer

vba