Il faut lancer ou créer un bouton sur SaveAsHtmlFileWithEmbedded

Option Explicit
' ajouter une référence à Microsoft CDO 1.21 library
Pour Outlook 2007 il faut le télécharger là :
http://www.microsoft.com/downloads/details.aspx?familyid=2714320d-c997-4de1-986f-24f081725d36&displaylang=en
 
Public oSession As MAPI.Session
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Const OLECMDEXECOPT_DODEFAULT = 0, OLECMDEXECOPT_PROMPTUSER = 1, OLECMDEXECOPT_DONTPROMPTUSER = 2, OLECMDEXECOPT_SHOWHELP = 3
Const OLECMDID_OPEN = 1, OLECMDID_NEW = 2, OLECMDID_SAVE = 3, OLECMDID_SAVEAS = 4, OLECMDID_SAVECOPYAS = 5, OLECMDID_PRINT = 6, OLECMDID_PRINTPREVIEW = 7, OLECMDID_PAGESETUP = 8, OLECMDID_SPELL = 9, OLECMDID_PROPERTIES = 10, OLECMDID_CUT = 11, OLECMDID_COPY = 12, OLECMDID_PASTE = 13, OLECMDID_PASTESPECIAL = 14, OLECMDID_UNDO = 15, OLECMDID_REDO = 16, OLECMDID_SELECTALL = 17, OLECMDID_CLEARSELECTION = 18, OLECMDID_ZOOM = 19, OLECMDID_GETZOOMRANGE = 20, _
      OLECMDID_UPDATECOMMANDS = 21, OLECMDID_REFRESH = 22, OLECMDID_STOP = 23, OLECMDID_HIDETOOLBARS = 24, OLECMDID_SETPROGRESSMAX = 25, OLECMDID_SETPROGRESSPOS = 26, OLECMDID_SETPROGRESSTEXT = 27, OLECMDID_SETTITLE = 28, OLECMDID_SETDOWNLOADSTATE = 29, OLECMDID_STOPDOWNLOAD = 30, OLECMDID_ONTOOLBARACTIVATED = 31, OLECMDID_FIND = 32, OLECMDID_DELETE = 33, OLECMDID_HTTPEQUIV = 34, OLECMDID_HTTPEQUIV_DONE = 35, OLECMDID_ENABLE_INTERACTION = 36, OLECMDID_ONUNLOAD = 37, OLECMDID_PROPERTYBAG2 = 38, OLECMDID_PREREFRESH = 39, OLECMDID_SHOWSCRIPTERROR = 40, OLECMDID_SHOWMESSAGE = 41, OLECMDID_SHOWFIND = 42, OLECMDID_SHOWPAGESETUP = 43, OLECMDID_SHOWPRINT = 44, OLECMDID_CLOSE = 45, OLECMDID_ALLOWUILESSSAVEAS = 46, _
      OLECMDID_DONTDOWNLOADCSS = 47, OLECMDID_UPDATEPAGESTATUS = 48, OLECMDID_PRINT2 = 49, OLECMDID_PRINTPREVIEW2 = 50, OLECMDID_SETPRINTTEMPLATE = 51, OLECMDID_GETPRINTTEMPLATE = 52, OLECMDID_PAGEACTIONBLOCKED = 55, OLECMDID_PAGEACTIONUIQUERY = 56, OLECMDID_FOCUSVIEWCONTROLS = 57, OLECMDID_FOCUSVIEWCONTROLSQUERY = 58, OLECMDID_SHOWPAGEACTIONMENU = 59, OLECMDID_ADDTRAVELENTRY = 60, OLECMDID_UPDATETRAVELENTRY = 61, OLECMDID_UPDATEBACKFORWARDSTATE = 62, OLECMDID_OPTICAL_ZOOM = 63, OLECMDID_OPTICAL_GETZOOMRANGE = 64, OLECMDID_WINDOWSTATECHANGED = 65
 
Private Const maxTime = 10    ' in seconds
Private Const sleepTime = 250    ' in milliseconds
 
 
 
Function remplaceCaracteresInterdit(ByVal CheminStr As String)
  Dim ObjCurrentMessage As Outlook.MailItem
  
