Extracting Outlook files.. with macro.

[HansV]

Yes - the full email address.

Activate the Visual Basic Editor.
Click anywhere in the ExportAttachments macro.
Each time you press the function key F8, one instruction will be executed.
You can inspect the value of variable by hovering the mouse pointer over them in the code.

[vaxo]

Hello friends, I have found this code on another forum and it works greatly, but it needs to add sender criteria... Please help.

[vaxo]

But it deleted all attachments from sending folder and located it to Disk D, How can I restore this to outlook bases? :(((

Code: Select all

Public Sub SaveOLFolderAttachments()

  ' Ask the user to select a file system folder for saving the attachments
  Dim oShell As Object
  Set oShell = CreateObject("Shell.Application")
  Dim fsSaveFolder As Object
  Set fsSaveFolder = oShell.BrowseForFolder(0, "Please Select a Save Folder:", 1)
  If fsSaveFolder Is Nothing Then Exit Sub
  ' Note:  BrowseForFolder doesn't add a trailing slash

  ' Ask the user to select an Outlook folder to process
  Dim olPurgeFolder As Outlook.MAPIFolder
  Set olPurgeFolder = Outlook.GetNamespace("MAPI").PickFolder
  If olPurgeFolder Is Nothing Then Exit Sub

  ' Iteration variables
  Dim msg As Outlook.MailItem
  Dim att As Outlook.attachment
  Dim sSavePathFS As String
  Dim sDelAtts

  For Each msg In olPurgeFolder.Items

    sDelAtts = ""

    ' We check each msg for attachments as opposed to using .Restrict("[Attachment] > 0")
    ' on our olPurgeFolder.Items collection.  The collection returned by the Restrict method
    ' will be dynamically updated each time we remove an attachment.  Each update will
    ' reindex the collection.  As a result, it does not provide a reliable means for iteration.
    ' This is why the For Each loops will not work.
    If msg.Attachments.Count > 0 Then

      ' This While loop is controlled via the .Delete method
      ' which will decrement msg.Attachments.Count by one each time.
      While msg.Attachments.Count > 0

        ' Save the file
        sSavePathFS = fsSaveFolder.Self.Path & "\" & msg.Attachments(1).FileName
        msg.Attachments(1).SaveAsFile sSavePathFS

        ' Build up a string to denote the file system save path(s)
        ' Format the string according to the msg.BodyFormat.
        If msg.BodyFormat <> olFormatHTML Then
            sDelAtts = sDelAtts & vbCrLf & "<file://" & sSavePathFS & ">"
        Else
            sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sSavePathFS & "'>" & sSavePathFS & "</a>"
        End If

        ' Delete the current attachment.  We use a "1" here instead of an "i"
        ' because the .Delete method will shrink the size of the msg.Attachments
        ' collection for us.  Use some well placed Debug.Print statements to see
        ' the behavior.
        msg.Attachments(1).Delete

      Wend

      ' Modify the body of the msg to show the file system location of
      ' the deleted attachments.
      If msg.BodyFormat <> olFormatHTML Then
        msg.Body = msg.Body & vbCrLf & vbCrLf & "Attachments Deleted:  " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To:  " & vbCrLf & sDelAtts
      Else
        msg.HTMLBody = msg.HTMLBody & "<p></p><p>" & "Attachments Deleted:  " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To:  " & vbCrLf & sDelAtts & "</p>"
      End If

      ' Save the edits to the msg.  If you forget this line, the attachments will not be deleted.
      msg.Save

    End If

  Next
End Sub

[vaxo]

I was happy that I found the answer to this problem but then I saw the outlook Sent items section and all files were deleted :(

[vaxo]

Besides I changed the location where the files was downloaded and no undo functions are working... so I cannot find my files.. What can I do?

[HansV]

The code explicitly states that it will delete all attachments from all messages in the selected folder.

However, there is nothing in the code that would delete the messages themselves, so I don't understand why your Sent Items folder was cleared. Are you sure you haven't set a filter on that folder?

If the messages have been deleted, I don't see a way to restore them. Do you have a backup of your email storage?

Here is a version of the macro that doesn't remove the attachments, nor does it modify the messages.

Code: Select all

Public Sub SaveOLFolderAttachments()
  ' Ask the user to select a file system folder for saving the attachments
  Dim oShell As Object
  Set oShell = CreateObject("Shell.Application")
  Dim fsSaveFolder As Object
  Set fsSaveFolder = oShell.BrowseForFolder(0, "Please Select a Save Folder:", 1)
  If fsSaveFolder Is Nothing Then Exit Sub
  ' Note:  BrowseForFolder doesn't add a trailing slash

  ' Ask the user to select an Outlook folder to process
  Dim olPurgeFolder As Outlook.MAPIFolder
  Set olPurgeFolder = Outlook.GetNamespace("MAPI").PickFolder
  If olPurgeFolder Is Nothing Then Exit Sub

  ' Iteration variables
  Dim msg As Outlook.MailItem
  Dim att As Outlook.Attachment
  Dim sSavePathFS As String

  For Each msg In olPurgeFolder.Items
    If msg.Attachments.Count > 0 Then
      For Each att In msg.Attachments
        ' Save the file
        sSavePathFS = fsSaveFolder.Self.Path & "\" & att.FileName
        att.SaveAsFile sSavePathFS
      Next att
    End If
  Next msg
End Sub

[vaxo]

The files has been downloaded to this location but, I have rewritten the location and now, the link which is seen in picture don't works.. but the files are not in recycle bin... Where are they gone?

[vaxo]

When I search them through search everything soft.. it is now link... could I restore them?

[HansV]

The items in your search results are links in two Recent folders, not the files themselves.
Have you tried searching on the D: disk?

[vaxo]

On D Disk I have added new folder after executing this macro with the name: "aq", but after this I have used Ctrl-z for undo and the file has changed name to NEW Folder. Then I wanted to do CTRL-Y but it does not worked.

[HansV]

Adding a folder after running the macro wouldn't help.

[vaxo]

When executing this macro i added folder "aq" and downloaded all attachments there. And the links from outlook opened, but then I faulty pressed on Ctrl-z and the folder name which has this name has been changed. Now when I press "Attachments Deleted: 02/10/2022 18:10:37 Saved To:
D:\aq\LLC Aviaservice_Geo_2021 for Upload.pdf" to this link it says: We can not find D:\aq\........... Please make sure you are using the correct location or web address.

[HansV]

Can you find the file LLC Aviaservice_Geo_2021 for Upload.pdf anywhere on your D: disk?

[vaxo]

No not in Disk D, but the links in two recent files which I have pictured are openable now. But I search them through search everything without .pdf.

[vaxo]

Can we transform these links to the usual file extension? For example to usual .pdf format? Will the recent file location removed soon? :(

[vaxo]

Your macro does nothing, I tried it to a different folder... What is the problem?

[HansV]

I give up. I can't help you with this, sorry.

[vaxo]

Ok, I would recover it one by one... This would be not a big problem.. But this code that You transformed doesn't download files? Why?

[HansV]

I don't know! I have tested the code and it works for me!

[vaxo]

Excuse me it works, but for specific folders, it does not execute. When you would have time could we change the code so that I can download attachments for specific senders?