Question

这是我在Stackoverflow上的第一篇文章，所以请你放轻松。我知道VBA足够危险，主要是在Excel中，到目前为止，我通常能够将代码片段拼凑在一起，以便做我需要的东西。

我目前的编程问题是我的房地产经纪人每天都会向我发送列表链接，但除了链接到他的网站之外，电子邮件中没有任何信息。我希望能够将每个列表的所有细节都提取到Excel中。（MLS＃，地址，卧室数量，价格等）我想我可以弄清楚如何在Excel中处理它，但此刻，我无法弄清楚如何在我到达那里的IE页面。我有这段代码来获取从Outlook到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运行它，那部分工作正常。我之所以加入它只是因为我最终希望将整个过程放到一个地方。

我能够将这些链接http://www.mrexcel.com/forum/excel-questions/534042-visual-basic-applications-copy-paste-not-web-query-open-web-page.html和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

问题是它给了我“运行时错误'91'：对象变量或With块变量未设置为“strCountBody = IE.Document.body.innerText”

我可以点击页面并选择全部，那么有没有办法让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更改为String类型
设置ActiveCell = TextIWant而不是粘贴
处理HTML框架

VBA从Outlook切换到Excel再到IE并返回Excel

1 个答案: