VB and VBA Users Source Code: MAPI API class and example
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
MAPI API class and example
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Wednesday, March 07, 2001
Hits:
4169
Category:
Internet/Remote Comms
Article:
Below is the code for a MAPI class and a demonstration routine. If you are using VBA the code should work as is. If however, you are using VB you will first need to create a MAPI DLL. To do this, copy the code for the MAPI class along with the public types and the constants (which need to be Private) into the class. Then compile the DLL and reference the DLL from your VB Exe. Place the following code in a class module called "MAPI" Option Explicit 'Note, this has been written to work with Excel 2000 and VB. '---------------------PRIVATE VARIABLES----------------- Private zlSessionID As Long, zlParentHwnd As Long Private zsUserName As String, zsPassword As String Private zlShowDialogs As Long '---------------------API CALLS----------------- 'Error message API Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Any) As Long Private Declare Function GetActiveWindow Lib "user32" () As Long 'MAPI API Private Declare Function MAPILogon Lib "MAPI32.DLL" (ByVal lUIParam As Long, ByVal User As String, ByVal Password As String, ByVal lFlags As Long, ByVal lReserved As Long, lSession As Long) As Long Private Declare Function MAPILogoff Lib "MAPI32.DLL" (ByVal lSession As Long, ByVal lUIParam As Long, ByVal lFlags As Long, ByVal lReserved As Long) As Long Private Declare Function MAPISaveMail Lib "MAPI32.DLL" Alias "BMAPISaveMail" (ByVal Session As Long, ByVal UIParam As Long, Message As MAPIMessage, Recipient As MapiRecip, File As MapiFile, ByVal Reserved As Long, MsgID As String) As Long Private Declare Function MAPISendMail Lib "MAPI32.DLL" Alias "BMAPISendMail" (ByVal Session As Long, ByVal UIParam As Long, Message As MAPIMessage, Recipient() As MapiRecip, File() As MapiFile, ByVal Flags As Long, ByVal Reserved As Long) As Long Private Declare Function MAPIReadMail Lib "MAPI32.DLL" Alias "BMAPIReadMail" (lMsg As Long, nRecipients As Long, nFiles As Long, ByVal Session As Long, ByVal UIParam As Long, MessageID As String, ByVal Flag As Long, ByVal Reserved As Long) As Long Private Declare Function MAPIGetReadMail Lib "MAPI32.DLL" Alias "BMAPIGetReadMail" (ByVal lMsg As Long, Message As MAPIMessage, Recip() As MapiRecip, File() As MapiFile, Originator As MapiRecip) As Long Private Declare Function MAPIFindNext Lib "MAPI32.DLL" Alias "BMAPIFindNext" (ByVal lSession As Long, ByVal lUIParam As Long, MsgType As String, SeedMsgID As String, ByVal Flag As Long, ByVal lReserved As Long, MsgID As String) As Long Private Declare Function MAPISendDocuments Lib "MAPI32.DLL" (ByVal lUIParam As Long, ByVal DelimStr As String, ByVal FilePaths As String, ByVal FileNames As String, ByVal lReserved As Long) As Long Private Declare Function MAPIDeleteMail Lib "MAPI32.DLL" (ByVal lSession As Long, ByVal lUIParam As Long, ByVal MsgID As String, ByVal lFlags As Long, ByVal lReserved As Long) As Long Private Declare Function MAPIAddress Lib "MAPI32.DLL" (ByVal lSession As Long, ByVal lUIParam As Long, ByVal Caption As String, ByVal nEditFields As Long, ByVal Label As String, ByVal nRecipients As Long, Recip() As MapiRecip, ByVal lFlags As Long, ByVal lReserved As Long) As Long Private Declare Function MAPIGetAddress Lib "MAPI32.DLL" (ByVal lInfo As Long, ByVal nRecipients As Long, Recipients() As MapiRecip) As Long Private Declare Function MAPIDetails Lib "MAPI32.DLL" Alias "BMAPIDetails" (ByVal lSession As Long, ByVal lUIParam As Long, Recipient As MapiRecip, ByVal lFlags As Long, ByVal lReserved As Long) As Long Private Declare Function MAPIResolveName Lib "MAPI32.DLL" Alias "BMAPIResolveName" (ByVal lSession As Long, ByVal lUIParam As Long, ByVal UserName As String, ByVal lFlags As Long, ByVal lReserved As Long, Recipient As MapiRecip) As Long Private Const SUCCESS_SUCCESS = 0 Private Const MAPI_USER_ABORT = 1 Private Const MAPI_E_USER_ABORT = MAPI_USER_ABORT Private Const MAPI_E_FAILURE = 2 Private Const MAPI_E_LOGIN_FAILURE = 3 Private Const MAPI_E_LOGON_FAILURE = MAPI_E_LOGIN_FAILURE Private Const MAPI_E_DISK_FULL = 4 Private Const MAPI_E_INSUFFICIENT_MEMORY = 5 Private Const MAPI_E_BLK_TOO_SMALL = 6 Private Const MAPI_E_TOO_MANY_SESSIONS = 8 Private Const MAPI_E_TOO_MANY_FILES = 9 Private Const MAPI_E_TOO_MANY_RECIPIENTS = 10 Private Const MAPI_E_ATTACHMENT_NOT_FOUND = 11 Private Const MAPI_E_ATTACHMENT_OPEN_FAILURE = 12 Private Const MAPI_E_ATTACHMENT_WRITE_FAILURE = 13 Private Const MAPI_E_UNKNOWN_RECIPIENT = 14 Private Const MAPI_E_BAD_RECIPTYPE = 15 Private Const MAPI_E_NO_MESSAGES = 16 Private Const MAPI_E_INVALID_MESSAGE = 17 Private Const MAPI_E_TEXT_TOO_LARGE = 18 Private Const MAPI_E_INVALID_SESSION = 19 Private Const MAPI_E_TYPE_NOT_SUPPORTED = 20 Private Const MAPI_E_AMBIGUOUS_RECIPIENT = 21 Private Const MAPI_E_AMBIG_RECIP = MAPI_E_AMBIGUOUS_RECIPIENT Private Const MAPI_E_MESSAGE_IN_USE = 22 Private Const MAPI_E_NETWORK_FAILURE = 23 Private Const MAPI_E_INVALID_EDITFIELDS = 24 Private Const MAPI_E_INVALID_RECIPS = 25 Private Const MAPI_E_NOT_SUPPORTED = 26 Private Const MAPI_E_NO_LIBRARY = 999 Private Const MAPI_E_INVALID_PARAMETER = 998 Private Const MAPI_ORIG = 0 Private Const MAPI_TO = 1 Private Const MAPI_CC = 2 Private Const MAPI_BCC = 3 'Flags for MAPILogon Private Const MAPI_LOGON_UI = &H1& Private Const MAPI_NEW_SESSION = &H2& Private Const MAPI_FORCE_DOWNLOAD = &H1000& 'Flags for MAPILogoff Private Const MAPI_LOGOFF_SHARED = &H1 Private Const MAPI_LOGOFF_UI = &H2 'Flags for MAPISendMail Private Const MAPI_DIALOG = &H8 Private Const MAPI_NODIALOG = &H1 'Flags for ReadMail Private Const MAPI_ENVELOPE_ONLY = &H40 Private Const MAPI_PEEK = &H80 Private Const MAPI_BODY_AS_FILE = &H200 Private Const MAPI_SUPPRESS_ATTACH = &H800 'Flags for MAPIDetails Private Const MAPI_AB_NOMODIFY = &H400 'Flags for Attachments Private Const MAPI_OLE = &H1 Private Const MAPI_OLE_STATIC = &H2 'Flags for MapiMessage Private Const MAPI_UNREAD = &H1 Private Const MAPI_RECEIPT_REQUESTED = &H2 Private Const MAPI_SENT = &H4 'Purpose : Reads the MAPI mailbox 'Inputs : tMessage See outputs ' tOriginator See outputs ' atRecipients See outputs ' atAttachments See outputs 'Outputs : tMessage A structure containing the message information ' tOriginator A structure containing the originators details ' atRecipients A 1d array of the message recipients ' atAttachments A 1d array of the attachments ' [sMessageResumeID] If specified, reads the next message after this ID, ' else reads the first message. ' [lType] Determines which messages are read (See 'Flags for MapiMessage) 'Author : Andrew Baker 'Date : 14/01/2001 12:20 'Notes : 'Revisions : Function ReadMail(tMessage As MAPIMessage, tOriginator As MapiRecip, atRecipients() As MapiRecip, atAttachments() As MapiFile, Optional ByRef sMessageResumeID As String, Optional lType As Long = MAPI_UNREAD_ONLY) As Long Dim lMessageID As Long, sResumeID As String Dim lNumFiles As Long, lNumRecips As Long If Len(sMessageResumeID) = 0 Then 'First call to routine, create buffer sMessageResumeID = Space(256) ReadMail = MAPIFindNext(zlSessionID, zlParentHwnd, "", "", lType, 0&, sMessageResumeID) Else 'User specified a sMessageResumeID ReadMail = MAPIFindNext(zlSessionID, zlParentHwnd, "", sMessageResumeID, lType, 0&, sMessageResumeID) End If If (ReadMail = SUCCESS_SUCCESS) Then ReadMail = MAPIReadMail(lMessageID, lNumRecips, lNumFiles, zlSessionID, zlParentHwnd, sMessageResumeID, MAPI_PEEK, 0&) If (ReadMail = SUCCESS_SUCCESS) Then 'Read mail into types ReadMail = MAPIGetReadMail(lMessageID, tMessage, atRecipients, atAttachments, tOriginator) End If End If End Function 'Purpose : Starts a MAPI session 'Inputs : N/A 'Outputs : Returns a descriptive error message 'Author : Andrew Baker 'Date : 14/01/2001 12:20 'Notes : 'Revisions : Function Logon() As String Dim lReturnValue As Long 'On Error Resume Next If zlSessionID Then 'End existing session LogOff zlSessionID = 0 End If lReturnValue = MAPILogon(zlParentHwnd, zsUserName, zsPassword, MAPI_LOGON_UI, 0&, zlSessionID) Logon = ErrorDescription(lReturnValue) End Function 'Purpose : The users password 'Inputs : N/A 'Outputs : N/A 'Author : Andrew Baker 'Date : 14/01/2001 12:20 Property Get Password() As String Password = zsPassword End Property Property Let Password(Value As String) zsPassword = Value End Property 'Purpose : The name of the user 'Inputs : N/A 'Outputs : N/A 'Author : Andrew Baker 'Date : 14/01/2001 12:20 Property Get UserName() As String Password = zsUserName End Property Property Let UserName(Value As String) zsUserName = Value End Property 'Purpose : Terminates a MAPI session 'Inputs : N/A 'Outputs : Returns zero on success 'Author : Andrew Baker 'Date : 14/01/2001 12:20 'Notes : 'Revisions : Function LogOff() As Long If zlSessionID Then LogOff = MAPILogoff(zlSessionID, zlParentHwnd, 0&, 0&) zlSessionID = 0 End If End Function 'Purpose : Transforms a message recipient's name to an unambiguous address list entry. 'Inputs : tRecip A structure containing the name to resolve 'Outputs : tRecip A structure containing the resolved name 'Author : Andrew Baker 'Date : 14/01/2001 12:20 'Notes : Differs from the SendMail function in that it allows less flexibility in message generation. 'Revisions : Public Function ResolveName(ByRef tRecip As MapiRecip) As Long ResolveName = MAPIResolveName(zlSessionID, zlParentHwnd, tRecip.Name, zlShowDialogs, 0&, tRecip) End Function 'Purpose : Sends a standard message with one or more attached files and a cover note. ' The cover note is a dialog box that allows the user to enter a list of ' recipients and an optional message. 'Inputs : sDocumentList A deliminated list of documents to send. ' sDocumentNamesList A deliminated list of the document names (should have same number ' of items as sDocumentList). ' [sDelimeter] The character delimiter. 'Outputs : Returns zero on success 'Author : Andrew Baker 'Date : 14/01/2001 12:20 'Notes : Differs from the SendMail function in that it allows less flexibility in message generation. 'Revisions : Public Function ShowSendFileDialog(sDocumentList As String, sDocumentNamesList As String, Optional sDelimeter As String = ";") As Long ShowSendFileDialog = MAPISendDocuments(zlParentHwnd, sDelimeter, sDocumentList, sDocumentNamesList, 0&) End Function 'Purpose : Converts an error number to an error description 'Inputs : tMessage A structure containing the message details ' tRecipient A 1d array containing details of the recipients to send the mail to. ' tFile A 1d array containing details of any attachments. 'Outputs : Returns zero on success 'Author : Andrew Baker 'Date : 14/01/2001 12:20 'Notes : 'Revisions : Public Function SendMail(tMessage As MAPIMessage, tRecipient() As MapiRecip, tFile() As MapiFile) As Long Dim lThisRecip As Long 'Resolve the recipients before sending mail For lThisRecip = LBound(tRecipient) To UBound(tRecipient) SendMail = MAPIResolveName(zlSessionID, zlParentHwnd, tRecipient(lThisRecip).Name, 0, 0, tRecipient(lThisRecip)) Next 'MAPI_DIALOG SendMail = MAPISendMail(zlSessionID, zlParentHwnd, tMessage, tRecipient, tFile, zlShowDialogs, 0&) If SendMail Then 'Print error message Debug.Print ErrorDescription(SendMail) End If End Function 'Purpose : Determines whether MAPI will display any dialogs 'Inputs : See 'Flags for MAPISendMail. 'Outputs : N/A 'Author : Andrew Baker 'Date : 14/01/2001 12:20 Property Get ShowDialogs() As Long ShowDialogs = zlShowDialogs End Property Property Let ShowDialogs(Value As Long) zlShowDialogs = Value End Property 'Purpose : Determines the parent window handle of this session 'Inputs : N/A 'Outputs : N/A 'Author : Andrew Baker 'Date : 14/01/2001 12:20 Property Get ParentHwnd() As Long ParentHwnd = zlParentHwnd End Property Property Let ParentHwnd(Value As Long) zlParentHwnd = Value End Property Private Sub Class_Initialize() zlShowDialogs = MAPI_DIALOG zlParentHwnd = GetActiveWindow 'Seed parent window handle End Sub Private Sub Class_Terminate() LogOff End Sub 'Purpose : Deletes a mail message 'Inputs : sMessageID The identifier for the message to be deleted 'Outputs : Returns zero on success 'Author : Andrew Baker 'Date : 14/01/2001 12:20 'Notes : 'Revisions : Function DeleteMail(sMessageID As String) As Long DeleteMail = MAPIDeleteMail(zlSessionID, zlParentHwnd, sMessageID, zlShowDialogs, 0&) End Function 'Purpose : Converts an error number to an error description 'Inputs : lErrorNumber The API error number 'Outputs : Returns a descriptive error message 'Author : Andrew Baker 'Date : 14/01/2001 12:20 'Notes : 'Revisions : Function ErrorDescription(ByVal lErrorNumber As Long) As String Const FORMAT_MESSAGE_FROM_HMODULE = &H800, FORMAT_MESSAGE_FROM_SYSTEM = &H1000 Const NERR_BASE = 2100, MAX_NERR = NERR_BASE + 899 Const LOAD_LIBRARY_AS_DATAFILE = &H2 Dim sMsg As String Dim sRtrnCode As String Dim lFlags As Long Dim hModule As Long Dim lRet As Long hModule = 0 sRtrnCode = Space$(256) lFlags = FORMAT_MESSAGE_FROM_SYSTEM 'If lRet is in the network range, load the message source If (lErrorNumber >= NERR_BASE And lErrorNumber <= MAX_NERR) Then hModule = LoadLibraryEx("netmsg.dll", 0&, LOAD_LIBRARY_AS_DATAFILE) If (hModule <> 0) Then lFlags = lFlags Or FORMAT_MESSAGE_FROM_HMODULE End If End If 'Call FormatMessage to allow for message text to be acquired 'from the system or the supplied module handle. lRet = FormatMessage(lFlags, hModule, lErrorNumber, 0&, sRtrnCode, 256&, 0&) If (hModule <> 0) Then 'Unloaded message source FreeLibrary hModule End If ErrorDescription = "ERROR: " & lErrorNumber & " - " & sRtrnCode 'Clean message lRet = InStr(1, ErrorDescription, vbNullChar) If lRet Then ErrorDescription = Left$(ErrorDescription, lRet - 1) End If lRet = InStr(1, ErrorDescription, vbNewLine) If lRet Then ErrorDescription = Left$(ErrorDescription, lRet - 1) End If End Function Place the following code in a standard module: Option Explicit '---------------------Public structures and constants----------------- 'Flags for MAPIFindNext Public Const MAPI_UNREAD_ONLY = &H20 Public Const MAPI_GUARANTEE_FIFO = &H100 'MAPI message holds information about a Message Public Type MAPIMessage lReserved As Long Subject As String MessageText As String MessageType As String DateReceived As String ConversationID As String lFlags As Long RecipCount As Long FileCount As Long End Type 'MAPIRecip structure, holds information about a message 'originator or recipient Public Type MapiRecip lReserved As Long RecipClass As Long Name As String Address As String EIDSize As Long EntryID As String End Type 'MapiFile structure, holds information about file attachments Public Type MapiFile lReserved As Long lFlags As Long Position As Long PathName As String FileName As String FileType As String End Type 'Demostration routine (for Excel 2000 and VB) Sub Test() Dim Mail As New MAPI 'Assumes you called the class MAPI Dim tMessage As MAPIMessage Dim atRecipients() As MapiRecip Dim tOriginator As MapiRecip Dim atMapiFile(1 To 1) As MapiFile Dim lRetVal As Long Dim sMesageResumeID As String '---Logon to mail account Mail.UserName = "" 'Enter Username Mail.Password = "" 'Enter Password Debug.Print Mail.Logon 'Get a mail address (resolve a name) ReDim atRecipients(1 To 1) atRecipients(1).Name = InputBox("Please enter an email address to find...") If Mail.ResolveName(atRecipients(1)) = 0 Then MsgBox "Found address: " & atRecipients(1).Address End If 'Send a message tMessage.MessageText = "Test" tMessage.FileCount = 1 'Send a file tMessage.RecipCount = 2 'Send to two email addresses tMessage.Subject = "Test Mail" atMapiFile(1).FileName = "Autoexec" atMapiFile(1).PathName = "C:\test.txt" ReDim atRecipients(1 To 2) atRecipients(1).Name = "Andrew Baker" atRecipients(1).Address = "someone@hotmail.com" atRecipients(2).Name = "Andrew Baker" atRecipients(2).Address = "someone@somewhere.com" Mail.ShowDialogs = 1 'Don't show dialogs Debug.Print "Send Mail Result: " & Mail.SendMail(tMessage, atRecipients, atMapiFile) '---Get all new mail sMesageResumeID = "" lRetVal = Mail.ReadMail(tMessage, tOriginator, atRecipients, atMapiFile, sMesageResumeID) Do While lRetVal = 0 Debug.Print "--------------------------------" Debug.Print "SUBJECT: " & tMessage.Subject Debug.Print "TEXT: " & tMessage.MessageText Debug.Print "DATE: " & tMessage.DateReceived Debug.Print "FROM: " & tOriginator.Name & " {" & tOriginator.Address & "}" Debug.Print "--------------------------------" lRetVal = Mail.ReadMail(tMessage, tOriginator, atRecipients, atMapiFile, sMesageResumeID) If MsgBox("Delete new mail :" & tMessage.Subject, vbQuestion + vbYesNo) = vbYes Then Mail.DeleteMail sMesageResumeID End If Loop 'Logoff Mail.LogOff End Sub
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
