codice:
Programma VBA di salvataggio mail HTML

Riferimenti: 
Microsoft Scripting RunTime
Microsoft Internet Controls

‘Nel modulo di classe ThisWorkbook
Private WithEvents colNews As Outlook.Items
Private Sub Application_Quit()
    On Error Resume Next
    Set colNews = Nothing
    Set FSO = Nothing
    Set myNS = Nothing
End Sub

Private Sub Application_Startup()
    Dim FoldNews As Outlook.MAPIFolder
    Call SettaItem
    Set FoldNews = myNS.GetDefaultFolder(olFolderInbox).Folders("NewsLetter") 
    Set colNews = FoldNews.Items
    Set FoldNews = Nothing
    swFatto = False
    If colNews.Count > 0 Then Call Inizia
End Sub

Private Sub colNews_ItemAdd(ByVal Item As Object)
    Call SalvaHTMLMail(Item)
End Sub

Sub Inizia()
    Dim Ele As Outlook.MailItem, i As Integer, Cont As Long
    Cont = colNews.Count
    For i = Cont To 1 Step -1
        Set Ele = colNews(i)
        Call SalvaHTMLMail(Ele)
        Set Ele = Nothing
    Next
End Sub
‘in un modulo a parte
Public myNS As Outlook.NameSpace
Public MyArchivio As MAPIFolder
Public Utente As String
Public UtenteMapi As String
Public FSO As Scripting.FileSystemObject
Sub SettaItem()
    If myNS Is Nothing Then Set myNS = Application.GetNamespace("Mapi")
    If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
    Utente = Environ$("UserName")
    UtenteMapi = Application.Session.CurrentUser
End Sub

Sub SalvaHTMLMail(ByVal Item As Object)
    Dim arrSubject As Variant, F As Scripting.TextStream, Att As Attachment, strFold As String
    Dim j As Integer, strPathAtt As String
    Dim ContaAtt As Integer, t As Integer, strHtml As String, swModificato As Boolean
    Dim CercaCID As String, TrovatoCID As Long, NumFile As Integer, PercorsoFile As String
    arrSubject = Array("JavaScript", "CSS", "Programmazione", "Microsoft Dev", "Grafica e design") ‘cartelle sul disco riguardanti il subject della newsletter
    swModificato = False
    For j = 0 To UBound(arrSubject)
        If InStr(1, Item.Subject, arrSubject(j), vbBinaryCompare) > 0 Then
            strFold = "E:\andrea\Posta\" & arrSubject(j)
            If Len(Trim$(Dir$(strFold, vbDirectory))) = 0 Then
                MkDir strFold
                MkDir strFold & "\Immagini"
            End If
            strHtml = Item.HTMLBody ‘per formato testo usare la proprietà Body e cancellare fino alla freccia
            ContaAtt = Item.Attachments.Count
            For t = ContaAtt To 1 Step -1
                Set Att = Item.Attachments(t)
                strPathAtt = strFold & "\Immagini\" & Att.FileName
                If Len(Trim$(Dir(strPathAtt))) > 0 Then Kill strPathAtt
                Att.SaveAsFile strPathAtt
                TrovatoCID = InStrRev(strHtml, "cid:", , vbTextCompare)
                CercaCID = Mid$(strHtml, TrovatoCID)
                CercaCID = Mid$(CercaCID, 1, InStr(1, CercaCID, Chr(34)) - 1)
                strHtml = Replace(strHtml, CercaCID, strPathAtt)
                Set Att = Nothing
                DoEvents
            Next 
            NumFile = FreeFile
            PercorsoFile = strFold & "\" & Format(Date, "dd-mm-yyyy") & ".htm" ‘nome file = data odierna
            If Len(Trim$(Dir(PercorsoFile))) > 0 Then Kill PercorsoFile
            Set F = FSO.CreateTextFile(PercorsoFile)
            F.Write strHtml
            F.Close
            Set F = Nothing
            swModificato = True
            Exit For
        End If
    Next
    If swModificato = True Then ‘se tutto è andato a buon fine, cancello la mail e apro il browser
        Item.Delete
        Call ApriBrowser(PercorsoFile, True)
    End If
End Sub

‘in un altro modulo
Option Explicit

Const ENUM_CURRENT_SETTINGS As Long = -1&
Const CCDEVICENAME = 32
Const CCFORMNAME = 32
Public Type DEVMODE
    dmDeviceName As String * CCDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Sub ApriBrowser(ByVal strUrl As String, Optional blToolbar As Boolean = False)
    Dim Web As SHDocVw.InternetExplorer, Schermo As DEVMODE
    Call EnumDisplaySettings(0&, ENUM_CURRENT_SETTINGS, Schermo)
    Set Web = CreateObject("InternetExplorer.Application")
    With Web
        .Width = Schermo.dmPelsWidth * (90 / 100)
        .Height = Schermo.dmPelsHeight * (90 / 100)
        .Top = Schermo.dmPelsHeight * (5 / 100)
        .Left = Schermo.dmPelsWidth * (5 / 100)
        .Resizable = False
        .MenuBar = False
        .StatusBar = False
        .AddressBar = False
        .Toolbar = blToolbar
        .Visible = True
        .Navigate strUrl
    End With
    Set Web = Nothing
End Sub

Se avete consigli o se manca qualcosa o errori vari contattatemi