' 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