Excel从URL插入图片VBA宏无法加载NetSuite图片问题求助

故障根因 #

• NetSuite近期更新了静态资源访问安全策略，要求请求必须携带合法的请求头（如浏览器User-Agent、有效会话凭证）
• 原宏中调用的Shapes.AddPicture内置方法发送的HTTP请求无合规请求头，被NetSuite拦截导致下载失败
• Shopify CDN为公开无校验资源，因此不受影响仍可正常使用
• 原宏中On Error Resume Next配置会吞掉所有运行报错，无法直接看到被拦截的具体错误提示

修复后代码 #

Sub Netsuite_Image_ATS()
    Dim Pshp As Shape
    Dim xRg As Range
    Dim xCol As Long
    Dim filenam As String
    Dim http As Object
    Dim stream As Object
    Dim tempPath As String
    
    ' 临时文件存储路径
    tempPath = Environ("TEMP") & "\temp_netsuite_img.jpg"
    
    ' 初始化WinHTTP对象（晚绑定，无需手动加引用）
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
    Set stream = CreateObject("ADODB.Stream")
    
    On Error Resume Next
    Application.ScreenUpdating = False
    Set Rng = ActiveSheet.Range("B2", Range("B" & Rows.Count).End(3)(1))
    
    For Each cell In Rng
        filenam = cell.Value
        If filenam <> "" Then
            xCol = cell.Column + 1
            Set xRg = Cells(cell.Row, xCol)
            
            ' 发送带请求头的HTTP请求拉取图片
            http.Open "GET", filenam, False
            ' 模拟浏览器请求头，绕过NetSuite基础校验
            http.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/118.0.0.0 Safari/537.36"
            http.Send
            
            ' 如果请求成功，保存到临时文件
            If http.Status = 200 Then
                stream.Type = 1 ' 二进制类型
                stream.Open
                stream.Write http.ResponseBody
                stream.SaveToFile tempPath, 2 ' 覆盖现有文件
                stream.Close
                
                ' 从临时文件插入图片
                ActiveSheet.Shapes.AddPicture Filename:=tempPath, _
                    LinkToFile:=msoFalse, SaveWithDocument:=msoCTrue, _
                    Left:=xRg.Left + (xRg.Width - 100) / 2, _
                    Top:=xRg.Top + (xRg.Height - 100) / 2, _
                    Width:=100, _
                    Height:=100
                
                ' 删除临时文件
                Kill tempPath
            End If
        Else
            Set Pshp = Nothing
            Range("B2").Select
        End If
        ThisWorkbook.Save
    Next
    
    ' 释放对象
    Set http = Nothing
    Set stream = Nothing
    
    Application.ScreenUpdating = True
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    Range("A" & Rows.Count).End(3)(2).EntireRow.Delete
End Sub

可选配置说明 #

如果你的NetSuite资源需要登录后才能访问，可在http.Send代码前新增一行，填入你浏览器登录NetSuite后获取的有效Cookie即可：

http.SetRequestHeader "Cookie", "你浏览器中复制的NetSuite登录Cookie内容"

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