Auto export e-mails from Outlook to Excel - excel

Question

I've found in the internet and modified a bit a piece of code:
Public WithEvents objMails As Outlook.Items
Private Sub Application_Startup()
Const pierwszy = "pierwszy#gmail.com"
Const drugi = "drugi#gmail.com"
Dim OutAcc As Account
Debug.Print "Startup"
For Each OutAcc In Outlook.Application.Session.Accounts
If (OutAcc.DisplayName = pierwszy) Then
Set objMails = OutAcc.DeliveryStore.GetDefaultFolder(olFolderInbox).Items
Exit For
End If
If (OutAcc.DisplayName = drugi) Then
Set objMails = OutAcc.DeliveryStore.GetDefaultFolder(olFolderInbox).Items
Exit For
End If
Next
End Sub
Private Sub objMails_ItemAdd(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim strExcelFile As String
Dim objExcelApp As Excel.Application
Dim objExcelWorkBook As Excel.Workbook
Dim objExcelWorkSheet As Excel.Worksheet
Dim nNextEmptyRow As Integer
Dim strColumnB As String
Dim strColumnC As String
Dim strColumnD As String
Dim strColumnE As String
If Item.Class = olMail Then
Set objMail = Item
End If
'Specify the Excel file which you want to auto export the email list
'You can change it as per your case
strExcelFile = "C:\Users\karol\Documents\test.xlsx"
'Get Access to the Excel file
On Error Resume Next
Set objExcelApp = GetObject(, "Excel.Application")
If Error <> 0 Then
Set objExcelApp = CreateObject("Excel.Application")
End If
Set objExcelWorkBook = objExcelApp.Workbooks.Open(strExcelFile)
Set objExcelWorkSheet = objExcelWorkBook.Sheets("Arkusz1")
'Get the next empty row in the Excel worksheet
nNextEmptyRow = objExcelWorkSheet.Range("B" & objExcelWorkSheet.Rows.Count).End(xlUp).Row + 1
'Specify the corresponding values in the different columns
strColumnB = objMail.SenderName
strColumnC = objMail.SenderEmailAddress
strColumnD = objMail.Subject
strColumnE = objMail.ReceivedTime
strColumnF = objMail.Body
strColumnG = objMail.To
'Add the vaules into the columns
objExcelWorkSheet.Range("A" & nNextEmptyRow) = nNextEmptyRow - 1
objExcelWorkSheet.Range("B" & nNextEmptyRow) = strColumnB
objExcelWorkSheet.Range("C" & nNextEmptyRow) = strColumnC
objExcelWorkSheet.Range("D" & nNextEmptyRow) = strColumnD
objExcelWorkSheet.Range("E" & nNextEmptyRow) = strColumnE
objExcelWorkSheet.Range("F" & nNextEmptyRow) = strColumnF
objExcelWorkSheet.Range("G" & nNextEmptyRow) = strColumnG
'Fit the columns from A to E
objExcelWorkSheet.Columns("A:G").AutoFit
'Save the changes and close the Excel file
objExcelWorkBook.Close SaveChanges:=True
End Sub
This code works fine, when in Outlook application I am logged in at one mailbox (one e-mail). I've faced a problem when I am trying to automatically export emails from two mailboxes (two accounts with different email addresses on which I am logged in to the Outlook application) - look at the picture:
https://ibb.co/mXWZJsw
I tried to solve this problem by using If statements in the Application_Startup () procedure (as seen in the code above). This approach, unfortunately, does not work. I also noticed that, for example, when the first email arrives at the account "pierwszy#gmail.com", then until the application is closed, emails will be exported to Excel only from this account "pierwszy#gmail.com" and not exported from the account "drugi#gmail.com". However, when the first e-mail arrives at the account "drugi#gmail.com", then emails will be exported from the seccond e-mail "drugi#gmail.com" until application is closed.

Answer 1

Let me preface this by saying - not sure how rules work for multiple accounts. You may need to create the rule for BOTH accounts but they can both reference the same script.
I've updated your code to be a public Sub vs Private Sub and placed it in a module so that it can be referenced by the rules engine.
Now, once we have the code in place (scripts run by Rules engine typically inherently pass the email as a MailItem to the sub and ByVal was causing issues with recognizing the script as one to be run from a MailItem so i updated it to Item as MailItem).
We next create a new rule using the rules engine. If you see this simplistic interface, click on Advanced Options. That will allow us to apply to rule to all emails. In the advanced options window, do not check any box for Which conditions do you want to check? simply click Next. It will confirm you want to add this rule for ALL EMAILS which we do.
After selecting run a script we can click on a script to indicate which script we want to run. I set it to the exportToExcel script in Module(Project)1
Click Finish and test it out.
Sub exportToExcel(item As MailItem)
Dim objMail As Outlook.MailItem
Dim strExcelFile As String
Dim objExcelApp As Excel.Application
Dim objExcelWorkBook As Excel.Workbook
Dim objExcelWorkSheet As Excel.Worksheet
Dim nNextEmptyRow As Integer
Dim strColumnB As String
Dim strColumnC As String
Dim strColumnD As String
Dim strColumnE As String
If item.Class = olMail Then
Set objMail = item
End If
'Specify the Excel file which you want to auto export the email list
'You can change it as per your case
strExcelFile = "C:\Users\karol\Documents\test.xlsx"
'Get Access to the Excel file
On Error Resume Next
Set objExcelApp = GetObject(, "Excel.Application")
If Error <> 0 Then
Set objExcelApp = CreateObject("Excel.Application")
End If
Set objExcelWorkBook = objExcelApp.Workbooks.Open(strExcelFile)
Set objExcelWorkSheet = objExcelWorkBook.Sheets("Arkusz1")
'Get the next empty row in the Excel worksheet
nNextEmptyRow = objExcelWorkSheet.Range("B" & objExcelWorkSheet.Rows.count).End(xlUp).Row + 1
'Specify the corresponding values in the different columns
strColumnB = objMail.SenderName
strColumnC = objMail.SenderEmailAddress
strColumnD = objMail.Subject
strColumnE = objMail.ReceivedTime
strColumnF = objMail.Body
strColumnG = objMail.To
'Add the vaules into the columns
objExcelWorkSheet.Range("A" & nNextEmptyRow) = nNextEmptyRow - 1
objExcelWorkSheet.Range("B" & nNextEmptyRow) = strColumnB
objExcelWorkSheet.Range("C" & nNextEmptyRow) = strColumnC
objExcelWorkSheet.Range("D" & nNextEmptyRow) = strColumnD
objExcelWorkSheet.Range("E" & nNextEmptyRow) = strColumnE
objExcelWorkSheet.Range("F" & nNextEmptyRow) = strColumnF
objExcelWorkSheet.Range("G" & nNextEmptyRow) = strColumnG
'Fit the columns from A to E
objExcelWorkSheet.Columns("A:G").AutoFit
'Save the changes and close the Excel file
objExcelWorkBook.Close SaveChanges:=True
End Sub

Answer 2

You can monitor multiple folders with ItemAdd.
Option Explicit
Public WithEvents objMailspierwszy As Items
Public WithEvents objMailsdrugi As Items
Private Sub Application_Startup()
Const pierwszy = "pierwszy#somewhere.com"
Const drugi = "drugi#somewhere.com"
Dim OutAcc As Account
For Each OutAcc In Session.Accounts
Debug.Print "OutAcc.DisplayName: " & OutAcc.DisplayName
Debug.Print "OutAcc.DeliveryStore: " & OutAcc.DeliveryStore
If OutAcc.DisplayName = pierwszy Then
Debug.Print "OutAcc.DisplayName: " & OutAcc.DisplayName
Set objMailspierwszy = OutAcc.DeliveryStore.GetDefaultFolder(olFolderInbox).Items
Debug.Print "Listener on " & objMailspierwszy.Parent & " of DeliveryStore " & OutAcc.DeliveryStore
End If
If OutAcc.DisplayName = drugi Then
Debug.Print "OutAcc.DisplayName: " & OutAcc.DisplayName
Set objMailsdrugi = OutAcc.DeliveryStore.GetDefaultFolder(olFolderInbox).Items
Debug.Print "Listener on " & objMailspierwszy.Parent & " of DeliveryStore " & OutAcc.DeliveryStore
End If
Next
End Sub
Private Sub objMailspierwszy_ItemAdd(ByVal Item As Object)
'...
End Sub
Private Sub objMailsdrug_ItemAdd(ByVal Item As Object)
'...
End Sub