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

debugcn 发表于 Dev

罗杰·里瓦斯

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

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

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

我正在寻找自动化这个过程。手动执行此操作是一项繁琐的任务，因为我收到了太多电子邮件，将每个电子邮件分别下载到我机器上的一个文件夹中，然后将它们上传到我的文档库需要很长时间。

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

有人可以帮助我吗？

EJD

从启用OutLook 中的Developer Tab开始。

那么如何在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

本文收集自互联网，转载请注明来源。

如有侵权，请联系[email protected] 删除。