Macro to extract .msg subject and date into excel

agouveia

New Member
Joined
Sep 9, 2014
Messages
5
Hello,

This problem has been posted here and in a few other forums a few other times.
I've tried editing previous codes and ended up in a blurb of "Man, I really don't know much about coding!"

Here's the deal: I got nearly 1500 .msg files, of which I need their date and subject, to subsequently rename these files based on that info. In order to get each message date and subject I've found this piece of code:

Sub GetMailInfo()

Dim MyOutlook As Outlook.Application
Dim msg As Outlook.MailItem
Dim x As Namespace
Dim Path As String
'Dim FileList As Variant


Set MyOutlook = New Outlook.Application
Set x = MyOutlook.GetNamespace("MAPI")

Path = "C:\Users\TEST 2"
FileList = GetFileList(Path + "*.msg")

Row = 1

While Row <= UBound(FileList) **CURRENT BUG STOPS HERE WITH TYPE 13 MISMATCH ERROR**

Set msg = x.OpenSharedItem(Path + FileList(Row))

Cells(Row + 1, 1) = msg.Subject
Cells(Row + 1, 2) = msg.SenderName
Cells(Row + 1, 3) = msg.SenderEmailAddress
Cells(Row + 1, 4) = msg.CC
Cells(Row + 1, 5) = msg.To
Cells(Row + 1, 6) = msg.SentOn
Cells(Row + 1, 7) = msg.Size


Row = Row + 1
Wend

End Sub

Sub test()
**WHEN RUNNING THIS... I'M GETTING RESULTS SAYING THAT THERE ARE NO FILES MATCHING... WHAT?***

Dim p As String, x As Variant

p = "C:/Users/TEST 2"
x = GetFileList(p + "*.msg")
Select Case IsArray(x)
Case True 'files found
MsgBox UBound(x)
Sheets("Sheet1").Range("A:A").Clear
For i = LBound(x) To UBound(x)
Sheets("Sheet1").Cells(i, 1).Value = x(i)
Next i
Case False 'no files found
MsgBox "No matching files"
End Select
End Sub



Function GetFileList(FileSpec As String) As Variant (another piece of code that was with the first part)

** I'm not sure if the error here is because I have no directory specified for FileSpec **

' Taken from Excel Tips From John Walkenbach: Getting A List Of File Names Using VBA
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False


Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String


On Error GoTo NoFilesFound


FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound


' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function


' Error handler
NoFilesFound:
GetFileList = False
End Function

HELP?
Anything that could direct me in having this working and finally getting through this would be VERY VERY VERY helpful!


Thanks <3
Ana
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK

Forum statistics

Threads
1,225,137
Messages
6,183,081
Members
453,146
Latest member
Lacey D

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top