email_full.vb

Sub SaveMSG_as_HTML()
Application.ScreenUpdating = False

Dim olMsg As MailItem
Dim strPath As String
Dim strMsg As String
Dim strHTML As String


Dim Sender, Received_Time As String
Dim ID As Integer
ID = 1

'Path In
strIn = "C:\YourFolderIn"
'Path Out
strOut = "C:\YourFolderOut"

'Target File Extension (must include wildcard "*")
myExtension = "*.msg*"

'Target Path with Ending Extention: all (.msg) files in this folder
myFile = Dir(strIn & myExtension)

'Loop through each Excel file in folder
Do While myFile <> ""
    
    'Ouvrir message
    On Error Resume Next
    Sheets(1).Cells(ID + 1, 1) = ID
    Sheets(1).Cells(ID + 1, 7) = myFile
    Set olMsg = Session.OpenSharedItem(strIn & myFile)
    strName = ID & ".html"

    'Extract email information
    Sender = olMsg.SenderName
    Received_Time = olMsg.ReceivedTime
    Sender_Adress = olMsg.SenderEmailAddress
    Sender_EmailType = olMsg.SenderEmailType
    Subject = olMsg.Subject
    Body = olMsg.Body
    
    
    'Copy information to your excel file
    Sheets(1).Cells(ID + 1, 2) = Sender
    Sheets(1).Cells(ID + 1, 3) = Sender_Adress
    Sheets(1).Cells(ID + 1, 4) = Sender_EmailType
    Sheets(1).Cells(ID + 1, 5) = Received_Time
    Sheets(1).Cells(ID + 1, 6) = Subject
    Sheets(1).Cells(ID + 1, 6) = Body
    
    
    'Save Attachment
    If olMsg.Attachments.Count > 0 Then 'If there is an Attachement in the email
         For i = 1 To olMsg.Attachments.Count
            If InStr(olMsg.Attachments(i).Filename, "image") = 0 Then
                olMsg.Attachments(i).SaveAsFile strOut & "ID" & ID & "-" & olMsg.Attachments(i).Filename
            End If
         Next
    End If
    olMsg.SaveAs Path:=strOut & strName, Type:=olHTML
    olMsg.Close olDiscard
lbl_Exit:
    Set olMsg = Nothing

    'Get next file name
    myFile = Dir
    ID = ID + 1
      
Loop

  
Application.ScreenUpdating = True
End Sub