使用VBA从Internet Explorer检索URL

Question

我在Excel中编写了一些VBA代码，从谷歌地图URL中检索纬度和经度，并将其粘贴到工作表中的单元格中。我的问题是从internet explorer中检索URL。下面我有两个代码示例，一个宏返回about:black，就好像对象没有LocationURL属性一样，另一个示例似乎保存了我以前的所有搜索，所以它循环浏览我以前的全部搜索并粘贴第一个搜索的URL。示例2使用我在网上找到的shell建议将属性重新分配给oIE对象。我可以让两者都做一些小的工作，但两者都不能从宏观上做我需要的事情。

Cell(8,8(是我搜索地址的谷歌地图的超链接，Cell(8，9(是我想在谷歌地图重定向并在URL中包含纬度和经度后粘贴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

谢谢，Andrew

Answer 1

这就像循环直到文档一样简单吗。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