More Outlook Resource Sites

Microsoft Developer Network (MSDN)

FAQs and other general resources

share code 23-Apr-2019 02:57

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: Export Outlook Folders to File Folders
Description: This VB application will export selected Outlook folders to file system as MSG files. The intent is to allow quick reference when burned to CD due to Outlook not opening 'Read Only' PST files.
Date: 25-Feb-2005  13:25
Code level: beginner
Code area: Basic Outlook
Posted by: Steven Harvey
This message is displayed as VB.NET
' Title: PST2MSG
' Description: 
' This VB application will export selected 
' Outlook folders to file system as MSG 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 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
        '****** 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
        intUserAbort = 0
        ProcessFolder objFolder, strDestination
        'Unload frmProcessing
        If intUserAbort = 0 Then
            MsgBox "Export Complete!" & vbCrLf & "Export log file location:" & vbCrLf & strLogFile
            MsgBox "Processing cancelled." & vbCrLf & "Export log file location:" & vbCrLf & strLogFile
        End If
      End If
      MsgBox "Destination folder selection cancelled!"
    End If
    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:", "")
    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
    frmProcessing.Label2.Caption = "Processing " & StartFolder
    MkDir strPath
    ' process all the items in this folder
    For Each objItem In StartFolder.Items
      SaveAsMsg objItem, strPath
      Set objItem = Nothing
    ' 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)
    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, "´", "'")
    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
        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

    If Not objItem Is Nothing Then
      Select Case TypeName(objItem)
        Case "AppointmentItem"
          strSaveName = Format(objItem.Start, "mm-dd-yyyy") & " " & IIf(Len(strFolderPath & objItem.Subject) > 255, Left(objItem.Subject, 255 - Len(strFolderPath)), objItem.Subject) & ".msg"
        Case "MailItem"
          strSaveName = Format(objItem.ReceivedTime, "mm-dd-yyyy") & " " & IIf(Len(strFolderPath & objItem.Subject) > 255, Left(objItem.Subject, 255 - Len(strFolderPath)), objItem.Subject) & ".msg"
          If Err Then
              WriteToLog "Error #" & Err.Number & ": " & Err.Description & " Unable to process message '" & strFolderPath & "\" & objItem.Subject & "'."
              strSaveName = strFolderPath & "\" & objItem.Subject & ".msg"
          End If
        Case "NoteItem"
          strSaveName = objItem.Subject & ".msg"
        Case "TaskItem"
          strSaveName = objItem.Subject & ".msg"
        Case "ContactItem"
          strSaveName = objItem.FileAs & ".msg"
        Case Else
          strSaveName = ""
      End Select
        objItem.SaveAs strFolderPath & "\" & CleanString(strSaveName), olMSG
        If Err Then
            WriteToLog "Error #" & Err.Number & ": " & Err.Description & " Unable to process message '" & strFolderPath & "\" & objItem.Subject & "'."
          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
All 82comments
Page [ 1 2 3 4 5 6 7 8 9 Next >>  
  25-Feb-2005  21:27   
The project needs to reference the Outlook Object library.
  25-Feb-2005  21:34   
This has been tested with Outlook 2000 and 2002.
It may or may not work in 2003.
This application will trigger security prompt.
  28-Feb-2005  08:21   
76 downloads and no comments? I was hoping for some feedback to fine tune my abilities. Ahh well, enjoy!
  28-Feb-2005  21:56   
It should work in Outlook 2003 -- and without security prompts. Lots of nice pieces here for someone wanting to work with the Win API folder dialog, etc.
  03-Mar-2005  10:00   
Some reasons that an export will fail are:
1) Encrypted message and client doesnt have proper certificate.
2) Too long of filename/path. I have tried to account for this but some people have very deep folder structures with long names.
3) The script will push system memory usage when huge PST files are fully exported. I have tried to account for this with 'blahblah = Nothing' statements in loops so keep them there!

I have assembled this from the information and code snippets I have found here on this website. Sue is my hero. I have purchased her book and would highly suggest you do too. It offers so much more and is very easy to understand. I will be a guru in no time! Please post your code if you feel it would benefit others.
  05-Mar-2005  12:47   
