However, I noticed
an error whenever I send it out like out instructed.
A problem I have had in the past is that if you open the Outbox and edit
messages in there, sometimes Outlook will not send them. But in that
situation, no error message was displayed so I assume you are seeing
something else.
Do you happen to know if there is a way to do this all in one go?
1. If you are marking he messages manually, you could try the following VBA
instead. It should work from both Outlook and Word, but in Word you will
need to ensure that there is a reference to the Microsoft Office xx.0
Outlook Library (with the VBA macro openin the VBE Editor, use
Tools|References to check the appropriate version of the library).
Sub MarkAllInOutboxAsPrivate()
Dim l As Long
Dim oa As Outlook.Application
Dim ns As Outlook.NameSpace
Dim fn As Outlook.Folder
Dim mm As Outlook.MailItem
Dim at As Outlook.Attachment
Set oa = GetObject(, "Outlook.Application")
Set ns = oa.GetNamespace("MAPI")
Set fn = ns.GetDefaultFolder(olFolderOutbox)
For Each mm In fn.Items
mm.Sensitivity = olPrivate
mm.Save
mm.Send
Next
Set fn = Nothing
Set ns = Nothing
Set oa = Nothing
End Sub
2. The difficulty with trying to automate the entire process is that
a. I do not think you can programmatically switch Outlook sending on and
off, at least not from Outlook. But you might want to check that in an
Outlook group. But that means that a one-step solution has to be able to set
each e-mail Private before it leaves the Outbox, and the only reliable way I
know to do that is to set it Private before you send it (i.e. put it in the
Outbox) in the first place. That means that you cannot use Word
merge-to-email because you do not get the opportunity to change any of the
properties of the message other than the title, body, address and format.
b. Using Word merge, the only other approach is to create the messages you
want to send first, then use the Outlook object model to send them. I
believe the following code has a chance of doing what Merge to email (HTML
format) does but
- it is pretty much untried, apart from a brief test here
- you may have problems with Outlook security
- the HTML used as the body text is generated by saving filtered HTML
from Word. That will probably only work for relatively simple HTML without
images etc..
- There may be a (low) limit on the maximum size of HTML you can use
Sub EmailOneHTMLPagePerSourceRecWithBody()
' By Peter Jamieson, 2006
' You need
' - a reference to the Microsoft Office xx.0 Outlook Library
' - a reference to the Microsoft Scripting Runtime
Dim bOutlookStarted As Boolean
Dim bTerminateMerge As Boolean
Dim intSourceRecord As Integer
Dim objMailItem As Outlook.MailItem
Dim objMerge As Word.MailMerge
Dim objOutlook As Outlook.Application
Dim strMailSubject As String
Dim strMailTo As String
Dim strMailBody As String
Dim strOutputDocumentName As String
bOutlookStarted = False
bTerminateMerge = False
' Set up a reference to the
' Activedocument, partly because
' the ActiveDocument changes as you
' merge each record
Set objMerge = ActiveDocument.MailMerge
' Start Outlook as necessary
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set objOutlook = CreateObject("Outlook.Application")
bOutlookStarted = True
End If
With objMerge
' If no data source has been defined,
' do it here using OpenDataSource.
' But if it is already defined in the
' document, you should not need to
' define it here.
' .OpenDataSource _
' Name:="whatever"
intSourceRecord = 1
Do Until bTerminateMerge
.DataSource.ActiveRecord = intSourceRecord
' if we have gone past the end
' (and possibly, if there are no records)
' then the Activerecord will not be what
' we have just tried to set it to
If .DataSource.ActiveRecord <> intSourceRecord Then
bTerminateMerge = True
' the record exists
Else
' while we are looking at the
' correct activerecord,
' create the mail subject, body and "to"
' Just some sample code here - replace it with
' whatever you need
' NB, the field names here must match the field names Word sees
/exactly/
' case is significant, i.e.
' If your data source uses "firstname", use "firstname". If it uses
"Firstname", use "Firstname"
' In some cases Word may modify the names (e.g. if they contain spaces)
strMailSubject = _
"Results for " & _
objMerge.DataSource.DataFields("Firstname") & _
" " & objMerge.DataSource.DataFields("Lastname")
' Use a simple sample
' we will create the body dynamically later
' strMailBody = "<HTML><BODY><TABLE
BORDER=5><TR><TD>k</TD><TD>t</TD></TR></TABLE></BODY></HTML>"
' substitute your email address field name
strMailTo = objMerge.DataSource.DataFields("Emailaddress")
' create the document path name
' In this case it can be the same for every recipient,
' but if you want to retain copies of the
' document, you can use info. in the data source
' this is an example - insert your
' own pathname here
strOutputDocumentName = "c:\a\results.htm"
' strOutputDocumentName = _
' "c:\mymergeletters\_" & _
' .DataSource.DataFields("Lastname").Value & _
' " letter.doc"
.DataSource.FirstRecord = intSourceRecord
.DataSource.LastRecord = intSourceRecord
.Destination = wdSendToNewDocument
.Execute
' The Activedocument is always the
' output document
' Add any parameters you need to these calls
ActiveDocument.SaveAs strOutputDocumentName, wdFormatFilteredHTML
ActiveDocument.Close
' Now create a mail item
Set objMailItem = objOutlook.CreateItem(olMailItem)
With objMailItem
.BodyFormat = olFormatHTML
.Subject = strMailSubject
' use the dynamic body
.HTMLBody = getText(strOutputDocumentName)
' use a more static body
.HTMLBody = strMailBody
.To = strMailTo
' send the merged doc. as an attachment
'.Attachments.Add strOutputDocumentName, olByValue, 1
.Save
.Send
End With
Set objMailItem = Nothing
intSourceRecord = intSourceRecord + 1
End If
Loop
End With
' Close Outlook if appropriate
If bOutlookStarted Then
objOutlook.Quit
End If
Set objOutlook = Nothing
Set objMerge = Nothing
End Sub
Function getText(strPath As String)
' Return an entire HTML file (we don't check the format) as a string
On Error Resume Next
Dim objFSO As Scripting.FileSystemObject
Dim objTextStream As Scripting.TextStream
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FileExists(strPath) Then
getText = ""
Exit Function
End If
Set objTextStream = objFSO.OpenTextFile(strPath, Scripting.ForReading)
If objTextStream.AtEndOfStream Then
' I leave you to cope with these errors sensibly
MsgBox "Message body " & strPath & " is empty."
getText = ""
Exit Function
End If
getText = objTextStream.ReadAll
objTextStream.Close
Set objTextStream = Nothing
Set objFSO = Nothing
End Function
