I am using the following code which I found on this site to generate e-mails from within my application. It works fine except a creates another session of Outlook everytime I call the routine even if I already have Outlook running. I'm using Access 2007 and Oitlook 2007.
Code:
Public Function SendMessage(varTo As Variant, strSubject As String, strBody As String, _
bolAutoSend As Boolean, bolSaveInOutbox As Boolean, bolAddSignature As Boolean, _
Optional varCC As Variant, Optional varBCC As Variant, Optional varReplyTo As Variant, Optional varAttachmentPath As Variant, Optional varImagePath As Variant, Optional varHtmlFooter As Variant) As Boolean
'=================================================================
'
'varto: a string of email addresses, multiples delimted by semi-colon
'strSubject: subject line for the email
'strBody: body of the email, must be wrapped in <html> </html> tags, and optionally any other formatting tags
'bolAutoSend: determines whether email is sent automatically or displayed to the user
'bolSaveInOutbox: determines if the message is saved in the outbox
'boladdsignature: determines if the user's default signature is added to the outgoing email
'varCC: (Optional) CC email addresses, multiples delimited by semi-colon
'varBCC: (Optional) BCC email addresses, multiples delimited by semi-colon
'varReplyTo (Optional) If specified sets the reply to email address, multiples delimited by semi-colon
'varAttachmentPath: (Optional) If specified attaches the file
'varImagePath: (Optional) If specified embeds the image in the body of the email
'varHtmlFooter: (Optional) If specifed, inserts an html file as a footer to the message.
'ASSUMPTIONS: Outlook, HTML message format, Word is the default editor
'When performing some of the optional steps the message is constructed in the following order
'signature then embedded image then footer then body text, so the actual email would read as follows
'body text, footer, embedded image, signature
'=================================================================
On Error GoTo HandleError
Dim i As Integer
Dim strtempfile As String
Dim strmsg As String
Dim objOutlook As Outlook.Application
Dim objNameSpace As Outlook.Namespace
Dim objInbox As Outlook.MAPIFolder
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim objInsp As Outlook.Inspector
Dim objword As Word.Application
Dim objdoc As Word.Document
Dim objrange As Word.Range
SendMessage = False
Set objOutlook = New Outlook.Application 'Create the Outlook session.
objOutlook.Session.Logon
Set objOutlookMsg = objOutlook.CreateItem(olMailItem) 'Create the message.
Set objNameSpace = objOutlook.GetNamespace("MAPI") 'Set MAPI Mail
Set objInbox = objNameSpace.GetDefaultFolder(olFolderInbox) 'Set Inbox
objInbox.Display 'Make Outlook visible
strBody = ReplaceCRLFwithBR(strBody) 'Replace any vbcrlf with <br>
If (InStr(strBody, "<font") = 0) Or (InStr(strBody, "<html>") = 0) Then 'if no <html> and <font> tags then wrap the body of the message with these tags
strBody = FormatAsHtml(strBody)
End If
With objOutlookMsg
If Not IsMissing(varTo) Then
If varTo <> "" And Not IsNull(varTo) Then
For i = 1 To CountCSWords(varTo)
Set objOutlookRecip = .Recipients.Add(GetCSWord(varTo, i)) 'Add the TO recipient(s) to the message.
objOutlookRecip.Type = olTo
Next i
End If
End If
If Not IsMissing(varCC) Then
If varCC <> "" And Not IsNull(varCC) Then
For i = 1 To CountCSWords(varCC)
Set objOutlookRecip = .Recipients.Add(GetCSWord(varCC, i)) 'Add the cc recipient(s) to the message.
objOutlookRecip.Type = olCC
Next i
End If
End If
If Not IsMissing(varBCC) Then
If varBCC <> "" And Not IsNull(varBCC) Then
For i = 1 To CountCSWords(varBCC)
Set objOutlookRecip = .Recipients.Add(GetCSWord(varBCC, i)) 'Add the bcc recipient(s) to the message.
objOutlookRecip.Type = olBCC
Next i
End If
End If
If Not IsMissing(varReplyTo) Then
If varReplyTo <> "" And Not IsNull(varReplyTo) Then
For i = 1 To CountCSWords(varReplyTo)
Set objOutlookRecip = .ReplyRecipients.Add(GetCSWord(varReplyTo, i)) 'Add the bcc recipient(s) to the message.
Next i
End If
End If
If (Not IsMissing(varAttachmentPath)) Then 'if attachment is specified
If (varAttachmentPath <> "") And (Not IsNull(varAttachmentPath)) Then 'check it is valid
If Dir(varAttachmentPath, vbHidden + vbSystem + vbReadOnly + vbDirectory) <> "" Then 'check the file actually exists
Set objOutlookAttach = .Attachments.Add(CStr(varAttachmentPath)) 'Add attachments to the message.
End If
End If
End If
.Subject = strSubject 'Set the Subject of the message.
.BodyFormat = olFormatHTML 'set format to html
If bolAddSignature Or Not IsMissing(varImagePath) Or Not IsMissing(varHtmlFooter) Then 'if signature or embedded image or html footer
Set objInsp = objOutlookMsg.GetInspector 'this causes the default signature to be added to the message
Set objdoc = objInsp.WordEditor
If objdoc Is Nothing Then
strmsg = "Outlook must use Word as the email editor. Follow these instructions to fix the problem." & vbCrLf & vbCrLf & _
"Tools>Options" & vbCrLf & "Then select 'Mail Format' tab" & vbCrLf & "Ensure Use Microsoft Office Word 2003 to edit e-mail messages."
MsgBox strmsg
objOutlookMsg.Close olDiscard
GoTo SendMessage_Done
End If
Set objword = objdoc.Application
If bolAddSignature = False Then 'If the user had a signature it would have been applied, if we dont want it then we need to delete it here
objdoc.Range.Delete
End If
If Not IsMissing(varImagePath) Then
If varImagePath <> "" And Not IsNull(varImagePath) Then
If Dir(varImagePath, vbHidden + vbSystem + vbReadOnly + vbDirectory) <> "" Then
On Error Resume Next
.Display 'Seems like word document must be visible before you can use addpicture method
If Err <> 0 Then 'if the mail cound not be displayed then display a warning and discard the message
MsgBox "It was not possible to display the message, check that there are no dialog boxes open in Outlook." & vbCrLf & "Please close all Outlook windows and emails, and then attempt this update again.", vbCritical
.Close olDiscard
GoTo SendMessage_Done
End If
objword.WindowState = wdWindowStateMinimize 'minimize word application so user does not see mail being created
Set objrange = objdoc.Range(Start:=0, End:=0) 'goto start of message again
objrange.InsertBefore vbCrLf
objdoc.InlineShapes.AddPicture Filename:=varImagePath, LinkToFile:=False, SaveWithDocument:=True, Range:=objrange
End If
End If
End If
If Not IsMissing(varHtmlFooter) Then
If varHtmlFooter <> "" And Not IsNull(varHtmlFooter) Then
If Dir(varHtmlFooter, vbHidden + vbSystem + vbReadOnly + vbDirectory) <> "" Then
Set objrange = objdoc.Range(Start:=0, End:=0) 'goto start of message
objrange.InsertFile varHtmlFooter, , , False, False 'insert the html from the external file
End If
End If
End If
strtempfile = Environ("temp") & Format(Now(), "yyyymmddhhnnss") & ".htm" 'generate temp filename
Set objrange = objdoc.Range(Start:=0, End:=0) 'goto start of message again
CreateTextFile strtempfile, strBody 'save the bodytext as a temporary htm file
objrange.InsertFile strtempfile, , , False, False 'insert the htm file into the body of the message
Kill strtempfile 'delete temp file
objdoc.SpellingChecked = True 'doesnt matter for autosend, but helps the user if the message is being displayed
Else
.HTMLBody = strBody
End If
If bolSaveInOutbox = False Then 'if message not to be saved after sending
.DeleteAfterSubmit = True 'specify that it should be deleted
End If
If (bolAutoSend = True) And (.Recipients.Count > 0) Then 'check that there is at least 1 recipient before trying to autosend
.Send
Else
Err = 0
On Error Resume Next
.Display 'Attempt to display the message
If Err <> 0 Then 'if the mail cound not be displayed then display a warning and discard the message
MsgBox "It was not possible to display the message, check that there are no dialog boxes open in Outlook." & vbCrLf & "Please close all Outlook windows and emails, and then attempt this update again.", vbCritical
.Close olDiscard
GoTo SendMessage_Done
End If
End If
End With
SendMessage = True
SendMessage_Done:
Set objOutlook = Nothing
Set objNameSpace = Nothing
Set objInbox = Nothing
Set objOutlookMsg = Nothing
Set objOutlookRecip = Nothing
Set objOutlookAttach = Nothing
Set objInsp = Nothing
Set objword = Nothing
Set objdoc = Nothing
Set objrange = Nothing
Exit Function
HandleError:
MsgBox Err.Number & ":" & Err.Description, vbCritical
Resume SendMessage_Done
End Function
Public Function ReplaceCRLFwithBR(ByVal strText) As String
'=================================================================
'Replace all vbcrlf with <br> to keep line breaks in html emails
'=================================================================
strText = Replace(strText, Chr(13), "<br>")
strText = Replace(strText, Chr(10), "")
ReplaceCRLFwithBR = strText
End Function
Public Function FormatAsHtml(ByVal str) As String
'=================================================================
'Wraps a string in html tags
'=================================================================
FormatAsHtml = "<html><font face=""arial"" size=""2"">" & str & "</font></html>"
End Function
Public Function GetCSWord(ByVal str, Indx As Integer, Optional strdelimiter = ";") As String
'=================================================================
'Returns the nth word in a specific field
'=================================================================
On Error Resume Next
GetCSWord = Split(str, strdelimiter)(Indx - 1)
End Function
Function CountCSWords(ByVal str, Optional strdelimiter = ";") As Integer
'=================================================================
'Counts the words in the delimited string
'=================================================================
Dim WC As Integer, Pos As Integer
If VarType(str) <> 8 Or Len(str) = 0 Then
CountCSWords = 0
Exit Function
End If
WC = 1
Pos = InStr(str, strdelimiter)
Do While Pos > 0
WC = WC + 1
Pos = InStr(Pos + 1, str, strdelimiter)
Loop
CountCSWords = WC
End Function
Public Sub CreateTextFile(strFullPath As String, strText As String)
'=================================================================
'Creates a text file with the specified file name containing the supplied text
'=================================================================
Dim fso As Object
Dim MyFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.CreateTextFile(strFullPath, True) 'Creates file, existing file will be overwritten
MyFile.WriteLine (strText) 'writes string to the file
MyFile.Close 'close the file
End Sub
Public Function GetTextFile(ByVal strFile As String) As String
'=================================================================
'Returns a string that contains the contents of the specified file
'=================================================================
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(strFile).OpenAsTextStream(1, -2) 'Open the file ForReading, Use system default for file format
GetTextFile = ts.readall 'Read the contents of the file
ts.Close 'Close the file
End Function
.
