Question

我一直在努力解决这个问题，并试图在StackOverflow中找到解决方案，但没有任何帮助。

我有成千上万的图像链接（A列），可以将您带到最终的JPG URL。这不是重定向链接，因为我尝试过使用其他网站，但无法检测到它。

这里是一个示例： https://www.pepperl-fuchs.com/global/en/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和循环第一个维度来比循环工作表更快，那么

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

这确实假定您的所有链接都遵循与第一个相同的模式。

使用Excel VBA获取最终URL

3 个答案: