Outlook Macro not performing as expected

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

Hmmm. The forum and the code itself suggests that you are running the macro from Outlook, whereas it looks like a Word macro. If you want to run it from Outlook it will need some changes. Also as you have not made the Maillist document available it is difficult to see the relationship between it and the messages in the Outbox. It would appear to make more sense to add the CC and the Attachments before the messages ever get to the Outbox, but your message does not relate to that.

If you are sending messages using mailmerge and want to add a CC and attachments then take a look at http://www.gmayor.com/ManyToOne.htm in its One to One mode. The data will have to be transferred from Word to Excel in order to employ that.

The following should allow your macro to be run from Outlook, but how you can be certain the correct CC and attachments are going to the recipients, I have no idea ... unless of course it is the same three attachments and CC you are adding to all, in which case I wouldn't use the table in this way.

Code:

---

Sub SetCCandattach()
Dim wdApp As Object
Dim Maillist As Object
Dim Datarange As Object, Datarangecc As Object
Dim i As Long, j As Long
Dim Item As Outlook.MailItem
Dim Attachment As Attachment
Dim olNS As Outlook.NameSpace
Dim MyFolder As Outlook.MAPIFolder
Dim count As Integer
Dim strFileName As String

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

    ' Open the mailmerge table document

    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0

    With wdApp.Dialogs(80)
        If .Show <> -1 Then
            MsgBox "Cancelled By User"
            GoTo lbl_Exit
        End If
    End With
    Set Maillist = wdApp.activedocument
    ' iterate through all items in the Outlook Outbox and adds an email from column 2 and an attachment from paths in colums 3plus


    ' By following change eliminates the security access prompts!
    'Set olNS = oOutlookApp.GetNamespace("MAPI")
    Set olNS = 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
            If FileExists(Trim(Datarange.Text)) Then
                Item.Attachments.Add Trim(Datarange.Text), olByValue, 1
            End If
        Next j
        Item.Save
        Item.sEnd
        count = count + 1
    Next i
    Maillist.Close 0
    MsgBox count & " emails have had a cc added."

    'Clean up
lbl_Exit:
    Set Maillist = Nothing
    Set wdApp = Nothing
    Set Datarangecc = Nothing
    Set Datarange = Nothing
    Set olNS = Nothing
    Set Item = Nothing
    Set MyFolder = Nothing
    Exit Sub
End Sub

Private Function FileExists(filespec) As Boolean
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

---

Thank you very much for your quick reply Graham!

It seems to work much better now - thank you! I wish I understood all of your changes, but I will be working on that :)
Thank you also for pointing me to your very comprehensive solution. It is, unfortunately, a little too comprehensive for us, I think - can't give my colleagues too many options or they'll get confused...

The macro attaches the right files to the right emails in the outbox because both the table and the messages are created using the same list in the same order. Sort of like your mail merge attachments macro that works from Word, just that you don't have to turn your message into html first. It's working anyway!

One thing that I don't seem to be able to do is to have outlook pop back up after the macro is finished. The maillist doc closes, but if another Word doc is open, that remains the active window. I tried to put the "Set OutlookApp = GetObject(, "Outlook.Application")" back in at the end (you were right to take it out at the beginning since it is activated from Outlook), which, as far as I can tell from other sources should do the trick - but it's not working. Any guidance would be much appreciated.

Code:

---

Sub TableCCandattach()
Dim wdApp As Object
Dim Maillist As Object
Dim Datarange As Object, Datarangecc As Object
Dim i As Long, j As Long
Dim Item As Outlook.MailItem
Dim Attachment As Attachment
Dim olNS As Outlook.NameSpace
Dim MyFolder As Outlook.MAPIFolder
Dim count As Integer
Dim strFileName As String
Dim OutlookApp As Outlook.Application

    ' This sub assumes that this macro is being run from within Outlook
    On Error Resume Next
    ' Open the mailmerge table document

    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0

    With wdApp.Dialogs(80)
        If .Show <> -1 Then
            MsgBox "Cancelled By User"
            GoTo lbl_Exit
        End If
    End With
    Set Maillist = wdApp.ActiveDocument
   
    ' iterate through all items in the Outlook Outbox and adds an email  from column 2 and an attachment from paths in colums 3plus
    ' By following change eliminates the security access prompts!
    'Set olNS = oOutlookApp.GetNamespace("MAPI")
    Set olNS = 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
            If FileExists(Trim(Datarange.Text)) Then
                Item.Attachments.Add Trim(Datarange.Text), olByValue, 1
            End If
        Next j
        Item.Save
        Item.Send
        count = count + 1
    Next i
    Maillist.Close
    MsgBox count & " emails have had a cc and attachment added."
    Set OutlookApp = GetObject(, "Outlook.Application")

    'Clean up
lbl_Exit:
    Set Maillist = Nothing
    Set wdApp = Nothing
    Set Datarangecc = Nothing
    Set Datarange = Nothing
    Set olNS = Nothing
    Set Item = Nothing
    Set MyFolder = Nothing
    Exit Sub
End Sub

Private Function FileExists(filespec) As Boolean
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

---

