I have an excel workbook which I am using to loop through a bunch of .msg files in a folder to extract the 'sent on', 'sender' and 'subject' fields. I can extract the information but only by expressly referencing the name of the files (in this case test and test2). How do I loop through all the .msg files in the directory and extract the relevant info? This is what I have so far:
Option Explicit
Sub getMsgData()
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim mailDoc As Outlook.MailItem
Dim i As Long
i = 1
Dim nam As Variant
For Each nam In Array("test.msg", "test2.msg")
Set mailDoc = olApp.Session.OpenSharedItem(ActiveWorkbook.Path & "\" & nam)
Sheets("sheet1").Range("a1").Offset(i) = mailDoc.SentOn
Sheets("sheet1").Range("a1").Offset(i, 1) = mailDoc.Sender
Sheets("sheet1").Range("a1").Offset(i, 2) = mailDoc.Subject
mailDoc.Close False
i = i + 1
Next nam
olApp.Quit
Set mailDoc = Nothing
Set olApp = Nothing
End Sub
This will loop through every file in a directory that is a .msg file Haven't used the OpenSharedItem so you may need direct & "\\" & myfile in place of just myfile. I do not recommend using ActiveWorkbook.Path, but maybe you have no other way, like asking the user to select the folder in FolderPicker?
direct = ActiveWorkbook.Path
myfile = Dir(direct, "*.msg") 'sets myfile equal to the first file name
Do While myfile <> "" 'loops until there are no more files in the directory
Set mailDoc = olApp.Session.OpenSharedItem(myfile)
Sheets("sheet1").Range("a1").Offset(i) = mailDoc.SentOn
Sheets("sheet1").Range("a1").Offset(i, 1) = mailDoc.Sender
Sheets("sheet1").Range("a1").Offset(i, 2) = mailDoc.Subject
mailDoc.Close False
i = i + 1
myfile = Dir
Loop
You do this using the Dir
function. An example of how to use it is found here . For your case this is the correct code:
Option Explicit
Sub getMsgData()
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim mailDoc As Outlook.MailItem
Dim i As Long
i = 1
Dim nam As String
nam = Dir(ActiveWorkbook.Path & "\*.msg")
Do While nam <> ""
Set mailDoc = olApp.Session.OpenSharedItem(ActiveWorkbook.Path & "\" & nam)
Sheets("sheet1").Range("a1").Offset(i) = mailDoc.SentOn
Sheets("sheet1").Range("a1").Offset(i, 1) = mailDoc.Sender
Sheets("sheet1").Range("a1").Offset(i, 2) = mailDoc.Subject
mailDoc.Close False
i = i + 1
nam = Dir
Loop
olApp.Quit
Set mailDoc = Nothing
Set olApp = Nothing
End Sub
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.