Modules: Import Outlook 98 messages

The new CDO Reference Library available with Outlook 98 gives us much more control over MAPI stuff.  For instance,  you can use CDO to import messages from any email folder to a local Access table.

Here's a class module which automates this for you.  Set a reference under Tools/References to Microsoft CDO 1.21 and paste this code in a new class module.

Please note that at the moment, this class will not import any information about attachments.

  Download MAPIStuff.Zip (50,488 bytes).  Access 97 version.

'**************** Usage Example Start ****************
Sub testMapi()
Dim clMAPI As clsMAPI
    Set clMAPI = New clsMAPI

    With clMAPI
        .MAPILogon
        .MAPISetImportFolder = "Inbox"
        .MAPISetImportTable = "tblMsgs"
        .MAPIImportMessages
        .MAPILogoff
    End With
End Sub
'**************** Usage Example End ****************

'**************** Class Start ***********************
'This code was originally written by Dev Ashish
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Dev Ashish
'
Option Compare Database
Option Explicit

Private Const mcERR_DOH = vbObjectError + 10000
Private Const mcERR_DECIMAL = 261144    'low word order +1000
Private Const mcMAXFLD = 16

Private mobjSession As MAPI.Session
Private mobjFolder As Folder
Private mobjMessage As Message
Private mobjMsgColl As Messages
Private mlngFolderType As Long
Private mstStatus As String
Private mstTable As String
Private mstFolderName As String
Private mastFld(0 To mcMAXFLD, 1) As String
Private mboolErr As Boolean
Private mlngCount As Long

Private Sub Class_Initialize()
     mboolErr = False
     mlngCount = 0
     mstStatus = SysCmd(acSysCmdSetStatus, "Initializing...")
End Sub

Private Sub Class_Terminate()
     On Error Resume Next
     Erase mastFld
     Set mobjMessage = Nothing
     Set mobjMsgColl = Nothing
     Set mobjFolder = Nothing
     mobjSession.Logoff
     Set mobjSession = Nothing
     mstStatus = SysCmd(acSysCmdClearStatus)
End Sub

Public Sub MAPIImportMessages()
Dim db As Database, rs As Recordset
Dim objRecipient As Recipient
Dim objAttachment As Attachment
Dim stOut As String

     On Error GoTo MAPIImportMessages_Error

     If Not mboolErr Then
          Set db = CurrentDb
          Set rs = db.OpenRecordset(mstTable, dbOpenDynaset)
          '***Must change this to QUERIES somehow

          Set mobjMsgColl = mobjFolder.Messages
          If Not 0 = mobjMsgColl.Count Then
               Set mobjMessage = mobjMsgColl.GetFirst()
               Do While Not mobjMessage Is Nothing
                    With rs
                         .AddNew
                              !Class = mobjMessage.Class
                              !FolderID = mobjMessage.FolderID
                              !ID = mobjMessage.ID

                              stOut = vbNullString
                              For Each objRecipient In mobjMessage.Recipients
                                   stOut = stOut & objRecipient.Name & " (" _
                                             & objRecipient.Address & ") ;"
                              Next
                              'some emails don't have your name in the To: field
                              If mobjMessage.Recipients.Count > 0 Then
                                   stOut = Left$(stOut, Len(stOut) - 2)
                                   !Recipients = stOut
                              End If

                              stOut = vbNullString
                              'Attachments at the moment are generating
                              'E_OutofMemory error code.
                              '
                              'For Each objAttachment In mobjMessage.Attachments
                              '    stOut = stOut & objAttachment.Name & ";"
                              ' Next
                              'If mobjMessage.Attachments.Count > 0 Then
                              '    stOut = Left$(stOut, Len(stOut) - 1)
                              '     !Attachments = stOut
                              ' End If

                              !SenderEmailAddress = mobjMessage.Sender.Address
                              !Sender = mobjMessage.Sender.Name

                              !Sensitivity = mobjMessage.Sensitivity
                              !MsgSize = mobjMessage.Size
                              !StoreID = mobjMessage.StoreID
                              !Subject = mobjMessage.Subject

                              !Messagebody = mobjMessage.Text
                              !TimeCreated = mobjMessage.TimeCreated
                              !TimeLastModified = mobjMessage.TimeLastModified
                              !TimeReceived = mobjMessage.TimeReceived
                              !TimeSent = mobjMessage.TimeSent
                         .Update
                         mlngCount = mlngCount + 1
                         mstStatus = SysCmd(acSysCmdSetStatus, "Imported " & mlngCount & " message(s)....")
                         Set mobjMessage = mobjMsgColl.GetNext
                    End With
               Loop
          End If
     End If
     Set rs = Nothing
     Set db = Nothing
     stOut = "Imported " & mlngCount & " messages from the folder '" & mobjFolder.Name & "'."
     MsgBox stOut, vbOKOnly, "Success!!"

MAPIImportMessages_Exit:
     Exit Sub

