CodeItBetter Programming Another VB Programming Blog

'Internet - How to send mail With MAPI.
Option Explicit
 
'-- used for sending mail with api and outlook objects
'-- can be used in MS Access or Visual Basic
'-- MAPI constants
Public Const MAPI_AB_NOMODIFY = &H400
Public Const MAPI_BCC = 3
Public Const MAPI_BODY_AS_FILE = &H200
Public Const MAPI_CC = 2
Public Const MAPI_DIALOG = &H8
Public Const MAPI_E_AMBIGUOUS_RECIPIENT = 21
Public Const MAPI_E_AMBIG_RECIP = MAPI_E_AMBIGUOUS_RECIPIENT
Public Const MAPI_E_ATTACHMENT_NOT_FOUND = 11
Public Const MAPI_E_ATTACHMENT_OPEN_FAILURE = 12
Public Const MAPI_E_ATTACHMENT_WRITE_FAILURE = 13
Public Const MAPI_E_BAD_RECIPTYPE = 15
Public Const MAPI_E_BLK_TOO_SMALL = 6
Public Const MAPI_E_DISK_FULL = 4
Public Const MAPI_E_FAILURE = 2
Public Const MAPI_E_INSUFFICIENT_MEMORY = 5
Public Const MAPI_E_INVALID_EDITFIELDS = 24
Public Const MAPI_E_INVALID_MESSAGE = 17
Public Const MAPI_E_INVALID_RECIPS = 25
Public Const MAPI_E_INVALID_SESSION = 19
Public Const MAPI_E_LOGIN_FAILURE = 3
Public Const MAPI_E_LOGON_FAILURE = MAPI_E_LOGIN_FAILURE
Public Const MAPI_E_MESSAGE_IN_USE = 22
Public Const MAPI_E_NETWORK_FAILURE = 23
Public Const MAPI_E_NO_MESSAGES = 16
Public Const MAPI_E_NOT_SUPPORTED = 26
Public Const MAPI_E_TEXT_TOO_LARGE = 18
Public Const MAPI_E_TOO_MANY_FILES = 9
Public Const MAPI_E_TOO_MANY_RECIPIENTS = 10
Public Const MAPI_E_TOO_MANY_SESSIONS = 8
Public Const MAPI_E_TYPE_NOT_SUPPORTED = 20
Public Const MAPI_E_UNKNOWN_RECIPIENT = 14
Public Const MAPI_ENVELOPE_ONLY = &H40
Public Const MAPI_FORCE_DOWNLOAD = &H1000
Public Const MAPI_GUARANTEE_FIFO = &H100
Public Const MAPI_LOGOFF_SHARED = &H1
Public Const MAPI_LOGOFF_UI = &H2
Public Const MAPI_LOGON_UI = &H1
Public Const MAPI_NEW_SESSION = &H2
Public Const MAPI_OLE = &H1
Public Const MAPI_OLE_STATIC = &H2
Public Const MAPI_ORIG = 0
Public Const MAPI_PEEK = &H80
Public Const MAPI_RECEIPT_REQUESTED = &H2
Public Const MAPI_SENT = &H4
Public Const MAPI_SUPPRESS_ATTACH = &H800
Public Const MAPI_TO = 1
Public Const MAPI_UNREAD = &H1
Public Const MAPI_UNREAD_ONLY = &H20
Public Const MAPI_USER_ABORT = 1
Public Const MAPI_E_USER_ABORT = MAPI_USER_ABORT
Public Const SUCCESS_SUCCESS = 0
 
'-- mapi message recipient object type
Public Type MapiRecip
    Reserved As Long
    RecipClass As Long
    Name As String
    Address As String
    EIDSize As Long
    EntryID As String
End Type
 
'-- mapi message file object type
Public Type MapiFile
    Reserved As Long
    Flags As Long
    Position As Long
    PathName As String
    FileName As String
    FileType As String
End Type
 
'-- mapi message object type
Public Type MAPIMessage
    Reserved As Long
    Subject As String
    NoteText As String
    MessageType As String
    DateReceived As String
    ConversationID As String
    Flags As Long
    RecipCount As Long
    FileCount As Long
