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

我正在寻找一些帮助来自动执行我每天要做几次的任务。我从某个地址接收电子邮件，并自动将其排序（使用规则）到一个专用文件夹中。如何在Outlook 2016中使用VB下载超链接中的PDF

这些电子邮件有超链接到不同的文件，从网上下载;但是链接不是作为URL编写的，而是存在链接，指出“打开文档”。

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

我期待这个过程自动化之前。手动完成这项任务非常繁琐，因为我收到了太多的电子邮件，并且将每个邮件分别下载到我的计算机上的文件夹中，然后将其上传到我的文档库需要很长时间。

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

任何人都可以帮助我吗？

来源

2017-06-21 Roger Rivas

从启用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

来源

2017-06-21 21:23:14 EJD

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

回答

相关问题