MAPIImportMessages_Error:
     stOut = "Finished importing " & mlngCount & " Messages." & vbCrLf
     stOut = stOut & "Couldn't import the message titled " & vbCrLf
     stOut = stOut & "'" & mobjMessage.Subject & "'." & vbCrLf & "Aborting!" & vbCrLf
     stOut = stOut & "Error returned was:" & vbCrLf
     stOut = stOut & Err & ": " & Err.Description

     MsgBox stOut, vbCritical + vbOKOnly, "Critical error encountered!"
     Set mobjMessage = Nothing
     Set mobjMsgColl = Nothing
     Set mobjFolder = Nothing
     mobjSession.Logoff
     Set mobjSession = Nothing
     Resume MAPIImportMessages_Exit
End Sub

Public Property Let MAPISetImportTable(stTableName As String)
Dim stMsg As String
     stMsg = "The table name '" & stTableName & "' already exists " _
                              & "in this database!"
     stMsg = stMsg & "@Continuing beyond this step will delete and recreate it."
     stMsg = stMsg & "@Do you wish to proceed?"
     mboolErr = False
     If Not fTableNotExist(stTableName) Then
          If MsgBox(stMsg, vbExclamation + vbYesNo, "Warning!") = vbYes Then
               DoCmd.DeleteObject acTable, stTableName
               CurrentDb.TableDefs.Refresh
          End If
     End If
     mstTable = stTableName
     If Not fCreateMsgTable(stTableName) Then
          MsgBox "Error encountered while creating table. Aborting.", _
                    vbCritical + vbOKOnly, "Critical Error"
          mboolErr = True
          Exit Property
     End If
End Property

Public Property Get MAPIGetImportTable() As String
     MAPIGetImportTable = mstTable
End Property


Private Function fCreateMsgTable(stTable As String) As Boolean
Dim tdf As TableDef, db As Database
Dim fld As Field, boolErr As Boolean
Dim i As Integer

     On Error GoTo Error_fCreateMsgTable
     mstStatus = SysCmd(acSysCmdSetStatus, "Creating Import table...")
     Set db = CurrentDb
     boolErr = False
     db.TableDefs.Refresh

     Call sInitFldArray

     Set tdf = db.CreateTableDef(stTable)
     With tdf
          For i = 0 To mcMAXFLD
               If CInt(mastFld(i, 1)) = dbText Then
                    Set fld = .CreateField(mastFld(i, 0), CInt(mastFld(i, 1)), 255)
               Else
                    Set fld = .CreateField(mastFld(i, 0), CInt(mastFld(i, 1)))
               End If
               If CInt(mastFld(i, 1)) = dbText Or CInt(mastFld(i, 1) = dbMemo) Then
                    'must do this since some subjects/emails are blanks
                    fld.AllowZeroLength = True
               End If
               With fld
                    If .Name = "CounterID" Then
                         .Attributes = dbAutoIncrField
                    End If
               End With
               .Fields.Append fld
          Next
     End With
     db.TableDefs.Append tdf
     db.TableDefs.Refresh
     fCreateMsgTable = True

Exit_fCreateMsgTable:
     Set fld = Nothing
     Set tdf = Nothing
     Set db = Nothing

     If boolErr Then
          On Error Resume Next
          DoCmd.DeleteObject acTable, stTable
     End If
     Exit Function

Error_fCreateMsgTable:
     MsgBox "Error in creating table '" & stTable & "'.  Aborting!", _
          vbCritical + vbOKOnly, "Critical error encountered"
     boolErr = True
     fCreateMsgTable = False
     Resume Exit_fCreateMsgTable
End Function
Sub sInitFldArray()
     mastFld(0, 0) = "Class":                         mastFld(0, 1) = CStr(dbLong)
     mastFld(1, 0) = "FolderID":                     mastFld(1, 1) = CStr(dbText)
     mastFld(2, 0) = "ID":                              mastFld(2, 1) = CStr(dbText)
     mastFld(3, 0) = "Recipients":                   mastFld(3, 1) = CStr(dbMemo)
     mastFld(4, 0) = "Sender":                       mastFld(4, 1) = CStr(dbText)
     mastFld(5, 0) = "SenderEmailAddress":   mastFld(5, 1) = CStr(dbText)
     mastFld(6, 0) = "Sensitivity":          mastFld(6, 1) = CStr(dbLong)
     mastFld(7, 0) = "MsgSize":              mastFld(7, 1) = CStr(dbLong)
     mastFld(8, 0) = "StoreID":              mastFld(8, 1) = CStr(dbText)
     mastFld(9, 0) = "Subject":              mastFld(9, 1) = CStr(dbText)
     mastFld(10, 0) = "MessageBody":         mastFld(10, 1) = CStr(dbMemo)
     mastFld(11, 0) = "TimeCreated":         mastFld(11, 1) = CStr(dbDate)
     mastFld(12, 0) = "TimeLastModified":    mastFld(12, 1) = CStr(dbDate)
     mastFld(13, 0) = "TimeReceived":        mastFld(13, 1) = CStr(dbDate)
     mastFld(14, 0) = "TimeSent":            mastFld(14, 1) = CStr(dbDate)
     mastFld(15, 0) = "Attachments":         mastFld(15, 1) = CStr(dbMemo)
     mastFld(16, 0) = "CounterID":           mastFld(16, 1) = CStr(dbLong)
