' 05/29/2001

' updated 09/20/2008

'

' the purpose of this code is to send email programmatically from Access

' originally was a workaround for an Access 2000 bug

' does not require a reference to the Outlook object library

' possible alternative to mixed Office 2003/2007 environments

' standard module:

Option Compare Database

Option Explicit

Sub SendMail(ToWhom As String, TheSubject As String, TheMessage As String)

Dim clsSendObject As accSendObject

'

Set clsSendObject = New accSendObject

clsSendObject.SendObject acSendNoObject, , accOutputRTF, ToWhom, , , TheSubject, TheMessage, False

Set clsSendObject = Nothing

End Sub

' class module, named accSendObject:

Option Compare Database

Option Explicit

Private MAPISession As MAPI.Session

Private MAPIMessage As Message

Private MAPIRecipient As MAPI.Recipient

Private MAPIAttachment As MAPI.Attachment

Private reciparray

Private strFileName As String

Private Type OSVERSIONINFO

dwOSVersionInfoSize As Long

dwMajorVersion As Long

dwMinorVersion As Long

dwBuildNumber As Long

dwPlatformId As Long

szCSDVersion As String * 128

End Type

Private Const REG_SZ As Long = 1

Private Const REG_DWORD As Long = 4

Private Const HKEY_CURRENT_USER = &H80000001

Private Const ERROR_NONE = 0

Private Const ERROR_BADDB = 1

Private Const ERROR_BADKEY = 2

Private Const ERROR_CANTOPEN = 3

Private Const ERROR_CANTREAD = 4

Private Const ERROR_CANTWRITE = 5

Private Const ERROR_OUTOFMEMORY = 6

Private Const ERROR_INVALID_PARAMETER = 7

Private Const ERROR_ACCESS_DENIED = 8

Private Const ERROR_INVALID_PARAMETERS = 87

Private Const ERROR_NO_MORE_ITEMS = 259

Private Const KEY_ALL_ACCESS = &H3F

Private Const REG_OPTION_NON_VOLATILE = 0

Private Declare Function GetVersionEx Lib "kernel32" _

Alias "GetVersionExA" _

(ByRef lpVersionInformation As OSVERSIONINFO) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" _

(ByVal hKey As Long) As Long

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _

Alias "RegOpenKeyExA" _

(ByVal hKey As Long, _

ByVal lpSubKey As String, _

ByVal ulOptions As Long, _

ByVal samDesired As Long, _

phkResult As Long) As Long

Private Declare Function RegQueryValueExString Lib "advapi32.dll" _

Alias "RegQueryValueExA" _

(ByVal hKey As Long, _

ByVal lpValueName As String, _

ByVal lpReserved As Long, _

lpType As Long, _

ByVal lpData As String, _

lpcbData As Long) As Long

Private Declare Function RegQueryValueExLong Lib "advapi32.dll" _

Alias "RegQueryValueExA" _

(ByVal hKey As Long, _

ByVal lpValueName As String, _

ByVal lpReserved As Long, _

lpType As Long, lpData As Long, _

lpcbData As Long) As Long

Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" _

Alias "RegQueryValueExA" _

(ByVal hKey As Long, _

ByVal lpValueName As String, _

ByVal lpReserved As Long, _

lpType As Long, _

ByVal lpData As Long, _

lpcbData As Long) As Long

Private Declare Function GetTempPath Lib "kernel32" _

Alias "GetTempPathA" (ByVal nBufferLength As Long, _

ByVal lpBuffer As String) As Long

Public Enum accSendObjectOutputFormat

accOutputRTF = 1

accOutputTXT = 2

accOutputSNP = 3

accOutputXLS = 4

End Enum

Public Sub SendObject(Optional ObjectType As Access.AcSendObjectType = acSendNoObject, _

Optional ObjectName, _

Optional OutputFormat As accSendObjectOutputFormat, _

Optional EmailAddress, _

Optional CC, _

Optional BCC, _

Optional Subject, _

Optional MessageText, _

Optional EditMessage)

Dim strTmpPath As String * 512

Dim sTmpPath As String

Dim strExtension As String

Dim nRet As Long

StartMessagingAndLogon

Set MAPIMessage = MAPISession.Outbox.Messages.Add

If ObjectType <> -1 Then

If IsMissing(ObjectName) Or IsMissing(OutputFormat) Then

MsgBox "The object type, name, or output format is invalid. Unable to send message.", vbCritical

MAPISession.Outbox.Messages.Delete

GoTo accSendObject_Exit

Else

strExtension = GetExtension(OutputFormat)

nRet = GetTempPath(512, strTmpPath)

If (nRet > 0 And nRet < 512) Then

If InStr(strTmpPath, Chr(0)) > 0 Then

sTmpPath = RTrim(Left(strTmpPath, InStr(1, strTmpPath, Chr(0)) - 1))

End If

strFileName = sTmpPath & ObjectName & strExtension

End If

On Error Resume Next

DoCmd.OutputTo ObjectType, ObjectName, GetOutputFormat(OutputFormat), strFileName, False

If Err.Number = 0 Then

Set MAPIAttachment = MAPIMessage.Attachments.Add

With MAPIAttachment

.Name = ObjectName

.Type = CdoFileData

.Source = strFileName

End With

Kill strFileName

Else

MsgBox "The object type, name, or output format is invalid. Unable to send message.", vbCritical

MAPISession.Outbox.Messages.Delete

GoTo accSendObject_Exit

End If

End If

End If

If Not IsMissing(EmailAddress) Then

reciparray = Split(EmailAddress, ";", -1, vbTextCompare)

