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

 

[kikola123]

My code looks like:

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

Dim SendersAdr As String                'New Variable
'For Each msg In olPurgeFolder.Items
For I = 1 To olPurgeFolder.Items.Count
    Debug.Print TypeName(olPurgeFolder.Items(1)), 0
    If TypeName(olPurgeFolder.Items(1)) = "MailItem" Then
        Set msg = olPurgeFolder.Items(1)
        SendersAdr = GetSender(msg)
        Debug.Print SendersAdr, 1
        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

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

 

[Anthony47]

Confirm that this is not the code that now is online
See also msg #10: Extracting all mails with specific email sender..

 

[kikola123]

O yes, it started downloading but the error also occurred saying: "Object variable or With block variable not set"

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) << [B]this Line is highilighted[/B]
    End If
End If
End Function

 

[Anthony47]

You should investigate which is wrong with the element at that moment under analysis; but the easiest way is skipping that line using OnError Resume Next:

Function GetSender(ByRef jItem As MailItem) As String
If jItem.SenderEmailType = "SMTP" Then
    GetSender = LCase(jItem.SenderEmailAddress)
Else
    If jItem.SenderEmailType = "EX" Then
        On Error Resume Next
        GetSender = LCase(jItem.Sender.GetExchangeUser.PrimarySmtpAddress)
        On Error GoTo 0
    End If
End If
End Function

After running the macro, look at the Immediate window; there you should see the mail address and its index in the folder; one line will have a missing mail address (only the Index). By examining the previous element and the subsequent one you should be able to check what type of element is in that position and see whther we risk (using OnError Resume Next) to lose something important

In the attached image I simulated that item 46 in the selected folder was skipped.
If you look at the address of the Item 45 and 47 you should be able to understand what is item 46

 

[kikola123]

For the specific sender, I investigated and compared downloaded attachments with outlook emails. No missing items were identified, but not all attachments are downloaded after some specific period, this might be for the reason mentioned in the picture. is this thruth?

 

[Anthony47]

No missing items were identified, but not all attachments are downloaded after some specific period

I guess that you mean "not all the emails are examined"

I am not an Outlook expert, even don't know what the message means, so I cannot help on this; sorry...

 

[kikola123]

I guess that you mean "not all the emails are examined"

I am not an Outlook expert, even don't know what the message means, so I cannot help on this; sorry...

Yes, some emails are on exchange and I have downloaded only history for the 1 year in outlook, so the code downloads only attachments for the previous 1 year.

I would examine your code for the other senders and if it works for all senders the thread is resolved.

 

[kikola123]

Yes, it works for all senders. Thanks, you are truly professional.

 

[kikola123]

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

Dim SendersAdr As String                'New Variable
'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

Function GetSender(ByRef jItem As MailItem) As String
If jItem.SenderEmailType = "SMTP" Then
    GetSender = LCase(jItem.SenderEmailAddress)
Else
    If jItem.SenderEmailType = "EX" Then
        On Error Resume Next
        GetSender = LCase(jItem.Sender.GetExchangeUser.PrimarySmtpAddress)
        On Error GoTo 0
    End If
End If
End Function

 

[Anthony47]

Thank you for the feedback