Sub ExportToHTML()

'This code is based on the work of ediscovery, available at ediscovery.wordpress.com
'The save attachments bit is based on Michael Brederlau's post on OutlookCode.com
'To use paste the entire example code into ThisOutlookSession (or other Project) from
'within the VB editor

'####################################################################################
'WARNING 1: This script cannot cope with anything other than ordinary emails (so no invites, read
'receipts, delivery receipts etc), ordinary can of course mean any format (HTML, TXT, RTF etc)
'WARNING 2: This script also won't work at all if you don't read through it and change the folder
'paths to real folders in your system. You have to create the folders before using this script.
'It is reccomended that you have the attachments folder as a sub folder of the main message folder.
'####################################################################################

'Declare variables
Dim inBox As Outlook.MAPIFolder
Dim objEmail As MailItem
Dim inBoxItems As Outlook.Items
Dim i As Integer
Dim objAttachments As Object
Dim SubjectText As String
Dim SubjectDate As Date
Dim NewSubjectText As String
Dim Length As Integer
Dim Attachments As Integer
Dim Message

'Set folder you wish to export from - by default this is set as the Inbox only
Set inBox = Me.ActiveExplorer().Session.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)

'Get the items from the folder and set to the variable you declared
Set inBoxItems = inBox.Items

'Sort them by date
inBoxItems.Sort "SentOn", 1

'Set loop counter to 1
i = 1

'For each of the itms in the selected folder
For Each objEmail In inBoxItems
    
        'We create a new Mail item for each object in the folder
        Dim mailObj As MailItem
        Set mailObj = objEmail
    
        'First we check the message format and process accordingly
        If (objEmail.BodyFormat = olFormatPlain Or olFormatRichText Or olFormatUnspecified) Then
        
           mailObj.BodyFormat = olFormatHTML   'Converts body to HTML if not HTML format
    
        End If
        
        'Then we get the attachments
        Set objAttachments = mailObj.Attachments
    
        'If there are some
        If objAttachments.Count > 0 Then
    
          'for all attachments do...
            For Attachments = 1 To objAttachments.Count
            
                '###########################################################################
                'EDIT THE LINK HERE OR THIS WON'T WORK
                'By default it links to a sub folder called Attchments
                '###########################################################################
                'Add name and destination to message text
                
                mailObj.HTMLBody = mailObj.HTMLBody & vbCrLf & Chr(60) & "A HREF=" & Chr(34) & "Attachments\" & Format(i, "0000") & ", " & objAttachments(Attachments).DisplayName & Chr(34) & Chr(62) & objAttachments(Attachments).DisplayName & Chr(60) & "/A" & Chr(62) & Chr(60) & "BR" & Chr(62) & vbCrLf
                        
                'Save them to destination
                '###########################################################################
                'EDIT THE FOLDER NAMED HERE OR THIS WON'T WORK
                '###########################################################################
                
                objAttachments(Attachments).SaveAsFile "C:\Documents and Settings\Ed\My Documents\Outlook\Attachments\" & Format(i, "0000") & ", " & objAttachments(Attachments).DisplayName
                
            Next Attachments
    
        End If
        
        'Then we check the subject text, and remove and : which will kill the sub
        SubjectText = objEmail.Subject
        SubjectDate = objEmail.ReceivedTime
        Length = 1
        NewSubjectText = ""
    
        For Length = 1 To Len(SubjectText)
            If (Mid(SubjectText, Length, 1) = Chr(58)) Or (Mid(SubjectText, Length, 1) = Chr(92)) Or (Mid(SubjectText, Length, 1) = Chr(47)) Or (Mid(SubjectText, Length, 1) = Chr(34)) Or (Mid(SubjectText, Length, 1) = Chr(60)) Or (Mid(SubjectText, Length, 1) = Chr(62)) Or (Mid(SubjectText, Length, 1) = Chr(42)) Or (Mid(SubjectText, Length, 1) = Chr(63)) Then
                NewSubjectText = NewSubjectText & " - "
            Else
                NewSubjectText = NewSubjectText & Mid(SubjectText, Length, 1)
            End If
        Next
    
        'Save the HTML Email
        '###########################################################################
        'EDIT THE FOLDER NAMED HERE OR THIS SCRIPT WON'T WORK
        '###########################################################################
        mailObj.SaveAs "C:\Documents and Settings\Ed\My Documents\Outlook\" & Format(i, "0000") & ", " & Format(SubjectDate, "dddd mmmm dd yyyy") & ", " & NewSubjectText & ".html", olHTML
       
        'Counter used to name emails and attachments
        i = i + 1
       
Next

End Sub