Export the Outlook messages in txt format

**************************************************
' Title: PST2TXT
'
' Description:
' This VB application will export selected
' Outlook folders to file system as TXT files.
' The intent is to allow quick reference when
' burned to CD due to Outlook not opening
' Read Only PST files.
'
' Use: Paste the code into a VB5/6 module
' There is an optional Form explained in code
'
' Notes:
' This code is offered 'As Is'.
' No support will be provided by me.
'
' Author: Steven Harvey
' Free to use for all
'
'**************************************************
Public Const BIF_RETURNONLYFSDIRS = 1
Public Const MAX_PATH = 260

Public Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type

'APIs for the folder selection
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Private objNS As NameSpace
Private objFolder As Outlook.MAPIFolder
Private strDestination As String
Private strTopFolder As String
Private strLogFile As String
Private intErrors As Boolean
Public intUserAbort As Integer

Sub Main()
Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.PickFolder

If Not objFolder Is Nothing Then
strTopFolder = CleanString(objFolder.Name)
strDestination = GetFileDir
If strDestination <> "" Or strDestination <> Null Then
strFolderName = CleanString(objFolder.Name)
strLogFile = strDestination & "\" & strFolderName & "\ExportLog.txt"
strDestination = strDestination & "\" & strFolderName
If FolderExist(strDestination) Then
MsgBox "This folder has already been exported here. Please clear the destination or choose another."
Exit Sub
Else
'****** frmProcessing displays while processing messages.
'****** It has a message asking user to wait while processing.
'****** It also has a cancel button to set intUserAbort to 1.
'****** Form's button code is below
'*** Private Sub cmdCancel_Click()
'*** intUserAbort = 1
'*** Unload Me
'*** End Sub
'frmProcessing.Show

intUserAbort = 0
ProcessFolder objFolder, strDestination

'Unload frmProcessing

If intUserAbort = 0 Then
MsgBox "Export Complete!" & vbCrLf & "Export log file location:" & vbCrLf & strLogFile
Else
MsgBox "Processing cancelled." & vbCrLf & "Export log file location:" & vbCrLf & strLogFile
End If
End If
Else
MsgBox "Destination folder selection cancelled!"
End If
Else
MsgBox "MAPI folder selection cancelled!"
End If

Set objNS = Nothing
Set objFolder = Nothing
End Sub

Function FolderExist(sFileName As String) As Boolean
FolderExist = IIf(Dir(sFileName, vbDirectory) <> "", True, False)
End Function

Public Function StripNulls(ByVal OriginalStr As String) As String
If (InStr(OriginalStr, Chr$(0)) > 0) Then
OriginalStr = Left$(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
End If
StripNulls = OriginalStr
End Function

Public Function GetFileDir() As String
Dim ret As String
Dim lpIDList As Long
Dim sPath As String, udtBI As BrowseInfo
Dim RdStrings() As String, nNewFiles As Long

'Show a browse-for-folder form:
With udtBI
.lpszTitle = lstrcat("Please select a folder to export to:", "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With

lpIDList = SHBrowseForFolder(udtBI)
If lpIDList = 0 Then Exit Function

'Get the selected folder.
sPath = String$(MAX_PATH, 0)
SHGetPathFromIDList lpIDList, sPath
CoTaskMemFree lpIDList
sPath = StripNulls(sPath)
GetFileDir = sPath
End Function

Sub ProcessFolder(StartFolder As Outlook.MAPIFolder, strPath As String)
Dim objItem As Object

MkDir strPath
' process all the items in this folder
For Each objItem In StartFolder.Items
DoEvents
SaveAsMsg objItem, strPath
Set objItem = Nothing
Next

' process all the subfolders of this folder
For Each objFolder In StartFolder.Folders
Dim strSubFolder As String
strSubFolder = strPath & "\" & CleanString(StartFolder.Name)
Call ProcessFolder(objFolder, strSubFolder)
Next

Set objFolder = Nothing
Set objItem = Nothing
End Sub

Private Function CleanString(strData As String) As String
'Replace invalid strings.
strData = ReplaceChar(strData, "_", "")
strData = ReplaceChar(strData, "L", "'")
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

Private Function ReplaceChar(strData As String, strBadChar As String, strGoodChar As String) As String
Dim tmpChar, tmpString As String
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 i
ReplaceChar = Trim(tmpString)
End Function

Private Sub SaveAsMsg(objItem As Object, strFolderPath As String)
On Error Resume Next
Dim strSubject As String
Dim strSaveName As String

Err.Clear
If Not objItem Is Nothing Then
Select Case TypeName(objItem)
Case "AppointmentItem"
strSaveName = Format(objItem.Start, "mm-dd-yyyy hh.nn.ss") & " " & IIf(Len(strFolderPath & objItem.Subject) > 255, Left(objItem.Subject, 255 - Len(strFolderPath)), objItem.Subject)
Case "MailItem"
strSaveName = Format(objItem.ReceivedTime, "mm-dd-yyyy hh.nn.ss") & " " & IIf(Len(strFolderPath & objItem.Subject) > 255, Left(objItem.Subject, 255 - Len(strFolderPath)), objItem.Subject)
If Err Then
WriteToLog "Error #" & Err.Number & ": " & Err.Description & " Unable to process message '" & strFolderPath & "\" & objItem.Subject & "'."
strSaveName = strFolderPath & "\" & objItem.Subject
End If
Case "NoteItem"
strSaveName = objItem.Subject
Case "TaskItem"
strSaveName = objItem.Subject
Case "ContactItem"
strSaveName = objItem.FileAs
Case Else
strSaveName = ""
End Select
Err.Clear
objItem.SaveAs strFolderPath & "\" & CleanString(strSaveName) & ".txt", 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

Private Sub WriteToLog(strMessage As String)
intErrors = True
Open strLogFile For Append As #1
Write #1, strMessage
Close #1
End Sub