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.
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!
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