如何在 Outlook 2016 中使用 VB 下载超链接中的 PDF [英] How to download a PDF that is in a hyperlink using VB in Outlook 2016

问题描述

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

I'm looking for some assistance with automating a task I do several times per day.I receive emails from a certain address which I automatically sort (using Rules) into a dedicated folder.

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

These emails have hyperlinks to different documents to download from the web; however the links are not written as a URL, rather there is a link saying "Open the document".

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

I click on this link, it opens the PDF, then I save this PDF file on my desktop before I upload it to a document library

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

I'm looking to automate this process. It's a fiddly task doing it manually because I receive so many emails, and downloading each one separately to a folder on my machine and then uploading them to my document library takes a long time.

我对 VBA 的编程经验不多，但我愿意学习.

I don't have much programming experience with VBA but I'm willing to learn.

有人可以帮我吗?

推荐答案

首先启用 OutLook 中的开发人员标签.

然后如何在OutLook中创建宏

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

Copy the code below into a new Module.

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

Finally, edit your rule to move the emails and add another step to run a script. Click in the rule your new Module should show up.

完成.

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

这篇关于如何在 Outlook 2016 中使用 VB 下载超链接中的 PDF的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！