使用Excel VBA獲取最終URL

Question

我一直在努力解決這個問題，並試圖在StackOverflow中找到解決方案，但沒有任何幫助。

我有成千上萬的圖像鏈接（A列），它將使您到達最終的JPG URL。 它不是重定向鏈接，因為我嘗試了其他網站，但未檢測到它。

這是一個示例： https : //www.pepperl-fuchs.com/global/zh/doci.htm?docilang=ENG&view=showproductpicbypartno&partno=000046

它將帶您到這里： https : //files.pepperl-fuchs.com/webcat/navi/productInfo/pd/d428540a.jpg

因此，我想推斷出B列中的所有最終鏈接。我找到了一些為每個鏈接打開IE的代碼，但它可能缺少復制URL並將其粘貼到單元格中的功能：

Sub Test()

    Dim IE As Object
    Dim URL As Range
    Dim objDocument As Object
    Dim x As Integer

    Set IE = CreateObject("InternetExplorer.Application")

    With IE
        .Visible = True
        For Each URL In Range("A2:A16")
            .Navigate URL.Value
            While .busy Or .ReadyState <> 4: DoEvents: Wend

            If LCase(TypeName(objDocument)) = "htmldocument" Then
            Cells(A, 1).Value = objDocument.URL
            Cells(A, 2).Value = objDocument.Title
            x = x + 1
            End If

        Next
    End With

End Sub

你們可以幫我弄清楚丟失了什么嗎？ 不幸的是，我對VBA並不是很熟悉。

非常感謝你

Answer 1

嘗試這個

Sub Test()

    Dim IE As Object
    Dim URL As Range
    Dim objDocument As Object
    Dim x As Integer

    Set IE = CreateObject("InternetExplorer.Application")

    With IE
        .Visible = True

        For Each URL In Range("A2:A16")
            .Navigate URL.Value
            While .busy Or .ReadyState <> 4: DoEvents: Wend

            URL.Offset(, 1).Value = .LocationURL
        Next
    End With

End Sub

Answer 2

試試這個代碼

Sub Test()
Dim html        As HTMLDocument
Dim ie          As Object
Dim objDocument As Object
Dim url         As Range
Dim x           As Integer

Set ie = CreateObject("InternetExplorer.Application")
x = 1

With ie
    .Visible = True
    For Each url In Range("A2:A3")
        .navigate url.Value
        While .Busy Or .readyState <> 4: DoEvents: Wend
        Set html = .document

        x = x + 1
        Cells(x, 2).Value = html.url
        Cells(x, 3).Value = html.Title
    Next url
End With
End Sub

Answer 3

需要更多的測試，但這會更快，並且如果您可以通過使用Dim arr(): arr = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value輕松地使用數組循環比循環工作表更快，則可以Dim arr(): arr = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value並循環第一個維度。

Option Explicit
Public Sub GetInfo()
    Dim rng As Range
    With Worksheets("Sheet1")
        For Each rng In .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
            If InStr(rng.Value, "http") > 0 Then Debug.Print GetURL(rng.Value)
        Next
    End With
End Sub
Public Function GetURL(ByVal url As String) As String
    Dim sResponse As String, s As Long, e As Long
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", url, False
        .send
        sResponse = StrConv(.responseBody, vbUnicode)
    End With
    s = InStr(1, sResponse, "https")
    e = InStr(1, sResponse, ".jpg") + 4
    GetURL = Mid(sResponse, s, e - s)
End Function

這確實假定您的所有鏈接都遵循與第一個相同的模式。