Issue Outlook PDF download by received link

Question

I used this code by Simon Li, but for some reason it always gives me a connection problem once i start outlook.

I wanted to create a PDF downloader for certain emails we receive and actually it worked for quite a while, but now the script doesnt trigger anymore:

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim olApp As Outlook.Application

  Set olApp = Outlook.Application
  Set Items = GetNS(olApp).GetDefaultFolder(olFolderInbox).Folders("Tagblätter").Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)

  On Error GoTo ErrorHandler

'Variablen definieren
    Dim olMsg As MailItem
    Dim i As Integer
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olFolder As Outlook.Folder
    Dim olItems As Outlook.Items
    Dim olMailItem As Outlook.MailItem
    Dim linkLoc As Integer
    Dim link As String
    Dim Pfad As String
    Dim WinHttpReq As Object
    Dim oStream As Object
    Dim Datum As Date
    Dim strDatum As String
    Dim CountMail As Long
 
 'Speicherpfad angeben
    Pfad = "L:\Newsletter\"
 
 'Inhalt von Tagblätter checken
    On Error Resume Next
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.GetDefaultFolder(olFolderInbox).Folders("Tagblätter")
    Set olItems = olFolder.Items
      
 'Link aus Body extrahieren
    For i = CountMail To 1 Step -1
        Set olMsg = olItems.item(i)
        linkLoc = InStr(1, olMsg.Body, "PDF herunterladen")
        link = Mid(olMsg.Body, linkLoc + 8)
        link = Split(link, "<")(1)
        link = Split(link, ">")(0)
        
 'Aktuelles Datum für Ordner beziehen
        Datum = olMsg.ReceivedTime
        strDatum = Datum
        strDatum = Split(strDatum, " ")(0)
        strDatum = Split(strDatum, ".")(2) + Split(strDatum, ".")(1) + Split(strDatum, ".")(0)
       
        Pfad = Pfad + strDatum
        
 'Link öffnen
        Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
        WinHttpReq.Open "GET", link, False
        WinHttpReq.Send

        
 'Check ob Adresse erreichbar
        If WinHttpReq.Status = 200 Then
        
 'Ordner mit aktuallem Datum erstellen
            Set FSO = CreateObject("Scripting.FileSystemObject")
            FSO.CreateFolder Pfad

 'PDF abspeichern
            Set oStream = CreateObject("ADODB.Stream")
            oStream.Open
            oStream.Type = 1
            oStream.Write WinHttpReq.ResponseBody
            oStream.SaveToFile (Pfad + "\" + olMsg.Sender + "-" + olMsg.Subject + ".pdf")
            oStream.Close
        End If
 'E-Mail löschen
        olMsg.Delete
    Next i
    
 'Variablen leeren
    Set olMsg = Nothing
    Pfad = ""

ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
  Set GetNS = app.GetNamespace("MAPI")
End Function

Does anyone have an idea? Thank you in advance!

ReSu · Accepted Answer · 2022-07-12T13:55:30.730

0

Ok i got the answer.

For i = CountMail To 1 Step -1

Somehow i forgot to actually Count the Mails:

CountMail = olNS.GetDefaultFolder(olFolderInbox).Folders("Tagblätter").Items.Count

And second issue was here:

Datum = olMsg.ReceivedTime

Changed it to:

Datum = olItems.item(i).ReceivedTime

Well, anyway maybe someone has a need for this code. Or there might be smth to code better? For us it works quite nice, cos the emails we receive always got the same format and linked text.

Cheers

edited Jul 12 '22 at 13:55

answered Jul 12 '22 at 13:54

ReSu

1
2

The most experienced programmers will fall into traps set by `On Error Resume Next`. That is why it is most used by the inexperienced. – niton Jul 12 '22 at 18:12
Indeed, didnt think about deleting it to get the issues. as u said inexperienced, but will keep that in mind for next time. – ReSu Jul 15 '22 at 09:33

Issue Outlook PDF download by received link

1 Answers1