More Outlook Resource Sites

Microsoft Developer Network (MSDN)

FAQs and other general resources

share code 18-Dec-2018 14:17

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
This message is displayed as VB.NET
 '***************************************************
'* 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 37comments
Page [ 1 2 3 4 Next >>  
  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).
  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
 
  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 & "'."
  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
 
  27-May-2005  20:08   
Troy,

I can help if you still need it.

Jeff
  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
  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.
  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?
  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?
  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 >>