Extracting all mails with specific email sender..

[kikola123]

Hello Friends, I have VBA Code for extracting email attachments from outlook with specific sender, but it dos't work - ( it does nothing after executing it), could you help me investigating the problem?

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

 

[Anthony47]

Add the "Debug.Print" line in this position:

For Each msg In olPurgeFolder.Items
    Debug.Print msg.SenderEmailAddress                           '<<< ADD THIS LINE HERE
    If LCase(msg.SenderEmailAddress) = sSender Then

Then run the macro.
At the end go to the vba editor, open the "Immediate Window" (typing Contr-g should do the job; or Menu /Display /Immediate window): you will see how the sender email address is shown (only the last 200 lines are shown in that window); compare it to how you write it into the inputbox and maybe you will understand what is going on

 

[kikola123]

Yes I did what you said but in the immediate window appeared this message: /O=EXCHANGELABS/OU=EXCHANGE ADMINISTRATIVE GROUP (FYDIBOHF23SPDLT)/CN=RECIPIENTS/CN=FAF57AD000824838880DE43638198FA5-VAKHTANG.MA
and other email addresses outside our company mail, and not the mails inside our company's addresses.

 

[Anthony47]

What you see is what your command (msg.SenderEmailAddress) returns; and it's not what you expected.

Try
1) add this Function at the bottom of your code:

Function GetSender(ByRef Item As MailItem) As String
If Item.SenderEmailType = "SMTP" Then
    GetSender = LCase(Item.SenderEmailAddress)
Else
    If Item.SenderEmailType = "EX" Then
        GetSender = LCase(Item.Sender.GetExchangeUser.PrimarySmtpAddress)
    End If
End If
End Function

Then replace the followng lines:

For Each msg In olPurgeFolder.Items
    Debug.Print msg.SenderEmailAddress                           
    If LCase(msg.SenderEmailAddress) = sSender Then

with the following:

Dim SendersAdr As String                'New Variable
For Each msg In olPurgeFolder.Items
    SendersAdr = GetSender(msg)
    Debug.Print SendersAdr
    If SendersAdr = sSender Then

In the "Immediate Window" you should now read the smtp addresses, that is the format you use for the searched address (I guess)

Try...

 

[kikola123]

Yes, now I see SMTP addresses, and attachments are downloaded but the process stops in the middle with a type mismatch error and by debuging it:

sSavePathFS = fsSaveFolder.Self.Path & "\" & att.FileName
att.SaveAsFile sSavePathFS
Next att
End If
End If
Next msg <<< this line is highilighted.
End Sub


And only few attachments from the sender are downloaded not all...

 

[Anthony47]

Please use Tags to improve readability of your code

That error arise (I guess) because not all the Items in olPurgeFolder.Items are "Mail Items".

Try replacing the main loop (from For Each msg In olPurgeFolder.Items to the end) with this:

'For Each msg In olPurgeFolder.Items
For I = 1 To olPurgeFolder.Items.Count
    Debug.Print TypeName(olPurgeFolder.Items(I)), 0
    If TypeName(olPurgeFolder.Items(I)) = "MailItem" Then
        Set msg = olPurgeFolder.Items(I)
        SendersAdr = GetSender(msg)
        Debug.Print SendersAdr, I
        Debug.Print TypeName(msg), "A"
        If SendersAdr = 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
        Debug.Print TypeName(msg), "B"
    End If
'Next msg
Next I
Beep
End Sub

BEWARE: The code has been edited after its first publishing

 

[kikola123]

No error but the attachments are not downloaded and in the immediate window:

 

[Anthony47]

Read again my previous message and the final "BEWARE"...

 

[kikola123]

Read again my previous message and the final "BEWARE"...

I pasted your edited code to the VBA editor... or something I missed?

 

[Anthony47]

The immediate window says that you was too fast in copying the suggested code, in that I modified it 4 minutes later
You need to copy the code that is now online, sorry