使用 VBA 从 Internet Explorer 检索 URL

Question

我在 Excel 中编写了一些 VBA 代码，以从 Google 地图 URL 中检索纬度和经度，并将其粘贴到我工作表中的单元格中。我的问题是从 Internet Explorer 中检索 URL。下面我有两个代码示例，一个宏返回 about:blank 好像该对象没有 LocationURL 属性，另一个示例似乎保存了我以前的所有搜索，因此它循环遍历我的所有以前的搜索并粘贴第一次搜索的 URL。示例 2 使用我在网上找到的 shell 建议将属性重新分配给 oIE 对象。我可以让两者都稍微工作，但两者都不能完全满足我对宏的需要。

Cell(8,8) 是指向我正在搜索地址的谷歌地图的超链接，而 Cell(8,9) 是我想要在谷歌地图重定向后粘贴 URL 的位置，并且在其中包含纬度和经度网址。

示例 1：

Sub CommandButton1_Click()

Dim ie As Object
Dim Doc As HTMLDocument

Set ie = CreateObject("InternetExplorer.Application")

ie.Visible = True
ie.Navigate "http://www.google.com/maps?q=" & Range("I7").Value
Do
DoEvents
Loop Until ie.ReadyState = 4

Set Doc = ie.Document

Cells(8, 9).Value = ie.LocationName

End Sub

示例 2：

Sub Macro()
Dim oIE, oShell, objShellWindows, strPath, X

strPath = Cells(8, 8)

Set oIE = CreateObject("InternetExplorer.Application")

'This is to resolve oIE.navigate "about:blank" issue
oIE.Top = 0
oIE.Left = 0
oIE.Width = 500
oIE.Height = 500

oIE.Navigate strPath

Do While oIE.Busy And oIE.ReadyState < 2
    DoEvents
Loop

'Reassigning oIE.LocationName & vbCrLf & oIE.LocationURL values after redirect in IE

Set oShell = CreateObject("WScript.Shell")
Set objShellWindows = CreateObject("Shell.Application").Windows
For X = objShellWindows.Count - 1 To 0 Step -1
    Set oIE = objShellWindows.Item(X)
    If Not oIE Is Nothing Then
        If StrComp(oIE.LocationURL, strPath, 1) = 0 Then
            Do While oIE.Busy And oIE.ReadyState < 2
                DoEvents
            Loop
            oIE.Visible = 2
            Exit For
        End If
    End If
    Cells(8, 9).Value = oIE.LocationURL
    Set oIE = Nothing
Next
Set objShellWindows = Nothing
Set oIE = Nothing

End Sub

谢谢， 安德鲁

Answer 1

这就像循环直到 document.URL 改变一样简单吗？在我的定时循环中，我等待原始页面加载中的字符串 safe=vss 消失。

Option Explicit    
Public Sub GetNewURL()
    Dim IE As New InternetExplorer, newURL As String, t As Date
    Const MAX_WAIT_SEC As Long = 5

    With IE
        .Visible = True
        .navigate2 "http://www.google.com/maps?q=" & "glasgow" '<==Range("I7").Value

        While .Busy Or .readyState < 4: DoEvents: Wend
        t = Timer
        Do
            DoEvents
            newURL = .document.URL
            If Timer - t > MAX_WAIT_SEC Then Exit Do
        Loop While InStr(newURL, "safe=vss") > 0

        Debug.Print newURL       
    End With 
End Sub