Macro Outlook 2003

Bonjour,

J'ai un petit problème, j'avais une macro Outlook en 2000, qui
m'enregistrait des e-mails selectionnés dans un dossier sur mon serveur. Le
format du nom du fichier prenait en compte le nom de l'expéditeur de
l'e-mail.
Aujourd'hui nous avons migré en Outlook 2003, et la fonction
"GetFromAddress" ne semble plus fonctionner.
Existe-t-il un moyen pour récuperer cette fonction ?


(J'utilisais le module CDO.DLL, avec le CDOUPDT.EXE + ClickYesSetup.exe)
Je joins ma macro.


Merci.
Mathieu JAY.

début macro
====================
Attribute VB_Name = "Module1"

Public Sub EnregistreRecu()

'Const Path_EMAIL As String = "E:\MAIL\"
Const Path_EMAIL As String = "\\auresyssrv\rootd\User\FC\E_Mail2006\"

Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookNameSpace As Outlook.NameSpace
Dim objOutlookFolder As Outlook.MAPIFolder

Dim MonEsp As NameSpace
Dim monExp As Explorer
Dim laSel As Selection


Dim Index As Long
Dim Path As String
Dim RetPath As String

Dim VersionStr As String
Dim VersionInt As Integer

Set objOutlook = CreateObject("Outlook.Application")
Set objOutlookNameSpace = objOutlook.GetNamespace("MAPI")
Set objOutlookFolder = objOutlookNameSpace.GetDefaultFolder(olFolderInbox)



Set monExp = ActiveExplorer
Set MonEsp = GetNamespace("MAPI")
Set laSel = monExp.Selection

If laSel.Count = 0 Then
MsgBox "Pas d'élément sélectionné !"
Exit Sub
End If

Index = 1

For Index = 1 To laSel.Count
VersionInt = 0
VersionStr = ""
If TypeName(laSel.Item(Index)) = "MailItem" Then
Set objOutlookMsg = laSel.Item(Index)
With objOutlookMsg
Path = .SenderName & " [" & GetFromAddress(objOutlookMsg) & "] "
& .Subject
CorrigePath Path, RetPath
Path = Path_EMAIL & RetPath

While TestFichierExiste(Path & VersionStr & ".MSG")
VersionInt = VersionInt + 1
VersionStr = " -" & Format(VersionInt, "00")
Wend

objOutlookMsg.SaveAs Path & VersionStr & ".MSG", olMSG

End With
End If
Next Index

End Sub

Public Sub CorrigePath(ByVal Path As String, ByRef RetPath As String)
' Cette fonction permet de corriger le chemin pour qu'il ne contienne que
des caractère légaux

Dim Pos As Long
Dim Liste As Variant

Liste = Array("/", "\", ":", """", "*", "?", "<", ">", "|", "FIN")

While Liste(Pos) <> "FIN"
Path = Replace(Path, Liste(Pos), "_")
Pos = Pos + 1
Wend

RetPath = Path

End Sub

Function GetFromAddress(objMsg)
' start CDO session
Set objSession = CreateObject("MAPI.Session")
objSession.Logon "", "", False, False

' pass message to CDO
strEntryID = objMsg.EntryID
strStoreID = objMsg.Parent.StoreID
Set objCDOMsg = objSession.GetMessage(strEntryID, strStoreID)

' get sender address
On Error Resume Next
strAddress = objCDOMsg.Sender.Address
If Err = &H80070005 Then
'handle possible security patch error
MsgBox "The Outlook E-mail and CDO Security Patches are " & _
"apparently installed on this machine. " & _
"You must response Yes to the prompt about " & _
"accessing e-mail addresses if you want to " & _
"get the From address.", vbExclamation, _
"GetFromAddress"
End If

GetFromAddress = strAddress

Set objCDOMsg = Nothing
objSession.Logoff
Set objSession = Nothing
End Function

Function TestFichierExiste(specfichier) As Boolean
On Error GoTo Err
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(specfichier)

TestFichierExiste = True
Exit Function

Err:
TestFichierExiste = False

End Function


Public Sub EnregistreEnvoi()

'Const Path_EMAIL As String = "E:\MAIL\"
Const Path_EMAIL As String = "\\auresyssrv\rootd\User\FC\E_Mail2006Env\"

Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookNameSpace As Outlook.NameSpace
Dim objOutlookFolder As Outlook.MAPIFolder

Dim MonEsp As NameSpace
Dim monExp As Explorer
Dim laSel As Selection


Dim Index As Long
Dim Path As String
Dim RetPath As String

Dim VersionStr As String
Dim VersionInt As Integer

Set objOutlook = CreateObject("Outlook.Application")
Set objOutlookNameSpace = objOutlook.GetNamespace("MAPI")
Set objOutlookFolder = objOutlookNameSpace.GetDefaultFolder(olFolderInbox)



Set monExp = ActiveExplorer
Set MonEsp = GetNamespace("MAPI")
Set laSel = monExp.Selection

If laSel.Count = 0 Then
MsgBox "Pas d'élément sélectionné !"
Exit Sub
End If

Index = 1

For Index = 1 To laSel.Count
VersionInt = 0
VersionStr = ""
If TypeName(laSel.Item(Index)) = "MailItem" Then
Set objOutlookMsg = laSel.Item(Index)
With objOutlookMsg
Path = .SenderName & " [" & GetFromAddress(objOutlookMsg) & "] -
" & .To & " - " & .Subject
CorrigePath Path, RetPath
Path = Path_EMAIL & RetPath

While TestFichierExiste(Path & VersionStr & ".MSG")
VersionInt = VersionInt + 1
VersionStr = " -" & Format(VersionInt, "00")
Wend

objOutlookMsg.SaveAs Path & VersionStr & ".MSG", olMSG

End With
End If
Next Index

End Sub