如何在 Outlook 2016 中使用 VB 下载超链接中的 PDF [关闭]

Question

我正在寻求一些帮助，以自动化我每天多次执行的任务。我收到来自某个地址的电子邮件，我会自动将这些电子邮件分类（使用规则）到一个专用文件夹中。

这些电子邮件具有指向不同文档的超链接，可从网络下载；但是链接不是写成 URL，而是有一个链接说“打开文档”。

我单击此链接，它会打开 PDF，然后我将这个 PDF 文件保存在我的桌面上，然后再将其上传到文档库

我希望自动化这个过程。手动完成是一项繁琐的任务，因为我收到了很多电子邮件，并且将每封电子邮件单独下载到我机器上的一个文件夹中，然后将它们上传到我的文档库中需要很长时间。

我没有太多VBA 的编程经验，但我愿意学习。

谁能帮帮我？

Answer 1

从启用Developer Tab in OutLook开始。

然后how to create a Macro in OutLook

将下面的代码复制到一个新的模块中。

最后，编辑您的规则以移动电子邮件并添加另一个步骤来运行脚本。单击您的新模块应显示的规则。

完成。

Sub SavePDFLinkAction(item As Outlook.MailItem)

    Dim subject As String
    Dim linkName As String

    '*******************************
    ' Intitial setup
    '*******************************
    subject = "Criteria" ' Subject of the email
    linkName = "Open the document" ' link name in the email body
    '*******************************

    Dim link As String

    link = ParseTextLinePair(item.body, "HYPERLINK")
    link = Replace(link, linkName, "")
    link = Replace(link, """", "")
    'Download the file - Intitial settings need to be set
    DownloadFile (link)

End Sub

Sub DownloadFile(myURL As String)

    Dim saveDirectoryPath As String

    '*******************************
    ' Intitial setup
    '*******************************
    saveDirectoryPath = "C:\temp\" 'where your files will be stored
    '*******************************

    Dim fileNameArray() As String
    Dim fileName As String
    Dim arrayLength As Integer
    Dim DateString As String
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")

    fileNameArray = Split(myURL, "/")
    arrayLength = UBound(fileNameArray)
    fileName = fileNameArray(arrayLength)

    'Add date to the file incase there are duplicates comment out these lines if you do not want the date added
    fileName = Replace(fileName, ".pdf", "_" & DateString & ".pdf")
    fileName = Replace(fileName, ".PDF", "_" & DateString & ".PDF")

    Dim WinHttpReq As Object
    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", myURL, False, "username", "password"
    WinHttpReq.Send

    myURL = WinHttpReq.responseBody
    If WinHttpReq.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile saveDirectoryPath & fileName, 2 ' 1 = no overwrite, 2 = overwrite
        oStream.Close
    End If

End Sub

Function ParseTextLinePair(strSource As String, strLabel As String)
    Dim intLocLabel As Integer
    Dim intLocCRLF As Integer
    Dim intLenLabel As Integer
    Dim strText As String

    intLocLabel = InStr(strSource, strLabel)
    intLenLabel = Len(strLabel)
    If intLocLabel > 0 Then
        intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
        If intLocCRLF > 0 Then
            intLocLabel = intLocLabel + intLenLabel
            strText = Mid(strSource, _
                            intLocLabel, _
                            intLocCRLF - intLocLabel)
        Else
            intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
        End If
    End If
    ParseTextLinePair = Trim(strText)
End Function