|
|
Option Compare Database
Option Explicit
Dim mOutlookApp As Outlook.Application
Dim mNameSpace As Outlook.NameSpace
Dim mFolder As MAPIFolder
Dim mItem As MailItem
Dim fSuccess As Boolean
' First function sets the Outlook Application
' and Namespase objects and opens MS Outlook
Public Function GetOutlook() As Boolean
On Error Resume Next
' Assume success
fSuccess = True
Set mOutlookApp = GetObject(, "Outlook.application")
' If Outlook is NOT Open, then there will be an error.
' In case of error, attempt to open Outlook
If Err.Number > 0 Then
Err.clear
Set mOutlookApp = CreateObject("Outlook.application")
If Err.Number > 0 Then
MsgBox "Could not create Outlook object", vbCritical
fSuccess = False
Exit Function
End If
End If
' If we've made it this far, we have an Outlook App Object
' Now, set the NameSpace object to MAPI Namespace
Set mNameSpace = mOutlookApp.GetNamespace("MAPI")
If Err.Number > 0 Then
MsgBox "Could not create NameSpace object", vbCritical
fSuccess = False
Exit Function
End If
GetOutlook = fSuccess
End Function
' Next function reads user entered values and
' actually sends the message
Public Function SendMessage() As Boolean
On Error Resume Next
Dim strRecip As String
Dim strSubject As String
Dim strMsg As String
Dim strAttachment As String
strSubject = Nz(Me!txtSubject,"")
strRecip = Nz(Me!txtRecipient,"")
strMsg = Nz(Me!txtBody,"")
strAttachment = Nz(Me!txtAttachment,"")
If Len(strRecip) = 0 Then
strMsg = "You must provide a recipient."
MsgBox strMsg, vbExclamation, "Error"
Exit Function
End If
' Assume success
fSuccess = True
If GetOutlook Then
Set mItem = mOutlookApp.CreateItem(olMailItem)
mItem.Recipients.Add strRecip
mItem.Subject = strSubject
mItem.Body = strMsg
If Len(strAttachment) > 0 Then
mItem.Attachments.Add strAttachment
End If
mItem.Save
mItem.Send
End If
If Err.Number > 0 Then fSuccess = False
SendMessage = fSuccess
End Function
|