End Type
 
Public Declare Function MAPILogoff Lib "MAPI32.DLL" (ByVal Session&, ByVal UIParam&, _
    ByVal Flags&, ByVal Reserved&) As Long
Public Declare Function MAPILogon Lib "MAPI32.DLL" (ByVal UIParam&, ByVal User$, _
    ByVal Password$, ByVal Flags&, ByVal Reserved&, Session&) As Long
Public Declare Function MAPISendMail Lib "MAPI32.DLL" Alias "BMAPISendMail" (ByVal Session&, _
    ByVal UIParam&, Message As MAPIMessage, Recipient() As MapiRecip, File() As MapiFile, _
    ByVal Flags&, ByVal Reserved&) As Long
 
Public Function api_SendMail(sTo As String, sSubject As String, sMessage As String)
    '-- use api functions to send mail
    On Error GoTo Err_Trap
    Dim Rtn As Long    '-- return value For api calls
    Dim objMsg As MAPIMessage    '-- message object
    Dim objRec() As MapiRecip    '-- recipient object array
    Dim objFile() As MapiFile    '-- file object array
    Dim hMAPI As Long    '-- session handle
    ReDim objRec(1)
    ReDim objFile(1)
    '-- file object *************************************************
    '     *************
    '-- default - not expecting to send a file
    objFile(0).Reserved = 0
    '-- values not used for file
    'objFile(0).Flags
    'objFile(0).Position
    'objFile(0).PathName
    'objFile(0).FileName
    'objFile(0).FileType
    '-- recipient object ********************************************
    '     *************
    objRec(0).Reserved = 0
    objRec(0).RecipClass = 1
    objRec(0).Name = sTo
    '-- values not used for recipient
    'objRec.Address
    'objRec.EIDSize
    'objRec.EntryID
    '-- message object **********************************************
    '     *************
    objMsg.Reserved = 0
    objMsg.Subject = sSubject
    objMsg.RecipCount = 1
    objMsg.FileCount = 0
    objMsg.NoteText = sMessage
    '-- values not used for message
    'objMsg.MessageType
    'objMsg.DateReceived
    'objMsg.ConversationID
    'objMsg.Flags
    '-- make api calls to send mail *********************************
    '     **************
    '-- logon to MAPI application
    '-- default profile is set in user name parameter of Logon
    Rtn = MAPILogon(0, "MS Exchange Settings", "", MAPI_LOGON_UI, 0, hMAPI)
    '-- send mail message through MAPI
    Rtn = MAPISendMail(hMAPI, 0, objMsg, objRec, objFile, 0, MAPI_DIALOG)
    '-- logoff MAPI application
    Rtn = MAPILogoff(hMAPI, 0, 0, 0)
    Exit Function
 
Err_Trap:
    ErrorCatch "MOD_MAIL.api_SendMail()"
End Function
 
Public Function olk_SendMail(sTo As String, sSubject As String, sMessage As String)
    '-- use MS Outlook object to send mail
    On Error GoTo Err_Trap
    Dim objOutlook As Outlook.Application
    Dim objMailItem As Outlook.MailItem
    Set objOutlook = New Outlook.Application
    Set objMailItem = objOutlook.CreateItem(olMailItem)
 
    With objMailItem
        .To = sTo
        .Subject = sSubject
        .Body = sMessage
        .Send
    End With
    Set objMailItem = Nothing
    Set objOutlook = Nothing
    Exit Function
 
Err_Trap:
    ErrorCatch "MOD_MAIL.olk_SendMail()"
End Function
 
Public Function ErrorCatch(sDesc As String)
    Dim msg As String
    msg = vbTab & vbTab & "ERROR OCCURRED!!" & vbCrLf & vbCrLf
    msg = msg & "Function :" & vbTab & sDesc & vbCrLf
    msg = msg & "Number :" & vbTab & Err.Number & vbCrLf
    msg = msg & "Message :" & vbTab & Err.Description
    MsgBox msg, vbCritical, "Program Error"
    Err.Clear
End Function