I have another macro that lets my colleagues attach the same document to all messages in their outbox, but on some of my colleagues computers the 'browsing' function doesn't work, which is probably due to it 'high-jacking' Word's 'browse for file' functionality. Your browsing function (as far as I can tell the '.Dialogs(80)' piece) seems to be much for elegant, but I can't figure out how to make this work for ANY file type they may want to choose (rather than just word). I am including my code (which works on most machines) that I've already tried to cleanup a little bit based on your input for the above. Thanks again!

Code:

---

Sub Setattachmentbrowse()
Dim i As Long
Dim OutlookApp As Outlook.Application
Dim Item As Outlook.MailItem
Dim FilePath As String
Dim olNS As Outlook.NameSpace
Dim MyFolder As Outlook.MAPIFolder
Dim count As Integer

On Error Resume Next

'ask which file to attach
FilePath = GetFile("C:\")

'iterate through all items in the Outlook Outbox
'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)
            Item.Attachments.Add Trim(FilePath), olByValue, 1
            Item.Save
            Item.Send
            count = count + 1
        Next i
        Set Item = Nothing

MsgBox count & " files have been attached."

'Clean up
lbl_Exit:
Set OutlookApp = Nothing
Set Item = Nothing
Set olNS = Nothing
Set MyFolder = Nothing
Exit Sub

End Sub

Function GetFile(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Dim otherObject As Word.Application
Dim fdFile As office.FileDialog

    Set otherObject = New Word.Application
    otherObject.Visible = False
    Set fdFile = otherObject.Application.FileDialog(msoFileDialogFilePicker)
    With fdFile
    .title = "Select a File"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetFile = sItem
Set fdFile = Nothing
    otherObject.Quit
    Set otherObject = Nothing
lbl_Exit:
    Exit Function

End Function

---

You are presumably using Outlook without the option to send files immediately so they are accummulated in the outbox, where you are processing them. The problem with this is that there may be other unrelated e-mail messages pending in the outbox that would screw up your process.

The easiest way to keep the Word window out of the way is to minimize it

Code:

---

wdApp.Application.WindowState = 2

---

Do this after declaring wdApp immediately before

Code:

---

On Error Goto 0

---

Code:

---

Dialogs(80)

---

is exactly the same command as

Code:

---

Dialogs(wdDialogFileOpen)

---

but the numeric equivalent is used to allow late binding to Word (there is no need to set a reference to Word in Tools > References when using the code I posted).

The probable reason your GetFile function doesn't work for some is that they don't have Word declared as a reference in their Outlook VBA editors. This is why I prefer to use Late Binding to other office apps. It is harder to program with late binding, but it improves compatibility. GetFile is the better option so I have modified it to work from my version of the original code. It doesn't need yet another instance of Word as you already have Word opened, so use that one.

Code:

---

Option Explicit

Sub SetCCandattach()
Dim wdApp As Object
Dim Maillist As Object
Dim Datarange As Object, Datarangecc As Object
Dim i As Long, j As Long
Dim Item As Outlook.MailItem
Dim Attachment As Attachment
Dim olNS As Outlook.NameSpace
Dim MyFolder As Outlook.MAPIFolder
Dim count As Integer
Dim strFileName As String
Dim bStarted As Boolean
Const strPath As String = "C:\Path\" 'The initial filepath for the maillist document

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

    ' Open the mailmerge table document

    Set wdApp = GetObject(, "Word.Application") 'Get Word if it is already running
    If Err Then
        Set wdApp = CreateObject("Word.Application") 'or create it if it isn't
        bStarted = True
    End If
    wdApp.Application.WindowState = 2 'Minimize Word
    On Error GoTo 0
    strFileName = GetFile(wdApp, strPath) 'Get the maillist filename
    If strFileName = "" Then
        MsgBox "Process cancelled"
        GoTo lbl_Exit 'User cancelled
    End If
   
    Set Maillist = wdApp.documents.Open(strFileName) 'Open the selected document
    ' iterate through all items in the Outlook Outbox and adds an email from column 2 and an attachment from paths in colums 3plus


    ' By following change eliminates the security access prompts!
    'Set olNS = oOutlookApp.GetNamespace("MAPI")
    Set olNS = 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
            If FileExists(Trim(Datarange.Text)) Then
                Item.Attachments.Add Trim(Datarange.Text), olByValue, 1
            End If
        Next j
        Item.Save
        Item.sEnd
        count = count + 1
    Next i
    Maillist.Close 0
    MsgBox count & " emails have had a cc added."

    'Clean up
lbl_Exit:
    If bStarted Then wdApp.Quit
    Set Maillist = Nothing
    Set wdApp = Nothing
    Set Datarangecc = Nothing
    Set Datarange = Nothing
    Set olNS = Nothing
    Set Item = Nothing
    Set MyFolder = Nothing
    Exit Sub
End Sub

Private Function FileExists(filespec) As Boolean
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

Function GetFile(OtherObject As Object, strPath As String) As String
Dim sItem As String
Dim fdFile As office.FileDialog
    Set fdFile = OtherObject.FileDialog(msoFileDialogFilePicker)
    With fdFile
        .Title = "Select a File"
        .AllowMultiSelect = False
        .InitialFileName = strPath & "*.docx"
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
    GetFile = sItem
lbl_Exit:
    Set fdFile = Nothing
    Exit Function
NextCode:
    GetFile = ""
    GoTo lbl_Exit
End Function

---