Email VBA - 2

email_loop.vb

'Loop through each (.msg) file in your folder strIn
Do While myFile <> ""
    
    'Create record in Excel File
    On Error Resume Next
    Sheets(1).Cells(ID + 1, 1) = ID     
    Sheets(1).Cells(ID + 1, 7) = myFile
    'Open (.msg) file 
    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

    'Go to next file
    myFile = Dir
    ID = ID + 1
      
Loop

  
Application.ScreenUpdating = True
End Sub