End Sub

Private Function fTableNotExist(stTable) As Boolean
Dim db As Database
Dim tdf As TableDef
     Set db = CurrentDb
     On Error Resume Next
     Set tdf = db.TableDefs(stTable)
     fTableNotExist = (Err <> 0)
     Set tdf = Nothing
     Set db = Nothing
End Function

Public Property Get MAPIGetImportFolder() As String
     MAPIGetImportFolder = mstFolderName
End Property

Public Property Let MAPISetImportFolder(stFolderName As String)
Dim stID As String

     On Error GoTo MAPISetImportFolder_Error

     stID = vbNullString
     Select Case UCase(stFolderName)
          Case "CALENDAR":
               mlngFolderType = CdoDefaultFolderCalendar
          Case "CONTACTS":
               mlngFolderType = CdoDefaultFolderContacts
          Case "DELETED ITEMS":
               mlngFolderType = CdoDefaultFolderDeletedItems
          Case "INBOX":
               mlngFolderType = CdoDefaultFolderInbox
          Case "JOURNAL":
               mlngFolderType = CdoDefaultFolderJournal
          Case "NOTES":
               mlngFolderType = CdoDefaultFolderNotes
          Case "OUTBOX":
               mlngFolderType = CdoDefaultFolderOutbox
          Case "SENT ITEMS":
               mlngFolderType = CdoDefaultFolderSentItems
          Case "TASKS":
               mlngFolderType = CdoDefaultFolderTasks
          Case Else:
               stID = fSearchFolder(stFolderName)
               If Not stID = vbNullString Then
                    Set mobjFolder = mobjSession.GetFolder(stID)
               End If
     End Select

     If stID = vbNullString Then
          Set mobjFolder = mobjSession.GetDefaultFolder(mlngFolderType)
     End If
     mstFolderName = mobjFolder.Name

MAPISetImportFolder_Exit:
     Exit Property
MAPISetImportFolder_Error:
     If Err = CdoE_NOT_FOUND - mcERR_DECIMAL Then
          MsgBox "Folder '" & stFolderName & "' not found!  Please try again.", _
               vbCritical + vbOKOnly, "Error in folder name"
     End If
     Set mobjMessage = Nothing
     Set mobjMsgColl = Nothing
     Set mobjFolder = Nothing
     Set mobjSession = Nothing
     Resume MAPISetImportFolder_Exit
End Property

Private Function fSearchFolder(stFolderName) As String
Dim objFolder As Folder         ' local
Dim objInfoStoresColl As InfoStores
Dim objInfoStore As InfoStore
Dim objFoldersColl As Folders
Dim stID As String
Dim boolEnd As Boolean

     On Error GoTo fSearchFolder_Err
     mstStatus = SysCmd(acSysCmdSetStatus, "searching for folder...")
     fSearchFolder = False:  boolEnd = False
     Set objInfoStoresColl = mobjSession.InfoStores
     For Each objInfoStore In objInfoStoresColl
          With objInfoStore
               If .Name <> "Public Folders" Then
                    Set objFoldersColl = .RootFolder.Folders
                    Set objFolder = objFoldersColl.GetFirst
                    Do While Not objFolder Is Nothing
                         If objFolder.Name = stFolderName Then
                              stID = objFolder.ID
                              boolEnd = True
                              Exit Do
                         Else
                              Set objFolder = objFoldersColl.GetNext
                         End If
                    Loop
                    If boolEnd Then Exit For
               End If
          End With
     Next

     If boolEnd Then
          fSearchFolder = stID
     Else
          fSearchFolder = vbNullString
     End If

fSearchFolder_Exit:
     On Error Resume Next
     Set objFolder = Nothing
     Set objFoldersColl = Nothing
     Set objInfoStore = Nothing
     Set objInfoStoresColl = Nothing
     Exit Function
fSearchFolder_Err:
     fSearchFolder = vbNullString
     Resume fSearchFolder_Exit
End Function

Public Sub MAPILogon()
On Error GoTo err_sMAPILogon

     mstStatus = SysCmd(acSysCmdSetStatus, "Login....")
     Set mobjSession = CreateObject("MAPI.Session")
     mobjSession.Logon

exit_sMAPILogon:
     Exit Sub

err_sMAPILogon:
     If Err = CdoE_LOGON_FAILED - mcERR_DECIMAL Then
          MsgBox "Logon Failed", vbCritical + vbOKOnly, "Error"
     Else
          MsgBox "Error number " & Err - mcERR_DECIMAL & " description. " & Error$(Err)
     End If
     Resume exit_sMAPILogon
End Sub

Public Sub MAPILogoff()
On Error GoTo err_sMAPILogoff
     mstStatus = SysCmd(acSysCmdSetStatus, "Logging off...")
     Set mobjMessage = Nothing
     Set mobjMsgColl = Nothing
     Set mobjFolder = Nothing
     mobjSession.Logoff
     Set mobjSession = Nothing

exit_sMAPILogoff:
    Exit Sub

err_sMAPILogoff:
     Resume exit_sMAPILogoff
End Sub
'**************** Class End  ***********************