Outlook Technologies

Outlook Forms

Languages

Samples

More Outlook Resource Sites

Microsoft Developer Network (MSDN)

FAQs and other general resources

share code 09-Sep-2010 05:54

Looking for help with Outlook programming projects — VSTO, add-ins, VBA, custom Outlook forms, etc.? You′ve come to the right place!

NEW! >> Subscribe to this site via RSS. For more RSS options, see the complete list of feeds on our main news page.

Code level: beginner Code area: Basic Outlook Printer Friendly Version
Title: PST2TXT
Description: This file will export all PST files found in the selected folder to Text files. The exported text files will be in the same folder structure as the PST folders. Please ensure you have backed up the PST files prior to running this script on them.
Date: 01-Apr-2005 13:43
Code level: beginner
Code area: Basic Outlook
Posted by: Steven Harvey
Body: '*************************************************** '* Title: PST2TXT '* Author: Steven Harvey (vbscript@hexcellent.net) '* Created: 04/01/05 '* Description: '* This file will export all PST files found '* in the selected folder to Text files. The '* exported text files will be in the same '* folder structure as the PST folders. Please '* ensure you have backed up the PST files '* prior to running this script on them. '* '* Save this code to a file and name it PST2TXT.vbs '*************************************************** Dim objApp Dim objNS Dim objFolder Dim objNewFolder Dim strWorkingFolder Dim strDestination Dim strLogFile Main() Sub Main() strWorkingFolder = GetFileDir("Please select the folder containing the PST files") If strWorkingFolder <> "" Or strWorkingFolder <> Null Then 'Get the files from the chosen folder and process all PST files Set objFSO = CreateObject("Scripting.FileSystemObject") Set objWorkingFolder = objFSO.GetFolder(strWorkingFolder) Set colFiles = objWorkingFolder.Files For Each objFile In colFiles If UCase(objFSO.GetExtensionName(objFile.Path)) = "PST" Then Set objApp = CreateObject("Outlook.Application") Set objNS = objApp.GetNameSpace("MAPI") strDestination = Left(objFile.Path, Len(objFile.Path) - Len(objFile.Name)) & Left(objFile.Name, Len(objFile.Name) - 4) objFSO.CreateFolder(strDestination) strLogFile = strDestination & "\ExportLog.txt" objNS.AddStore objFile.Path Set objNewFolder = objNS.Folders.GetLast ProcessFolder objNewFolder, strDestination WriteToLog "Processing Completed normally." Err.Clear On Error Resume Next Do objNS.RemoveStore objNewFolder If Err.Number = 0 Then Exit Do Else Err.Clear End If Loop Set objNewFolder = Nothing Set objNS = Nothing End If Set objFile = Nothing Next MsgBox "All files processed!" & vbCrLf & "Files are located in subfolders of the selected folder." & vbCrLf & "View the logfile in each PST files folder to see any errors." Else MsgBox "No PST files in the folder selected!" End If Set objFolder = Nothing Set objNewFolder = Nothing Set objNS = Nothing Set objApp = Nothing End Sub Function FolderExist(sFileName) FolderExist = IIf(Dir(sFileName, vbDirectory) <> "", True, False) End Function Function GetFileDir(strTitleText) Const BIF_returnonlyfsdirs = &H0001 Const BSF_drives = 17 Set objShell = CreateObject("Shell.Application") Set objBrowser = objShell.BrowseForFolder(&H0, strTitleText, BIF_returnonlyfsdirs, BSF_drives) strFilePath = objBrowser.ParentFolder.ParseName(objBrowser.Title).Path GetFileDir = strFilePath End Function Sub ProcessFolder(StartFolder, strPath) On Error Resume Next Dim objItem Dim objAttachment Dim objFolder Dim objFSO Set objFSO = CreateObject("Scripting.FileSystemObject") ' process all the items in this folder For Each objItem In StartFolder.Items For Each objAttachment In objItem.Attachments objItem.Body = objItem.Body & vbCrLf & "Attachment: " & objAttachment.Filename Next SaveAsTxt objItem, strPath Set objItem = Nothing Next ' process all the subfolders of this folder For Each objFolder In StartFolder.Folders Dim strSubFolder strSubFolder = strPath & "\" & CleanString(objFolder.Name) objFSO.CreateFolder(strSubFolder) Call ProcessFolder(objFolder, strSubFolder) Next Set objFSO = Nothing Set objFolder = Nothing Set objItem = Nothing End Sub Function CleanString(strData) 'Replace invalid strings. strData = ReplaceChar(strData, ":", "-") strData = ReplaceChar(strData, "_", "") strData = ReplaceChar(strData, "´", "'") strData = ReplaceChar(strData, "`", "'") strData = ReplaceChar(strData, "{", "(") strData = ReplaceChar(strData, "[", "(") strData = ReplaceChar(strData, "]", ")") strData = ReplaceChar(strData, "}", ")") strData = ReplaceChar(strData, "/", "-") strData = ReplaceChar(strData, "\", "-") strData = ReplaceChar(strData, ":", "") strData = ReplaceChar(strData, ",", "") 'Cut out invalid signs. strData = ReplaceChar(strData, "*", "'") strData = ReplaceChar(strData, "?", "") strData = ReplaceChar(strData, """", "'") strData = ReplaceChar(strData, "<", "") strData = ReplaceChar(strData, ">", "") strData = ReplaceChar(strData, "\|", "") CleanString = Trim(strData) End Function Function ReplaceChar(strData, strBadChar, strGoodChar) Dim tmpChar Dim tmpString For i = 1 To Len(strData) tmpChar = Mid(strData, i, 1) If tmpChar = strBadChar Then tmpString = tmpString & strGoodChar Else tmpString = tmpString & tmpChar End If Next ReplaceChar = Trim(tmpString) End Function Function EnsureProperFileLength(strFolderPath, strFilename) If Len(strFolderPath & strFilename) > 200 Then strFilename = Left(strFilename, 200 - Len(strFolderPath)) End If EnsureProperFileLength = strFilename End Function Sub SaveAsTxt(objItem, strFolderPath) On Error Resume Next Dim strSubject Dim strSaveName Err.Clear If Not objItem Is Nothing Then Select Case TypeName(objItem) Case "AppointmentItem" strSaveName = objItem.Start & " " & EnsureProperFileLength(strFolderPath, objItem.Subject) & ".txt" Case "MailItem" strSaveName = objItem.ReceivedTime & " " & EnsureProperFileLength(strFolderPath, objItem.Subject) & ".txt" If Err Then WriteToLog "Error #" & Err.Number & ": " & Err.Description & " Unable to process message '" & strFolderPath & "\" & objItem.Subject & "'." strSaveName = "" End If Case "NoteItem" strSaveName = EnsureProperFileLength(strFolderPath, objItem.Subject) & ".txt" Case "TaskItem" strSaveName = EnsureProperFileLength(strFolderPath, objItem.Subject) & ".txt" Case "ContactItem" strSaveName = objItem.FileAs & ".txt" Case Else strSaveName = "" End Select Err.Clear objItem.SaveAs strFolderPath & "\" & CleanString(strSaveName), olTXT If Err Then WriteToLog "Error #" & Err.Number & ": " & Err.Description & " Unable to process message '" & strFolderPath & "\" & objItem.Subject & "'." Else WriteToLog "Success: " & strFolderPath & "\" & CleanString(strSaveName) End If End If End Sub Sub WriteToLog(strMessage) Dim objFSO, objFile Const ForReading = 1, ForWriting = 2, ForAppending = 8 Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFile = objFSO.OpenTextFile(strLogFile, ForAppending, True) objFile.WriteLine(strMessage) objFile.Close End Sub
All 35comments

	Page [ 1 2 3 4 Next >> ]
	Steven Harvey 01-Apr-2005 22:03 Yes, this is very similar to my PST2MSG post. A big difference is that this one is in VBScript. I have also cleaned up a few things with the code while I ported it to VBS. Maybe it's just me, but this seems to run faster than the PST2MSG. Probably because it's exporting to TXT files and not dealing with attachments other than putting a note regarding them in the Body of the items. Anyhoo, enjoy! Oh, this will still fail on an export of a Dist List or encrypted item (if you dont have the cert).
	Steven Harvey 01-Apr-2005 22:07 The below function isnt used and isnt VBScript compatable so just remove it.... Function FolderExist(sFileName) FolderExist = IIf(Dir(sFileName, vbDirectory) <> "", True, False) End Function
	Steven Harvey 02-Apr-2005 16:40 The forums broke a few of the code lines. You'll need to reassemble the below lines to get around initial errors due to this... strDestination = Left(objFile.Path, Len(objFile.Path) - Len(objFile.Name)) & Left(objFile.Name, Len(objFile.Name) - 4) MsgBox "All files processed!" & vbCrLf & "Files are located in subfolders of the selected folder." & vbCrLf & "View the logfile in each PST files folder to see any errors." WriteToLog "Error #" & Err.Number & ": " & Err.Description & " Unable to process message '" & strFolderPath & "\" & objItem.Subject & "'." WriteToLog "Error #" & Err.Number & ": " & Err.Description & " Unable to process message '" & strFolderPath & "\" & objItem.Subject & "'."
	Troy Bruder 20-Apr-2005 16:34 Hi Steve, I just started looking at your script for exporting a PST2 to TXT format via vbScript... I'm in DESPERATE need to search hundreds of PST files from several years worth of backups for a lawsuit investigation. We are currently doing the searches MANUALLY which is killing us. I'm looking for something that can take an original PST file, search all folders/subfolders for keyword matches, then COPY those items to a subfolder... Ideally, I would create a subfolder called "KEYWORDS" then create a subfolder within that for each actual keyword..... then place a COPY messages matching the search into the associated folder.. Any chance you have something similar I could attempt to modify?? I'm desperate! Thanks, Troy
	millennium_crazy 27-May-2005 20:08 Troy, I can help if you still need it. Jeff
	Fred Shilmover 05-Aug-2005 15:18 Sorry if this is a dumb question from someone who can't read code, but I keep getting file permission errors: Error #-2147352567: Can't write to file: C:\recordret\backup\Inbox\. Right-click the folder that contains the file you want to write to, and then click Properties on the shortcut menu to check your permissions for the folder. Unable to process message 'C:\recordret\backup\Inbox\'. I know that I have permissions to this folder, so the problem must be something else. Any advice would be appreciated. - Fred
	Sue Mosher 08-Aug-2005 08:54 C:\recordret\backup\Inbox\ looks like the name of a folder, not the name of a file. You might want to check that you have a valid filename.
	Amanda Kirk 15-Aug-2005 13:34 I have this script exporting emails and saving them in MS Word files but is there a way to only save the Body of the email and not save all of the header info?
	Amanda Kirk 15-Aug-2005 14:02 I have this script exporting emails and saving them in MS Word files but is there a way to only save the Body of the email and not save all of the header info?
	Anonymous 27-Sep-2005 13:57 Message to Amanda Kirk, How do you locate all of your .PST files in order to run the script that you created? Did you ever find an answer to your question about saving only the Body of the Outlook email showhow - as perhaps a .txt file - in order to copy and/or paste into Word - because what I am looking for is an Outlook macro that would run in Outlook and take all Body Text from select or all e-mails and paste it into Word. Anyone else know how to do this? thanks - Bonnie McKinnon
	Page [ 1 2 3 4 Next >> ]

name email