Saving email bodies as text files in Hard Drive in Outlook

**Legacial** · 06-23-2011, 08:51 AM

Hi guys,
I'm fairly new to Outlook VBA programming so I'm in a bit of a fix. I've been trying to find a macro that can automatically save the emails in my inbox folder to another folder that i created on my hard drive named 'Documents\Outlook_Mail\Data' as text files so that I can import them into a database. I want to save the body part of the emails, not the attachments.
I scoured the net and found this macro but it keeps sending me the following error: "This folder doesn't exist". I guess problem is how I've set the object folder.

Sub MoveSelectedMessagesToFolder()

On Error Resume Next
    Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder

    Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem

    Set objNS = Application.GetNamespace("MAPI")

    Set objInbox = objNS.GetDefaultFolder(olFolderInbox)

   ' Select your destination folder
   ' Assume this is a mail folder
    Set objFolder = GetFolder("C:\Users\Agnes\Documents\Outlook_Mail\Data")
    

    If objFolder Is Nothing Then
        MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "Invalid Folder"
    End If

    If Application.ActiveExplorer.Selection.Count = 0 Then
    'Ensures that a message is selected
         MsgBox "Nothing selected", vbOKOnly + vbExclamation, "No message selected"
        Exit Sub
    End If

 
    For Each objItem In Application.ActiveExplorer.Selection
        If objFolder.DefaultItemType = olMailItem Then
            If objItem.Class = olMail Then
                objItem.Move objFolder
            End If
        End If
    Next

    Set objItem = Nothing
    Set objFolder = Nothing
    Set objInbox = Nothing
    Set objNS = Nothing

End Sub

Public Function GetFolder(StrFolderPath As String) As MAPIFolder
  ' folder path needs to be something like
  '   "Public Folders\All Public Folders\Company\Sales"
  Dim objApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim colFolders As Outlook.Folders
  Dim objFolder As Outlook.MAPIFolder
  Dim arrFolders() As String
  Dim i As Long
  On Error Resume Next

  StrFolderPath = Replace(StrFolderPath, "/", "\")
  arrFolders() = Split(StrFolderPath, "\")
  Set objApp = CreateObject("Outlook.Application")
  Set objNS = objApp.GetNamespace("MAPI")
  Set objFolder = objNS.Folders.Item(arrFolders(0))
  If Not objFolder Is Nothing Then
    For i = 1 To UBound(arrFolders)
      Set colFolders = objFolder.Folders
      Set objFolder = Nothing
      Set objFolder = colFolders.Item(arrFolders(i))
      If objFolder Is Nothing Then
        Exit For
      End If
    Next
  End If

  Set GetFolder = objFolder
  Set colFolders = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Function

Could anyone assist me with this code? I would highly appreciate your assistance. Or if possible, help me with another piece of code that can function in the way specified. Thanks in advance

**Domski** · 06-23-2011, 09:10 AM

How about this?

Sub Save_Mail_As_Text()
    
    Dim itm As Object
    Dim mFldr As Outlook.MAPIFolder
    Dim mlItm As Outlook.MailItem
    Dim strFileName As String

'    Set mFldr = ThisOutlookSession.ActiveExplorer.CurrentFolder    'Use this to select current folder
    Set mFldr = ThisOutlookSession.Session.PickFolder   'Use this to let user pick folder
           
    If MsgBox("Are you sure you want to save all the emails from " & mFldr, vbYesNo) = vbNo Then GoTo End_Code
    
    For Each itm In mFldr.Items
        If itm.Class = olMail Then
            strFileName = Left(Format(itm.ReceivedTime, "yyyymmdd hhmmss") & " - " & itm.SenderName & " - " & _
                StripIllegalChar(itm.Subject), 256) & ".txt"
            itm.SaveAs "C:\" & strFileName, olTXT
        End If
    Next itm

End_Code:
    Set mFldr = Nothing

End Sub

Function StripIllegalChar(StrInput)
    Dim RegX            As Object
    Set RegX = CreateObject("vbscript.regexp")
     
    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
    RegX.IgnoreCase = True
    RegX.Global = True
     
    StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
    Set RegX = Nothing
     
End Function

Dom

**Legacial** · 06-24-2011, 04:04 AM

It works perfectly!! Thanks!!

Just one more question, I also wanted to place the files in monthly folders such that every file saved on the hard drive will go to that month's folder, e.g. files received today will go to the June_2011 folder. Do you know a way of doing this?

**Domski** · 06-24-2011, 04:39 AM

Try this:

Sub Save_Mail_As_Text()
    
    Dim itm As Object
    Dim mFldr As Outlook.MAPIFolder
    Dim mlItm As Outlook.MailItem
    Dim strFileName As String
    Dim strFolderName As String

'    Set mFldr = ThisOutlookSession.ActiveExplorer.CurrentFolder    'Use this to select current folder
    Set mFldr = ThisOutlookSession.Session.PickFolder   'Use this to let user pick folder
           
    If MsgBox("Are you sure you want to save all the emails from " & mFldr, vbYesNo) = vbNo Then GoTo End_Code
    
    For Each itm In mFldr.Items
        If itm.Class = olMail Then
            strFolderName = "C:\" & Format(itm.ReceivedTime, "mmmm_yyyy")
            If FileFolderExists(strFolderName) = False Then
                MkDir strFolderName
            End If
            strFileName = Left(Format(itm.ReceivedTime, "yyyymmdd hhmmss") & " - " & itm.SenderName & " - " & _
                StripIllegalChar(itm.Subject), 256) & ".txt"
            itm.SaveAs strFolderName & strFileName, olTXT
        End If
    Next itm

End_Code:
    Set mFldr = Nothing

End Sub

Function StripIllegalChar(StrInput)
    Dim RegX            As Object
    Set RegX = CreateObject("vbscript.regexp")
     
    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
    RegX.IgnoreCase = True
    RegX.Global = True
     
    StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
    Set RegX = Nothing
     
End Function

Public Function FileFolderExists(strFullPath As String) As Boolean
'Author       : Ken Puls (www.excelguru.ca)
'Macro Purpose: Check if a file or folder exists

    On Error GoTo EarlyExit
    If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
    
EarlyExit:
    On Error GoTo 0

End Function

It will also check if a folder exists for the month and create one if not.

Dom

**Legacial** · 06-24-2011, 05:56 AM

I'm sure the code works just fine but when I try running it it brings up a pop-up that says "Outlook cannot complete the save due to a file permission error".what might the problem be, because I have the required access to the mail in outlook.

**Domski** · 06-24-2011, 06:51 AM

Oops.

This:

itm.SaveAs strFolderName & strFileName, olTXT

should be:

itm.SaveAs strFolderName & "\" & strFileName, olTXT

Dom

**Legacial** · 06-24-2011, 08:25 AM

It works beautifully!! Thanks so much!!

**Domski** · 06-24-2011, 08:53 AM

Cool, if you are happy with the solution please mark the thread as solved.

f your problem is solved, please say so clearly, and mark your thread as Solved: Click the Edit button on your first post in the thread, Click Go Advanced, select [SOLVED] from the Prefix dropdown, then click Save Changes. If more than two days have elapsed, the Edit button will not appear -- ask a moderator to mark it.

Dom