Converting MSG files to TXT files

Hello,

I am probably posting a question that has already been answered. Because I am new to the Excel Forum, I was unable to find the solution.

I am writing a macro that includes converting a series to msg files to corresponding txt files. The full path is the parameter, for example "c:\Documents\OutlookFiles\message1.msg" Has this VBA code been written before? Thanks!

Hi,
Basically you can copy/paste all code below in a VBA module, then add Reference to "Microsoft Outlook Objects Library".
Change the path to the folder where all yours .msg file are (under ConvertMsgToTXT sub, see comment in code).
What you should be aware of - this code creates separate .txt file for each .msg, name of each .txt file is "Sender" + "Sent Date". In case there will be more than one Outlook message from the same Sender - files fill be re-written.
You should run "Sub ConvertMsgToTXT()" to get all .msg files converted.

Sub ConvertMsgToTXT()

Call GetMailInfo("C:\Users\Desktop\New Folder\")  'your folder with .msg files to be converted

End Sub



Sub GetMailInfo(Path As String)

    Dim MyOutlook As Outlook.Application
    Dim msg As Outlook.MailItem
    Dim x As Namespace
    Dim strContent As String
    
    Set MyOutlook = New Outlook.Application
    Set x = MyOutlook.GetNamespace("MAPI")

    FileList = GetFileList(Path + "*.msg")
    
    Row = 1

    While Row <= UBound(FileList) 'loops until processes all file in folder
        
        strContent = ""
        
        Set msg = x.OpenSharedItem(Path + FileList(Row))
        'creates .txt file in the folder where current excel is
        Open ThisWorkbook.Path & "\" & msg.Sender + Format(msg.SentOn, "DD.MM.YYYY") & ".txt" For Output As #1
        
        'collect some basic info from Outlook message in one string
        strContent = msg.Subject
        strContent = strContent + " " + msg.Sender
        strContent = strContent + " " + msg.CC
        strContent = strContent + " " + msg.To
        strContent = strContent + " " + Format(msg.SentOn, "DD.MM.YYYY, hh:mm")
        strContent = strContent + " " + msg.Body
                
        Print #1, strContent 'write string o file
        
        Close #1 'close file
        
        Row = Row + 1
        
    Wend

End Sub

Function GetFileList(FileSpec As String) As Variant
'   Taken from http://spreadsheetpage.com/index.php/tip/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