' 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