Created
March 26, 2021 14:02
-
-
Save samirsaci/2761b59cb8640bcb4f3d3ea913ec52df to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment