Comment télécharger un PDF qui est dans un lien hypertexte en utilisant VB dans Outlook 2016

Question

Je cherche de l'aide avec l'automatisation d'une tâche que je fais plusieurs fois par jour. Je reçois des emails d'une certaine adresse que je trier automatiquement (en utilisant les règles) dans un dossier dédié.

Ces courriels contiennent des hyperliens vers différents documents à télécharger sur le Web; Cependant, les liens ne sont pas écrits comme une URL, mais plutôt un lien disant "Ouvrir le document".

je clique sur ce lien, il ouvre le PDF, puis-je enregistrer ce fichier PDF sur mon bureau avant de le télécharger à une bibliothèque de documents

Je cherche à automatiser ce processus. C'est une tâche fastidieuse de le faire manuellement parce que je reçois tellement de courriels, et les télécharger séparément dans un dossier sur mon ordinateur, puis les télécharger dans ma bibliothèque de documents prend beaucoup de temps.

Je n'ai pas beaucoup d'expérience en programmation avec VBA mais je suis prêt à apprendre.

Quelqu'un peut-il m'aider?

Answer 1

Commencez par activer le Developer Tab in OutLook.

Puis how to create a Macro in OutLook

Copiez le code ci-dessous dans un nouveau module.

Enfin, modifiez votre règle pour déplacer les courriers électroniques et ajoutez une autre étape pour exécuter un script. Cliquez dans la règle que votre nouveau module devrait apparaître.

Terminé.

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