Hi,

This is my first post trying to get help with some VBA code that's not working right.

I puzzled together an outlook macro from a few different online sources, that would take messages in the outbox and attach documents and enter CCd emails based on a table in a word document (it prompts for the word doc). When you use the same excel sheet to merge the emails and the table, it matches the correct attachments and CCs with the correct email recipients.

It works fine the first time I use it, and for up to 65 emails in the outbox. However, it does not attach things for more than 65 people, and when I try to run it again without restarting Outlook, it does not prompt me for the table document - it just appears to be doing something, but no documents are attached. Two of my colleagues have had different problems - for one of them it just freezes outlook, and for the other it attaches the same document to all emails in the outbox, which is the very first one in the Word table.

If someone could look at the code below and tell me where I've screwed up? Any ideas of how to achieve the same thing (easily sending mass sends with customized attached documents and CCs if needed) in a different way would also be appreciated.

Thanks in advance!

PS: I am using Office Prof. Plus 2010 version 14.0.7145.5000

Sub SetCCandattach()
Dim Maillist As Document
Dim Datarange As Range, Datarangecc As Range
Dim i As Long, j As Long
Dim OutlookApp As Outlook.Application
Dim Item As Outlook.MailItem
Dim CCEmail As String, message As String, title As String
Dim Attachment As Object


' This sub assumes that this macro is being run from within Outlook
On Error Resume Next
Set OutlookApp = GetObject(, "Outlook.Application")


' Open the mailmerge table document
With Dialogs(wdDialogFileOpen)
.Show
End With
Set Maillist = ActiveDocument


' iterate through all items in the Outlook Outbox and adds an email from column 2 and an attachment from paths in colums 3plus
Dim olNS As Outlook.NameSpace
Dim MyFolder As Outlook.MAPIFolder
Dim count As Integer


' By following change eliminates the security access prompts!
'Set olNS = oOutlookApp.GetNamespace("MAPI")
Set olNS = ThisOutlookSession.GetNamespace("MAPI")
Set MyFolder = olNS.GetDefaultFolder(olFolderOutbox)
For i = 1 To MyFolder.Items.count
Set Item = MyFolder.Items(i)
Set Datarangecc = Maillist.Tables(1).Cell(i, 2).Range
Datarangecc.End = Datarangecc.End - 1
Item.CC = Datarangecc
For j = 3 To Maillist.Tables(1).Columns.count
Set Datarange = Maillist.Tables(1).Cell(i, j).Range
Datarange.End = Datarange.End - 1
Item.Attachments.Add Trim(Datarange.Text), olByValue, 1
Next j
Item.Save
Item.Send
count = count + 1
Next i
Set Item = Nothing


MsgBox count & " emails have had a cc added."


'Clean up
Set Maillist = Nothing
Set OutlookApp = Nothing


End Sub