将Excel中的图片保存到文件中

Question

我有一个 Excel，我在其中导入一些图片（从 onedrive 文件中，它们作为查询的一部分上传）。这些图片是我将从 Excel 文件生成的自动回复 PDF 的一部分，效果很好。

但是，我也想将图片本身保存在驱动器上的某个位置，但我（显然）遇到了图片格式/我自己非常有限的 VBA 知识方面的限制。

'Put in new picture, save, copy to appropriate location


PicPath = Worksheets("Transfersheet").Range("PHOTOLD1URL").Value


Set myPicture = Worksheets("Lay-out").Pictures.Insert(PicPath)
    
    With myPicture
        .ShapeRange.LockAspectRatio = msoTrue
        .Height = Worksheets("Lay-out").Range("B24:F34").Height
        .Top = Worksheets("Lay-out").Range("B24:F34").Top
        .Left = Worksheets("Lay-out").Range("B24:F34").Left
    End With

知道是否有一种快速解决方法可以将“myPicture”写入文件？

Answer 1

根据评论和回复，似乎您最好将该文件下载到您自己的驱动器，然后然后将其导入 Excel。 您还指出，由于您使用的是网络资源，因此不能使用

FileCopy

。

因此，以下代码用于通过 Internet 下载文件并将其保存到计算机上的某个位置：

Public Function DownloadFile(ByVal DownloadURL As String, ByVal SaveAsLocation As String) As Boolean
    DownloadFile = False
    On Error GoTo FuncErr
    
    Dim WinHttpReq As Object, oStream As Object
    Set WinHttpReq = CreateObject("MSXML2.XMLHTTP")
    WinHttpReq.Open "GET", DownloadURL, False
    WinHttpReq.Send
    
    If WinHttpReq.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile SaveAsLocation, 2 ' 1 = no overwrite, 2 = overwrite
        oStream.Close
    End If

    DownloadFile = True
FuncErr:
    On Error Resume Next
    oStream.Close
    WinHttpReq.Close
    On Error GoTo -1
    On Error GoTo 0
    Set oStream = Nothing
    Set WinHttpReq = Nothing
End Function

然后你可以像这样使用它：

PicPath = Worksheets("Transfersheet").Range("PHOTOLD1URL").Value
DestPath = Worksheets("Transfersheet").Range("PHOTOLD1Dest").Value 

If DownloadFile(PicPath, DestPath) Then
    With Worksheets("Lay-out").Pictures.Insert(DestPath)
        .ShapeRange.LockAspectRatio = msoTrue
        .Height = Worksheets("Lay-out").Range("B24:F34").Height
        .Top = Worksheets("Lay-out").Range("B24:F34").Top
        .Left = Worksheets("Lay-out").Range("B24:F34").Left
    End With
Else
    MsgBox "Unable to download Picture!" & vbCrLf & vbCrLf & PicPath, vbCritical, "Picture Import Error"
End If