ParseAddress CdoTo

Erase reciparray

End If

If Not IsMissing(CC) Then

reciparray = Split(CC, ";", -1, vbTextCompare)

ParseAddress CdoCc

Erase reciparray

End If

If Not IsMissing(BCC) Then

reciparray = Split(BCC, ";")

ParseAddress CdoBcc

Erase reciparray

End If

If Not IsMissing(Subject) Then

MAPIMessage.Subject = Subject

End If

If Not IsMissing(MessageText) Then

MAPIMessage.Text = MessageText

End If

If IsMissing(EditMessage) Then EditMessage = True

MAPIMessage.Update

MAPIMessage.Send savecopy:=True, ShowDialog:=EditMessage

accSendObject_Exit:

'Log out of the MAPI session

MAPISession.Logoff

Set MAPIAttachment = Nothing

Set MAPIRecipient = Nothing

Set MAPIMessage = Nothing

Set MAPISession = Nothing

Exit Sub

End Sub

Private Sub ParseAddress(RecipientType As MAPI.CdoRecipientType)

Dim i As Variant

For Each i In reciparray

Set MAPIRecipient = MAPIMessage.Recipients.Add

With MAPIRecipient

.Name = i

.Type = RecipientType

.Resolve

End With

Set MAPIRecipient = Nothing

Next

End Sub

Private Function GetExtension(ObjectType As Long) As String

Select Case ObjectType

Case 1 'RTF

GetExtension = ".RTF"

Case 2 'TXT

GetExtension = ".TXT"

Case 3 'SNP

GetExtension = ".SNP"

Case 4 'XLS

GetExtension = ".XLS"

End Select

End Function

Private Function GetOutputFormat(ObjectType As Long)

Select Case ObjectType

Case 1 'RTF

GetOutputFormat = Access.acFormatRTF

Case 2 'TXT

GetOutputFormat = Access.acFormatTXT

Case 3 'SNP

GetOutputFormat = Access.acFormatSNP

Case 4 'XLS

GetOutputFormat = Access.acFormatXLS

End Select

End Function

Private Sub StartMessagingAndLogon()

Dim sKeyName As String

Dim sValueName As String

Dim sDefaultUserProfile As String

Dim osinfo As OSVERSIONINFO

Dim retvalue As Integer

On Error GoTo ErrorHandler

Set MAPISession = CreateObject("MAPI.Session")

'Try to logon. If this fails, the most likely reason is

'that you do not have an open session. The error

'-2147221231 MAPI_E_LOGON_FAILED will return. Trap

'the error in the ErrorHandler

MAPISession.Logon ShowDialog:=False, NewSession:=False

Exit Sub

ErrorHandler:

Select Case Err.Number

Case -2147221231 'MAPI_E_LOGON_FAILED

'Need to find out what OS is in use, the keys are different

'for WinNT and Win95.

osinfo.dwOSVersionInfoSize = 148

osinfo.szCSDVersion = Space$(128)

retvalue = GetVersionEx(osinfo)

Select Case osinfo.dwPlatformId

Case 0 'Unidentified

MsgBox "Unidentified Operating System. " & _

"Can't log onto messaging."

Exit Sub

Case 1 'Win95

sKeyName = "Software\Microsoft\" & _

"Windows Messaging " & _

"Subsystem\Profiles"

Case 2 'NT

sKeyName = "Software\Microsoft\Windows NT\" & _

"CurrentVersion\" & _

"Windows Messaging Subsystem\Profiles"

End Select

sValueName = "DefaultProfile"

sDefaultUserProfile = QueryValue(sKeyName, sValueName)

MAPISession.Logon ProfileName:=sDefaultUserProfile, _

ShowDialog:=False

Exit Sub

Case Else

MsgBox "An error has occured while attempting" & Chr(10) & _

"To create and logon to a new ActiveMessage session." & _

Chr(10) & "Please report the following error to your " & _

"System Administrator." & Chr(10) & Chr(10) & _

"Error Location: frmMain.StartMessagingAndLogon" & _

Chr(10) & "Error Number: " & Err.Number & Chr(10) & _

"Description: " & Err.Description

End Select

End Sub

Private Function QueryValue _

(sKeyName As String, _

sValueName As String)

Dim lRetVal As Long 'result of the API functions

Dim hKey As Long 'handle of opened key

Dim vValue As Variant 'setting of queried value

lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, _

sKeyName, _

0, _

KEY_ALL_ACCESS, _

hKey)

lRetVal = QueryValueEx(hKey, _

sValueName, _

vValue)

QueryValue = vValue

RegCloseKey (hKey)

End Function

Private Function QueryValueEx _

(ByVal lhKey As Long, _

ByVal szValueName As String, _

vValue As Variant) As Long

Dim cch As Long

Dim lrc As Long

Dim lType As Long

Dim lValue As Long

Dim sValue As String

On Error GoTo QueryValueExError

' Determine the size and type of data to be read

lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)

If lrc <> ERROR_NONE Then Error 5

Select Case lType

' For strings

Case REG_SZ:

sValue = String(cch, 0)

lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _

sValue, cch)

If lrc = ERROR_NONE Then

vValue = Left$(sValue, cch)

Else

vValue = Empty

End If

' For DWORDS

Case REG_DWORD:

lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _

lValue, cch)

If lrc = ERROR_NONE Then vValue = lValue

Case Else

'all other data types not supported

lrc = -1

End Select

QueryValueExExit:

QueryValueEx = lrc

Exit Function

QueryValueExError:

Resume QueryValueExExit

End Function