Save your Outlook mails as Notepad text plus attachment

Jaya Jagannath,

Sometimes we wonder why Outlook does not have a provision for self reformation into other readable decks. No where we could find a destination to this query. This has been a worry of IT professionals since decades to save their huge bulk of lakhs of outlook mails in some simple format that can be readable any where, every where. Mostly during separation from the employer, Professionals wish to keep a back up of their important mails even, but no way they can achieve the same.

With grace of Lord Jagannath, here comes the most simplest, light weight but perfect solution. Please find attached the source code for saving all your Outlook mails as Notepad files in the same hierarchy as it was distributed across folder links inside Outlook. Just a three step process and that's all you need to save all you outlook mails as attachments. Information inside your huge mountain of .pst file will shrink and reside inside just few kbs of note pad files. Amazing.

Procedure to Operate :

1. Open your MS Outlook 2000/ 2003 and press Ctrl + F11.
2. Paste the Source Code from here.
3. press F5 to execute and give number parameters as per your choice.
---------------------------------------------------------------------------------------------------------------------

Sub AAASaveMails()

Dim myOlApp As Outlook.Application
Dim myNamespace As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder
Dim myForFolder As Outlook.Folders
Dim myMail As Outlook.MailItem
Dim Path As String
Dim Folder As String
Dim DestFolder As String


Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderContacts)
Path = InputBox("Enter the destination location", "SAVE", "C:\Arun\Mails\")
Set fs1 = CreateObject("Scripting.FileSystemObject")
Set a = fs1.CreateTextFile("c:\Reference.txt", True)

Pfl = 1

Do While Pfl <= myNamespace.Folders.Count
PFNames = PFNames & vbCrLf & Pfl & " . " & myNamespace.Folders.Item(Pfl).Name
Pfl = Pfl + 1
Loop

PFolder = InputBox(PFNames, "Enter the Number", 4)

If PFolder >= 1 And PFolder <= myNamespace.Folders.Count Then

Set myForFolder = myNamespace.Folders.Item(PFolder).Folders
CurrentPath = Path
fl = 1
Do While fl <= myForFolder.Count
FNames = FNames & vbCrLf & fl & " . " & myForFolder.Item(fl).Name
fl = fl + 1
Loop
Folder = InputBox(FNames, "Enter the Number", 8)
Set fs = CreateObject("Scripting.FileSystemObject")
If Folder > 1 And Folder <= myForFolder.Count Then
For j = 1 To myForFolder.Item(Folder).Items.Count
Set myMail = myForFolder.Item(Folder).Items.Item(j)
If (fs.FolderExists(Path & Format(Replace(DateValue(myMail.ReceivedTime), "/", "-"), "dddd, mmm d yyyy")) = False) Then
If q <> 0 Then
a.WriteLine (q - 1 & " items saved in " & CurrentPath)
End If
Set CurrentPath = fs.CreateFolder(Path & Format(Replace(DateValue(myMail.ReceivedTime), "/", "-"), "dddd, mmm d yyyy"))
CurrentPath = CurrentPath & "\"
q = 1
Else
CurrentPath = Path & Format(Replace(DateValue(myMail.ReceivedTime), "/", "-"), "dddd, mmm d yyyy")
CurrentPath = CurrentPath & "\"
End If

If q < 10 Then
Z = "00" & q
ElseIf q < 100 Then
Z = "0" & q
Else
Z = q
End If

If (myMail.Attachments.Count > 0) Then
If (fs.FolderExists(Path & "Attachments") = False) Then
Set CurrentPath1 = fs.CreateFolder(Path & "Attachments")
End If

If (fs.FolderExists(Path & "Attachments\" & Format(Replace(DateValue(myMail.ReceivedTime), "/", "-"), "dddd, mmm d yyyy")) = False) Then
Set CurrentPath1 = fs.CreateFolder(Path & "Attachments\" & Format(Replace(DateValue(myMail.ReceivedTime), "/", "-"), "dddd, mmm d yyyy"))
End If

For k = 1 To myMail.Attachments.Count
Subject = Replace(myMail.Subject, ":", " ")
Subject = Replace(Subject, "/", "")
Subject = Replace(Subject, ".", "")
Subject = Replace(Subject, "?", "")
Subject = Replace(Subject, Chr(34), "")
Subject = Replace(Subject, "<", "")
Subject = Replace(Subject, ">", "")
AttName = Replace(myMail.Attachments.Item(k).DisplayName, ":", "")
myMail.Attachments.Item(k).SaveAsFile CurrentPath1 & "\" & Z & " . " & Subject & " " & AttName
Next k
End If

M = Split(myMail.ReceivedTime, " ")
N = Split(M(1), ":")

If (myMail.Subject = "") Then
FileName = CurrentPath & Z & " . " & "NoSubject " & N(0) & " " & N(1) & " " & N(2) & " " & M(2) & ".msg"
Else
Subject = Replace(myMail.Subject, ":", " ")
Subject = Replace(Subject, "/", "")
Subject = Replace(Subject, ".", "")
Subject = Replace(Subject, "?", "")
Subject = Replace(Subject, Chr(34), "")
Subject = Replace(Subject, "<", "")
Subject = Replace(Subject, ">", "")
FileName = CurrentPath & Z & " . " & Subject & " " & N(0) & " " & N(1) & " " & N(2) & " " & M(2) & ".msg"
End If

FileName = Replace(FileName, "?", "")
myMail.SaveAs FileName, olMailItem

q = q + 1

Next j
Else
s = MsgBox("Enter a valid Number", vbCritical)
End If

Else
s = MsgBox("Enter a valid Number", vbCritical)
End If
a.WriteLine (q - 1 & " items saved in " & CurrentPath)
s = MsgBox("Done", vbInformation)

End Sub
---------------------------------------------------------------------------------------------------------------------------------------------

In case of any clarifications or guidance please contact Sri. Siba Ram Baral at 9845760848. Jaya Jagannath.

Regards
Nilachakra
http://nilachakra.50webs.com