Excel VBA 使用WinHttp获取重定向URL的Sub实现及代码适配咨询

改动逻辑说明 #

• 关闭WinHttp自动重定向开关，先发起轻量HEAD请求检测响应状态，避免直接下载浪费带宽
• 兼容全量常见重定向状态码（301/302/303/307/308），不再仅匹配301
• 解析响应头时自动清理多余空格、回车字符，相对路径自动拼接原URL域名，避免后续下载报错
• 抓取到的最终URL自动写入对应单元格右侧相邻列（B列），无需手动调用额外函数
• 保留原有下载逻辑、本地文件夹自动创建、WinHttp版本兼容兜底

Sub Printdrawings()
    Dim WB As Workbook
    Dim WS As Worksheet
    Dim ROWS As Long
    Dim RNG As Range
    Dim CLL As Range
    Dim FileNum As Long
    Dim FileData() As Byte
    Dim MyFile As String
    Dim FinalURL As String
    Dim WHTTP As Object
    Dim FileName As String
    Dim respHeaders As Variant
    Dim headerLine As Variant
    Dim redirectLoc As String
    ' 固定WinHttp配置常量
    ' 选项索引6：控制是否启用自动重定向
    Const WinHttpOpt_EnableRedirect As Integer = 6
    Const BaseURL As String = "http://URLBODY" ' 替换为你的实际URL前缀
    
    Set WB = ThisWorkbook
    Set WS = WB.Sheets("Sheet1")
    
    ' 计算A列已使用行数
    ROWS = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
    Set RNG = WS.Range("A1:A" & ROWS)
    
    ' 提前创建下载文件夹
    If Dir("C:\MyDownloads", vbDirectory) = "" Then MkDir "C:\MyDownloads"
    
    For Each CLL In RNG
        ' 兼容不同版本WinHttp创建
        On Error Resume Next
        Set WHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
        If Err.Number <> 0 Then
            Set WHTTP = CreateObject("WinHttp.WinHttpRequest.5")
        End If
        On Error GoTo 0
        
        MyFile = BaseURL & CLL.Value
        FinalURL = MyFile ' 默认无重定向时用原URL
        
        ' 关闭自动重定向，先检测跳转
        WHTTP.Option(WinHttpOpt_EnableRedirect) = False
        WHTTP.Open "HEAD", MyFile, False
        WHTTP.Send
        
        ' 匹配所有重定向状态码
        If WHTTP.Status >= 301 And WHTTP.Status <= 308 Then
            ' 拆分响应头按行解析
            respHeaders = Split(WHTTP.getAllResponseHeaders(), vbCrLf)
            For Each headerLine In respHeaders
                If LCase(Left(headerLine, 9)) = "location:" Then
                    ' 提取并清理Location字段
                    redirectLoc = Trim(Mid(headerLine, 10))
                    ' 处理相对路径
                    If Left(redirectLoc, 4) <> "http" Then
                        ' 拼接原URL的域名部分
                        Dim baseDomain As String
                        Dim splitIdx As Integer
                        splitIdx = InStr(8, MyFile, "/")
                        baseDomain = Left(MyFile, splitIdx - 1)
                        If Left(redirectLoc, 1) = "/" Then
                            redirectLoc = baseDomain & redirectLoc
                        Else
                            redirectLoc = baseDomain & "/" & redirectLoc
                        End If
                    End If
                    FinalURL = redirectLoc
                    Exit For
                End If
            Next
        End If
        
        ' 将最终URL写入当前行B列
        CLL.Offset(0, 1).Value = FinalURL
        
        ' 发起GET请求下载文件
        WHTTP.Option(WinHttpOpt_EnableRedirect) = True ' 下载时开启自动跳转，避免漏下
        WHTTP.Open "GET", FinalURL, False
        WHTTP.Send
        FileData = WHTTP.ResponseBody
        Set WHTTP = Nothing
        
        ' 生成文件名（可根据需要调整规则）
        FileName = Right(FinalURL, 12)
        ' 清理文件名中的非法字符
        FileName = Replace(Replace(FileName, "/", ""), "\", "")
        ' 写入本地PDF
        FileNum = FreeFile
        Open "C:\MyDownloads\" & FileName & ".pdf" For Binary Access Write As #FileNum
            Put #FileNum, 1, FileData
        Close #FileNum
    Next CLL
    
    MsgBox "下载完成，请查看 C:\MyDownloads 文件夹"
End Sub

使用说明 #

• 替换代码中BaseURL常量为你实际的URL拼接前缀
• 若重定向URL写入的列不是B列，可修改CLL.Offset(0, 1).Value中的列偏移参数（比如要写到C列就把1改成2）
• 下载时开启了WinHttp自动重定向，避免遇到多层跳转导致下载失败
• 新增了文件名非法字符清理逻辑，避免因路径问题导致保存报错

内容的提问来源于stack exchange，提问作者LIrahara