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