Hi there
I want to do some thing similer, But I would like to send the infos to an Access Table.
Could you tell me what is wrong with my codes
Using Following codes I am trying to Loop through an OutLook folder Let’s say
OutBox folder and Import Some of it’s data to Table of mine in Access Application;
Private Sub cmdExport_Click()
Dim olookApp As Outlook.Application
Dim olookMsg As Object
Dim olookSpace As Outlook.NameSpace
Dim olookFolder As Outlook.MAPIFolder
Set olookApp = CreateObject("Outlook.Application")
Set olookSpace = olookApp.GetNamespace("MAPI")
Set olookFolder = olookSpace.GetDefaultFolder(olFolderOutbox)
   Dim dbs As Database
   Dim rst As Recordset
   Dim strTitle As String
   Dim strFirstName As String
   Dim strMiddleName As String
   Dim strLastName As String
   Dim strJobTitle As String
   Dim strCompany As String
   Dim strBusinessPhone As String
   Dim strHomePhone As String
   Dim strHomeFax As String
   Dim strEMailAddress As String
   Dim strMessage As String
   Set dbs = CurrentDb
   Set rst = dbs![tblContacts].OpenRecordset(dbOpenTable, dbDenyRead)
 For Each olookMsg In olookFolder.Items
         [FirstName] = strFirstName
         [MiddleName] = strMiddleName
         [LastName] = strLastName
         [JobTitle] = strJobTitle
         [Company] = strCompany
         [BusinessPhone] = strBusinessPhone
         [HomePhone] = strHomePhone
         [HomeFax] = strHomeFax
         [Message] = strMessage
         [E-mailAddress] = strEMailAddress
End Sub

  06-Mar-2005  10:22   
Hello Sanan,

The below example is a basic start of an export to database macro. I only work with email in it but you will easily be able to figure out how to export other items. You may need better error checking in the database routines also. I didnt want to spend all day on this. This code will trigger security prompts. I have only tested in Outlook2k but it should work in the others with minimal or no modifications.

Place the below code in a new or current module.

[Start Code]
Sub ExportToDatabase()
'Main macro for this example
'Helper functions are ProcessFolder and SearchForFile
  Dim olApp As Outlook.Application
  Dim olNS As Outlook.NameSpace
  Dim objFolder As Outlook.MAPIFolder
  Set olApp = Application
  Set olNS = olApp.GetNamespace("MAPI")

  Set objFolder = olNS.PickFolder
  ProcessFolder objFolder, ""
End Sub

Sub ProcessFolder(CurrentFolder As Outlook.MAPIFolder, strParentFolder As String)
  Dim i As Long
  Dim olNewFolder As Outlook.MAPIFolder
  Dim olTempItem As Object

  Set dbConn = CreateObject("ADODB.Connection")
  Set dbRS = CreateObject("ADODB.Recordset")
  'Change 'OutlookData' to the name of your databases DSN
  dbConn.Open "DSN=OutlookData;"

  'You will need to add your own error checking
  'I am keeping it simple for this example
  On Error Resume Next
  For i = CurrentFolder.Items.Count To 1 Step -1
    'Put different type items in different tables
    'I have only created an email table for this example
    Select Case CurrentFolder.Items(i).Class
      Case olMail
        'email is the name of the table to store emails in
        dbRS.Open "SELECT * FROM email", dbConn, 2, 3
        'Defined Fields in table 'email'
        'Folder = Text
        'Sender = Text
        'To = Text
        'Subject = Text
        'Body = Memo
        dbRS("Folder") = strParentFolder & "\" & CurrentFolder.Name
        dbRS("Sender") = CurrentFolder.Items(i).SenderName
        dbRS("To") = CurrentFolder.Items(i).To
        dbRS("Subject") = CurrentFolder.Items(i).Subject
        dbRS("Body") = CurrentFolder.Items(i).Body
      Case olAppointment
      Case olContact
      Case olNote
      Case olTask
    End Select

  For Each olNewFolder In CurrentFolder.Folders
    If olNewFolder.Name <> "Deleted Items" Then
      strParentFolder = strParentFolder & "\" & CurrentFolder.Name
      ProcessFolder olNewFolder, strParentFolder
    End If
End Sub

Function SearchForFile() As String
' Compliments of Greg Smith on the forums
   On Error Resume Next
    Dim strBFF
    Dim objSHL
    Set objSHL = CreateObject("Shell.Application")
    Dim objBFF
    Set objBFF = objSHL.BrowseForFolder(&H0, "OpenFile", &H4031, &H11)
    strBFF = objBFF.ParentFolder.ParseName(objBFF.Title).Path

    SearchForFile = strBFF
    Set objBFF = Nothing
    Set objSHL = Nothing
End Function
[End Code]
  06-Mar-2005  10:27   
The SearchForFile function is not neccessary due to DSN usage.
  19-Mar-2005  23:33   
Small glitch... (and I am NOT a programmer, just a computer user trying to extract messages from my outlook pst store.)

When I run the code I get a error 424, "Object Required" and the module halts. Debug identifies the issue is at the subroutine "processfolder",
line: frmProcessing.Label2.Caption = "Processing " & StartFolder

The code runs to completion if I delete the line above but I've obviously eliminated your nice processing message subroutine. Hope you can fix it.

The additional capability that I'd like to have is for the utility to export message attachments as separate files.

  20-Mar-2005  18:57   
Forgot to mention -- I'm using Office/Outlook 2003 under Windows XP Pro, and running your script in a module of Microsoft Visual Basic v6.3.

Larry Cereghino

Page [ 1 2 3 4 5 6 7 8 9 Next >>