CODEWITHSUNDEEP
vbaoutlook
user15574030
user15574030

Reputation: 11

Outlook deleting attachments

I was trying to get a macro to save attachments from multiple emails in Outlook all at once. I have only tinkered around in Word VBA with successful outcomes and this clearly was too much for a noob like myself.

I tried searching for an already-done macro and I found one on this page (Save attachments to a folder and rename them) and I copied the macro from the most useful answer into my Outlook VBA. Foolish me ran the macro on pretty much all the emails I wanted to do it on, and now the attachments are no longer there instead showing the message:

"C:\Users\fran1\Documents\Attachments\BATMAN_WEI2-1_3470_001.pdf"

for every file.

However, that folder does not exist, the link is broken and I cannot seem to manually find the equivalent folder. My question is, are the files stored somewhere in my computer? If so, how can I retrieve them? I have tried looking for them using their file name (which is pretty specific) but to no avail. These files are an automatic PDF generated from a scanner and so to get the files back I need to scan the documents again which takes some time, hence why I am keen on getting the attachment files back. Any answer on what the macro might have done with the files is very much welcome. Worst case scenario, I will have to spend another 90 minutes scanning the docs back.

Upvotes: 1

Views: 781

Answers (1)

Tragamor
Tragamor

Reputation: 3634

While not an answer to recovering your files (although you can check the OLK folder as per comments), you may want a better functioning VBA script for saving future attachments; so the following is code to save (and safely remove if desired) attachments from selected e-mails.

Duplicated filenames will not be saved or removed from e-mails unless set to do so.

Update the FilePath to where you would like to save the files

Public Sub SaveAttachmentsFromSelectedEmails()
    Dim olItem As Outlook.MailItem
    Dim olSelection As Outlook.Selection: Set olSelection = ActiveExplorer.Selection
    Dim FilePath As String: FilePath = Environ("USERPROFILE") & "\Documents\Documents\Attachments"
    
    If Dir(FilePath, vbDirectory) = "" Then
        Debug.Print "Save folder does not exist"
        Exit Sub
    End If
    
    For Each olItem In olSelection
        SaveAttachments olItem, FilePath, RemoveAttachments:=False
    Next olItem
End Sub

Function SaveAttachments(ByVal Item As Object, FilePath As String, _
    Optional FileExtensions As String = "*", _
    Optional Delimiter As String = ",", _
    Optional RemoveAttachments As Boolean = False, _
    Optional OverwriteFiles As Boolean = False) As Boolean
    
    On Error GoTo ExitFunction
    
    Dim i As Long, j As Long, FileName As String, Flag As Boolean
    Dim Extensions() As String: Extensions = Split(FileExtensions, Delimiter)
    If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
    
    For j = LBound(Extensions) To UBound(Extensions)
        With Item.Attachments
            If .Count > 0 Then
                For i = .Count To 1 Step -1
                    FileName = FilePath & .Item(i).FileName
                    Flag = IIf(LCase(Right(FileName, Len(Extensions(j)))) = LCase(Extensions(j)), True, False)
                    Flag = IIf(FileExtensions = "*" Or Flag = True, True, False)
                    If Flag = True Then
                        If Dir(FileName) = "" Or OverwriteFiles = True Then
                            .Item(i).SaveAsFile FileName
                        Else
                            Debug.Print FileName & " already exists"
                            Flag = False
                        End If
                    End If
                    If RemoveAttachments = True And Dir(FileName) <> "" And Flag = True Then .Item(i).Delete
                Next i
            End If
        End With
    Next j
    SaveAttachments = True

ExitFunction:
End Function

Upvotes: 1

Related Questions