Question

我使用下面的代码从收到的Outlook邮件中下载文件。

收到的邮件有几个链接。一个超链接包含“下载”一词，并包含要下载的文件。

下载文件的大小始终为9KB或10KB。实际文件大小为10或12 MB。由于文件未正确下载，我无法打开文件。

Option Explicit

#If VBA7 Then
 Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias 
  "URLDownloadToFileA" _
                        (ByVal pCaller As LongPtr, _
                        ByVal szURL As String, _
                        ByVal szFileName As String, _
                        ByVal dwReserved As LongPtr, _
                        ByVal lpfnCB As LongPtr) As LongPtr



#Else
Private Declare Function URLDownloadToFile Lib "urlmon" Alias 
"URLDownloadToFileA" _
                        (ByVal pCaller As Long, _
                        ByVal szURL As String, _
                        ByVal szFileName As String, _
                        ByVal dwReserved As Long, _
                        ByVal lpfnCB As Long) As Long
#End If


Sub ExportAllHyperlinksandDownload()
Dim objSelection As Selection
Dim objMail As MailItem
Dim objMailDocument As Document
Dim objHyperlink As Hyperlink
Dim url As String
Dim HttpReq As Object
Dim Ret As Long

Set objSelection = Outlook.Application.ActiveExplorer.Selection

If Not (objSelection Is Nothing) Then
    For Each objMail In objSelection
        Set objMailDocument = objMail.GetInspector.WordEditor
        If objMailDocument.Hyperlinks.Count > 0 Then
            url = objMailDocument.Hyperlinks(5).Address
            Ret = URLDownloadToFile(0, url, "C:\Temp\" & objMailDocument.Hyperlinks(5).TextToDisplay, 0, 0)
            If Ret = 0 Then
                MsgBox ("Files Downloaded !")
            Else
                MsgBox ("Error in Download! Please try again later !")
            End If
        End If
    Next
End If
End Sub

Answer 1

我拿了您的代码并进行了一点升级，以从选定的电子邮件中下载每个链接，不仅下载了第5个链接，而且还给出了文件的正确名称（文件名与下载源中的文件名称相同），并且可以正常工作对我来说。

Sub ExportAllHyperlinksandDownload()
Dim objSelection As Selection
Dim objMail As MailItem
Dim objMailDocument As Object
Dim objHyperlink As Hyperlink
Dim hlink As Hyperlink
Dim url As String
Dim HttpReq As Object
Dim ret As LongPtr
Dim xmlhttp As New MSXML2.XMLHTTP60
Dim i As Long
Dim nejm As String
Dim pos As String
Dim nejm2 As String

Set objSelection = Outlook.Application.ActiveExplorer.Selection

If Not (objSelection Is Nothing) Then

    For Each objMail In objSelection

        Set objMailDocument = objMail.GetInspector.WordEditor

        For i = 1 To objMailDocument.Hyperlinks.Count
            url = objMailDocument.Hyperlinks(i).Address

            xmlhttp.Open "GET", url, False
            xmlhttp.send

            nejm = xmlhttp.getResponseHeader("Content-Disposition")
            If nejm <> "" Then
                nejm = Replace(nejm, """", "")
                pos = InStr(1, nejm, "=")
                nejm2 = Mid(nejm, pos + 1, (Len(nejm) - (pos)))
            Else
                nejm2 = FileNameFromPath(url) '"File.jpg" 'GetFilenameFromPath(myURL)
            End If

            ret = URLDownloadToFile(0, url, "C:\Temp\" & nejm2, 0, 0)
            If ret = 0 Then
                MsgBox ("Files Downloaded !")
            Else
                MsgBox ("Error in Download! Please try again later !")
            End If
        Next

    Next

End If

End Sub

如何使用URLDownloadToFile下载文件？

1 个答案: