Automatically distribude emails to receipments from excel list.

[Robert123]

Hi All,
I'm new to Outlook VBA and im not sure if it's possible to do what i need.
I'm looking for a way to automate incoming emails distribution.
There is a shared inbox with subfolder "Done", and excel file with distribution list.

Excel looks like this (column A), and it's editable, so some records can be added/removed on a daily basis :

Agent1emailadress
Agent2emailadress
Agent3emailadress
Agent4emailadress
etc.

I need to create a macro that will loop through recipment's list and forward any incoming msg separately, one by one, just like this:

First msg today - agent1
Second msg today - agent2
Third msg today - agent3

Etc. to the end of the list and then start from beginning.

After message is forwarded it should be moved to inbox\\Done subfolder.
Main goal is to distribute fair number of incoming msgs through all of agents on the list.

I would be grateful for any help, if someone has created something like this then pls let me know.
Thx in advance.

Robert.

[gmayor]

Assuming column A has a header row, then the following should work when run from a rule. I have included a test macro.
Change the workbook and worksheet names as appropriate in the line
Arr = xlFillArray("C:\Path\Distribution List.xlsx", "Sheet1").
The process reads the worksheet into an array and then using an incrementing counter the macro forwards the message to the next e-mail address.
The counter is stored in the registry at HKEY_CURRENT_USER\Software\VB and VBA Program Settings\OutlookDistributeMessages. I have added a macro to allow you to test the code,


Option Explicit
Sub Test()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
DistributeMessages olMsg
lbl_Exit:
Exit Sub
End Sub

Sub DistributeMessages(olItem As MailItem)
Dim olOutMail As Outlook.MailItem
Dim sAddr As String
Dim iCount As Long
Dim i As Long
Dim Arr() As Variant
Arr = xlFillArray("C:\Path\Distribution List.xlsx", "Sheet1")
iCount = Val(GetSetting("OutlookDistributeMessages", "Config", "Count"))
sAddr = Arr(0, iCount)
iCount = iCount + 1
Set olOutMail = olItem.Forward
With olOutMail
.To = sAddr
.Display 'Change to .Send after testing
End With
If iCount = UBound(Arr, 2) + 1 Then iCount = 0
SaveSetting "OutlookDistributeMessages", "Config", "Count", CStr(iCount)
olItem.Move Session.GetDefaultFolder(olFolderInbox).folders("Done")
lbl_Exit:
Set olOutMail = Nothing
Exit Sub
End Sub

Private Function xlFillArray(strWorkBook As String, _
strWorksheetName As String) As Variant
Dim RS As Object
Dim CN As Object
Dim iRows As Long

strWorksheetName = strWorksheetName & "$]"
Set CN = CreateObject("ADODB.Connection")
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkBook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1

With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function

[Robert123]

It works great! Thank you very much :bow: