Extracting Outlook files.. with macro.

[HansV]

We tried that before and you said it didn't work...
It could look like this:

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

  ' Ask the user for a sender
  Dim sSender As String
  sSender = LCase(InputBox("Enter the sender's email address"))
  If sSender = "" 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 LCase(msg.SenderEmailAddress) = sSender Then
      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
    End If
  Next msg
End Sub

[HansV]

If you get an error that SenderEmailAddress is not supported, you could try entering the display name of the sender.

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

  ' Ask the user for a sender
  Dim sSender As String
  sSender = LCase(InputBox("Enter the sender's display name"))
  If sSender = "" 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 LCase(msg.SenderName) = sSender Then
      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
    End If
  Next msg
End Sub

[vaxo]

By debugging...

[HansV]

I have no idea. I already mentioned that the code works for me.

[vaxo]

Thanks, Hans V, maybe the problem lies on type of Inbox.