---Soumis par Dev Ashish---
Importer les messages d'Outlook 98.
La nouvelle bibliothèque CDO Reference Library disponible avec Outlook 98 nous donne plus de contrôle sur MAPI. Par exemple, on peut utiliser CDO pour importer les messages d'un dossier de e-mail à une table locale d'Access.
Voici un module de classe qui automatise cela pour vous. Ne pas oublier de cliquer sur la référence (Menu: tools, references... ) Microsoft CDO 1.21 puis couper-coller le code dans un nouveau module de classe
Noter qu'à ce moment, cette classe n'importe pas d'information relative aux pièces jointes (attachments).
Télécharger MAPIStuff.Zip (50,488 bytes). Access 97.
'**************** 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 ***********************
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 ***********************