Dim liste As Variant
    Dim L
    liste = Array("\", "/", ":", "*", "?", "<", ">", "|", ".", """", vbTab, Chr(7))
    For L = 0 To UBound(liste)
    CheminStr = Replace(CheminStr, liste(L), "")
    Next L
    remplaceCaracteresInterdit = CheminStr
    'MsgBox CheminStr
End Function
 
 
' Function: Fields_Selector
' Purpose: View type of attachment
' olivier catteau fevrier 2006
Function VerifAttachtype(ByVal StrEntryID As String, attindex As Integer) As Variant
 
' CDO objects
    Dim oMsg As MAPI.Message
    Dim oAttachs As MAPI.Attachments
    Dim oAttach As MAPI.Attachment
    On Error Resume Next
    ' get the message created earlier
    Set oMsg = oSession.GetMessage(StrEntryID)
    ' set properties of the attached graphic that make
    ' it embedded and give it an ID for use in an <IMG> tag
    Set oAttachs = oMsg.Attachments
    Set oAttach = oAttachs.item(attindex)
    Dim strCID As String
    strCID = oAttach.Fields(&H3712001E)
 
    VerifAttachtype = strCID
    Set oMsg = Nothing
    Set oAttachs = Nothing
    Set oAttach = Nothing
 
End Function
 
 
Sub SaveAsHtmlFileWithEmbedded()
'By oliv Fev 2007
 
    Dim colAttach As Outlook.Attachments
    Dim Sujet, ObjCurrentMessage, Destinataire, Repertoire, strName
    Dim OLDhtml
    Dim StrEntryID
    Dim ENVOYEUR, ShortStrname, ImprimanteParDefaut, c, OutputFilename
    On Error Resume Next
    If ObjCurrentMessage Is Nothing Then
        Set ObjCurrentMessage = ActiveInspector.CurrentItem
    End If
    On Error GoTo 0
    Set colAttach = ObjCurrentMessage.Attachments
    If ObjCurrentMessage.BodyFormat = olFormatHTML Then
        Sujet = ObjCurrentMessage.ConversationIndex
 
        If ObjCurrentMessage.ReceivedByName = "" Then
            Destinataire = ObjCurrentMessage.To
        Else
            Destinataire = ObjCurrentMessage.ReceivedByName
        End If
        If ObjCurrentMessage.SenderEmailAddress = "" Then
            ENVOYEUR = "Brouillon"
        Else
            ENVOYEUR = ObjCurrentMessage.SenderEmailAddress
        End If
 
        Sujet = Trim(Replace(Replace(remplaceCaracteresInterdit(" De " & ENVOYEUR & " Le " & Replace(Replace(ObjCurrentMessage.ReceivedTime, ":", "h", 1, 1), ":", "'") & " A " & Destinataire), " - Gras Savoye Ricour", ""), "O=RICOUROU=ASSURANCESCN=RECIPIENTSCN=", ""))
        If Sujet = "" Then Sujet = ObjCurrentMessage.EntryID
 
        'on crée le repertoire où mettre les fichiers joints ##########################################################
        If Repertoire = "" Then Repertoire = "c:\temp\Email\" & Sujet & "\"
        If "" = Dir("c:\temp\Email\", vbDirectory) Then MkDir "c:\temp\Email\"
 
        If Repertoire <> "" Then
            If "" = Dir("c:\temp\", vbDirectory) Then MkDir "c:\temp\"
 
            If "" = Dir("c:\temp\Email\", vbDirectory) Then MkDir "c:\temp\Email\"
 
            If "" = Dir(Repertoire, vbDirectory) Then MkDir Repertoire
        End If
 
 
        If "" = Dir(Repertoire & "embedded\", vbDirectory) Then MkDir Repertoire & "embedded\"
 
    End If
    '=======================================================================
    'On boucle sur les pj pour enlever le cid et enregistrer la pj
    '=======================================================================
    OLDhtml = ObjCurrentMessage.HTMLBody
 
    ' initialize CDO session
    On Error Resume Next
    Set oSession = CreateObject("MAPI.Session")
    oSession.Logon "", "", False, False
    On Error GoTo 0
 
    StrEntryID = ObjCurrentMessage.EntryID
    Dim i, toto
    For i = 1 To colAttach.Count
        toto = VerifAttachtype(StrEntryID, colAttach(i).index)
        If toto <> "" Then
            'MsgBox "type:=" & toto & vbCr & " Piece:= " & colAttach(i).FileName
            ObjCurrentMessage.HTMLBody = Replace(ObjCurrentMessage.HTMLBody, "cid:" & toto, "embedded\" & colAttach(i).FileName)
            colAttach(i).SaveAsFile Repertoire & "embedded\" & colAttach(i).FileName
        End If
    Next i
 
    oSession.Logoff
    Set oSession = Nothing
 
    '=======================================================================
    'on enregistre le mail
    '=======================================================================
    DoEvents
    ShortStrname = "Email " & Left(remplaceCaracteresInterdit(Sujet), 160)
    strName = Repertoire & ShortStrname
    ObjCurrentMessage.SaveAs strName & ".htm", OlSaveAsType.olHTML
    ObjCurrentMessage.HTMLBody = OLDhtml
    DoEvents
    ObjCurrentMessage.Display
 
 
 
        Dim ExpShell As Object
        Dim Cmdshell, cmdshell1, resultat
        Set ExpShell = CreateObject("WScript.Shell")
 
        Cmdshell = "explorer " & Repertoire
        cmdshell1 = "explorer " & strName & ".htm"
        resultat = ExpShell.Run(Cmdshell, 1, False)
 
        controlIE strName & ".htm"
        '=======================================================================
        'Fin on nettoie
        '=======================================================================
        On Error Resume Next
 
        Repertoire = ""
        Sujet = ""
        StrEntryID = ""
 
        Set ObjCurrentMessage = Nothing
        Set ExpShell = Nothing
        MsgBox "Pensez à supprimer les fichiers une fois terminé dans C:\TEMP\Email", vbOKOnly, "Export terminé"
 
 
 
Set colAttach = Nothing
 
 
End Sub
 
Private Sub controlIE(strName As String)
    Dim ie As Object
    Set ie = CreateObject("internetexplorer.application")
    ie.Visible = True
    ie.navigate (strName)
    Do While ie.Busy
        DoEvents
    Loop
End Sub