Program to mail merge attachments

[Rayashe]

Is there some VBA code that can be executed so that a mail merge can be done
to email as an attachment and get around the Outlook 'Allow' hurdle?

 

[Doug Robbins - Word MVP]

You can mail merge to email with attachments by following the procedure in
the article "Mail Merge to E-mail with Attachments" at:

http://word.mvps.org/FAQs/MailMerge/MergeWithAttachments.htm

But it still requires you to navigate the "Outlook 'Allow' hurdle" that you
were hoping to avoid.

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP

 

[Rand8203]

Hello,

I have incorporated the email merge attachment procedure into a template I
have create and I am having some trouble. In my template I have one user
enter some information via a form and then the template saveas to a word
document at a location I selected. I then use the email merge attachment
procedure to e-mail the saved word document to a second user who then enters
some additional information and then the word document saveas the same file
as before. The issue is I am getting a message indicating that the file I am
saving to is being used by a program and cannot be saved over. If I remove
the email merge attachment procedure I am able to run both user's parts. It
appears that the email merge attachement procedure causes a tmp file to be
created for the document as it is being attached, for a loss/recovery action,
as an improper closing of the file would have. Is there a way around this
automatically? So the user does not have to go a delete the tmp file? I don't
want to save to a different filename if it can be avoided.

If needed I can e-mail the template so my code can be examined in greater
detail.

 

[Doug Robbins - Word MVP]

For a single document, I would not be using the mail merge with attachment
utility.

See the article "How to send an email from Word using VBA" at:

http://www.word.mvps.org/FAQs/InterDev/SendMail.htm

If you want to show us your code, copy and paste it into a message that you
post back here.


--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP

 

[Rand8203]

First off Thank you for the link it was helpful. The only ways I have gotten
this to work is by using the routing slip and by using two save locations.
The first is less than ideal as I cannot add a e-mail body message and the
second gets away from the only having one file. The one aspect of the
mailmerge that I really like is the external maintenance of the e-mail list.
That way the end user could maintain the list and not have to know anything
about vba. I am going to keep playing with the code to see if I can achieve
all my objectives.

Thanks again for your help. Any insight to my below code would be greatly
appreciated. I have the mailmerge and send document as attachment subs in
the code but do not call them.


Option Explicit

Public bSignFormOK As Boolean
Public bMSignFormOK As Boolean
Public myDoc As Document
Public DHForm As UserForm1
Public DHMForm As UserForm2
Dim DHRepCmbBxVal As String
Dim DHMgrCmbBxVal As String

Sub AutoNew()
Set myDoc = ActiveDocument
Set DHForm = New UserForm1
Load DHForm
DHForm.Show
If bSignFormOK = True Then
CollectDHFormValues
Unload DHForm
Set DHForm = Nothing
Else
Unload DHForm
Set DHForm = Nothing
End If
If bSignFormOK = True Then BuildDoc Else myDoc.Close wdDoNotSaveChanges
End Sub

Sub MgrReview()
Set myDoc = ActiveDocument
Set DHMForm = New UserForm2
Load DHMForm
DHMForm.Show
If bMSignFormOK = True Then
CollectDHMFormValues
Unload DHMForm
Set DHMForm = Nothing
Else
Unload DHMForm
Set DHMForm = Nothing
End If
If bMSignFormOK = True Then AddMgrValues Else myDoc.Close
wdDoNotSaveChanges
End Sub

Private Sub CollectDHFormValues()
With DHForm
DHRepCmbBxVal = .RepNameCmbBx.Value
End With
End Sub

Private Sub CollectDHMFormValues()
With DHMForm
DHMgrCmbBxVal = .MgrNameCmbBx.Value
End With
End Sub

Sub BuildDoc()
If myDoc.ProtectionType <> wdNoProtection Then myDoc.Unprotect "inquiry"
InsertBookmarkValue "Report1", "Yes"
InsertBookmarkValue "Report2", "Yes"
InsertBookmarkValue "Report3", "Yes"
InsertBookmarkValue "Report4", "Yes"
InsertBookmarkValue "Report5", "Yes"
InsertBookmarkValue "Report6", "Yes"
InsertBookmarkValue "Report7", "Yes"
InsertBookmarkValue "Report8", "Yes"
InsertBookmarkValue "Report9", "Yes"
InsertBookmarkValue "Report10", "Yes"
InsertBookmarkValue "Report11", "Yes"
InsertBookmarkValue "Report12", "Yes"
InsertBookmarkValue "Report13", "Yes"
InsertBookmarkValue "Report14", "Yes"
InsertBookmarkValue "Report15", "Yes"
InsertBookmarkValue "Report16", "Yes"
InsertBookmarkValue "Report17", "Yes"
InsertBookmarkValue "RepName", DHRepCmbBxVal
With ActiveWindow.View
.ShowBookmarks = False
.ShowHiddenText = False
.ShowAll = False
End With
myDoc.Protect wdAllowOnlyFormFields, True, "inquiry"
' myDoc.SaveAs FileName:="Q:\Inquiry Research\Templates\Daily Holdover
Report Checklist.doc", Fileformat:=wdFormatDocument
' EmailMergeWithAttachment
' SendDocumentAsAttachment
myDoc.HasRoutingSlip = True
With myDoc.RoutingSlip
.Subject = "Please Complete the Manager Review of the Daily Holdover
Checklist."
.AddRecipient "(e-mail address removed)"
.Delivery = wdAllAtOnce
End With
myDoc.Route
End Sub

