VBA to Save Specific email pdfs creates Corrupted files

[patcell]

Hello everyone,

Have a bit of a peculiar situation and hoping there is a genius here that can help me. Basically, i have frankensteined some code to create a process in Excel VBA that saves a selected outlook email attachment as a pdf on my hard drive. This code works and saves the PDF to the selected location but the problem is that occasionally with certain PDFs (not all), I get an error message when i try to open the files (see image)

that says: "Adobe Reader could not open .pdf' because it is either not a supported file type or because the file has been damaged (for example, it was sent as an email attachment and wasn't correctly decoded)."

If this happened with all PDFs then I would know there is a genuine problem with the code, but i only get this error with about 20% of the PDFs saved using the code - the rest work without issue.


here is the bit of code i am currently using to save the PDFs:

 For Each olMail In olFldr.Items        
              For Each olAtt In olMail.Attachments
             If (InStr(1, olMail.SenderName, SenderName1) > 0 And InStr(1, olMail.Subject, MailSub) > 0 And intMessage = vbYes) Or (InStr(1, olMail.SenderName, SenderName1) > 0 And InStr(1, olMail.Body, MailSub) > 0 And intMessage = vbYes) Then
                 sFile = sPath & sName & ".pdf"
                 olAtt.SaveAsFile sFile
                 ActiveWorkbook.FollowHyperlink sFile
                                  
                 Sheets("Sheet1").Range("A1:A24").Value = ""
      Exit Sub
      End If

This code saves the PDF attachment into the specified location and opens the file once saved. Does anyone know another method or piece of code i can use to do the same thing but avoid the corrupted, erroneous files from being occasionally created?

Thanks for your help!

 

[patcell]

Still nothing.. If anyone needs some further detail on this - let me know! can't wait to hear what advice you may have.

Thanks

 

[bpbd]

Still nothing.. If anyone needs some further detail on this - let me know! can't wait to hear what advice you may have.

Thanks

I'm bumping this thread because I'm having the same difficulty in Outlook when attempting to export a pdf attachment and cannot find an answer to this anywhere. Is there some way to save PDF's with the saveasfile method without corrupting them? Or is there another method that can be used in it's place that will not corrupt those files?

Even though this is an Excel forum I'm attaching my Outlook VBA to see if anyone can find anything in the VBA itself that would help solve this issue:

'Generating Event Listener [BD]Private WithEvents Items As Outlook.Items


Private Sub Application_Startup()


    'Declaring Variables [BD]
    Dim oOutlook As Outlook.Application
    Dim oNameSpace As Outlook.NameSpace
    Dim oFolder As Outlook.MAPIFolder
    
    'Intializing Variables [BD]
    Set oOutlook = Outlook.Application
    Set oNameSpace = Application.GetNamespace("MAPI")
    
    Set oFolder = oNameSpace.GetDefaultFolder(olFolderInbox).Parent
    Set oFolder = oFolder.Folders("Produce Availability").Folders("Earls Organic")
    Set Items = oFolder.Items


End Sub


Private Sub Items_ItemAdd(ByVal Item As Object)


'Declaring Variables [BD]
Dim sOutputFileName As String


Dim oMessage As Outlook.MailItem
Dim oAttachment As Outlook.Attachments


'Initializing Variables [BD]
sDateTime = Format(Now(), "yyyymmddhhnnss")
sOutputFolderPath = "C:\Earls Organic\"
    
    On Error GoTo ErrorHandler
    
    If TypeName(Item) = "MailItem" Then
    
        Set oMessage = Item
        Set oAttachment = oMessage.Attachments
        
        sOutputFileName = oMessage.Subject & " " & sDateTime
        sOutputFolderPathAndName = sOutputFolderPath & sOutputFileName & ".pdf"
        oAttachment.Item(1).SaveAsFile sOutputFolderPathAndName


        Set oAttachment = Nothing
        Set oItem = Nothing
            
    End If
    
ProgramExit:
    Exit Sub
    
ErrorHandler:
        MsgBox Err.Number & " - " & Err.Description
        Resume ProgramExit


End Sub