Sub AddMgrValues()
If myDoc.ProtectionType <> wdNoProtection Then myDoc.Unprotect "inquiry"
InsertBookmarkValue "ReportM1", "Yes"
InsertBookmarkValue "ReportM2", "Yes"
InsertBookmarkValue "ReportM3", "Yes"
InsertBookmarkValue "ReportM4", "Yes"
InsertBookmarkValue "ReportM5", "Yes"
InsertBookmarkValue "ReportM6", "Yes"
InsertBookmarkValue "ReportM7", "Yes"
InsertBookmarkValue "ReportM8", "Yes"
InsertBookmarkValue "ReportM9", "Yes"
InsertBookmarkValue "ReportM10", "Yes"
InsertBookmarkValue "ReportM11", "Yes"
InsertBookmarkValue "ReportM12", "Yes"
InsertBookmarkValue "ReportM13", "Yes"
InsertBookmarkValue "ReportM14", "Yes"
InsertBookmarkValue "ReportM15", "Yes"
InsertBookmarkValue "ReportM16", "Yes"
InsertBookmarkValue "ReportM17", "Yes"
InsertBookmarkValue "MgrName", DHMgrCmbBxVal
With ActiveWindow.View
.ShowBookmarks = False
.ShowHiddenText = False
.ShowAll = False
End With
myDoc.Protect wdAllowOnlyFormFields, True, "inquiry"
myDoc.SaveAs FileName:="Q:\Inquiry Research\Templates\Daily Holdover
Report Checklist.doc", Fileformat:=wdFormatDocument
End Sub

Sub InsertBookmarkValue(BkmkName As String, Value As String)
With myDoc
If .Bookmarks.Exists(BkmkName) = True Then
Dim myRange As Range
Set myRange = .Bookmarks(BkmkName).Range
myRange.Text = Value
.Bookmarks.Add BkmkName, myRange
End If
End With
End Sub

Sub EmailMergeWithAttachment()
Dim mySource As Document, myMailList As Document
Dim myRange As Range
Dim myCounter As Integer, i As Integer
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim mySubject As String, myBody As String
Set mySource = ActiveDocument
'Check if outlook is running. If not, then start Outlook
bStarted = False
On Error Resume Next
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
'Open the catalog mailmerge document
Documents.Open FileName:="Q:\Inquiry Research\Templates\Email List.Doc"
Set myMailList = ActiveDocument
'Set Email subject and body
mySubject = "Please Complete the Manager Review of the Daily Holdover
Report Checklist"
myBody = "Please complete the Manager Review of the Daily Holdover
Report Checklist. Open the attached file and hit [Ctrl + Alt + `]. The '`'
key is on the left of the keyboard above the tab."
'Iterate through the rows of the catalog mailmerge document, extratcting the
information
'to be included in each email
myCounter = 1
While myCounter <= myMailList.Tables(1).Rows.Count
myDoc.Sections.First.Range.Cut
Documents.Add
Selection.Paste
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
.Subject = mySubject
.Body = myBody
Set myRange = myMailList.Tables(1).Cell(myCounter, 1).Range
myRange.End = myRange.End - 1
.To = myRange
For i = 2 To myMailList.Tables(1).Columns.Count
Set myRange = myMailList.Tables(1).Cell(myCounter, i).Range
myRange.End = myRange.End - 1
.Attachments.Add Trim(myRange.Text), olByValue, 1
Next i
.Send
End With
Set oItem = Nothing
myCounter = myCounter + 1
Wend
'Close Outlook if it was started by this macro
If bStarted Then oOutlookApp.Quit
'Clean up
Set oOutlookApp = Nothing
myDoc.Close wdDoNotSaveChanges
myMailList.Close wdDoNotSaveChanges
End Sub

Sub SendDocumentAsAttachment()
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem

Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If

Set oItem = oOutlookApp.CreateItem(olMailItem)

With oItem
.To = "(e-mail address removed)"
.Subject = "Please Complete the Manager Review of the Daily Holdover
Checklist."
.Body = "Please complete the Manager Review of the Daily Holdover
Report Checklist. Open the attached file and hit [Ctrl + Alt + `]. The '`'
key is on the left of the keyboard above the tab."
.Attachments.Add Source:="Q:\Inquiry Research\Templates\Daily
Holdover Report Checklist.doc", Type:=olByValue
.Send
End With

If bStarted Then oOutlookApp.Quit
Set oItem = Nothing
Set oOutlookApp = Nothing
End Sub