Option Explicit Sub BackUpEmailInPST() Dim olNS As Outlook.NameSpace Dim olBackup As Outlook.Folder Dim bFound As Boolean Dim strPath As String Dim strDisplayName As String strDisplayName = "Backup " & Format(Date, "yyyymmdd") strPath = "C:\Path\" & strDisplayName & ".pst" Set olNS = GetNamespace("MAPI") olNS.AddStore strPath Set olBackup = olNS.folders.GetLast olBackup.Name = strDisplayName RunBackup olNS, olBackup olNS.RemoveStore olBackup lbl_Exit: Set olNS = Nothing Set olBackup = Nothing Exit Sub End Sub Sub RunBackup(olNS As Outlook.NameSpace, olBackup As Outlook.Folder) Dim oFrm As New frmSelectAccount Dim strAcc As String Dim olStore As Store Dim olFolder As Folder Dim i As Long With oFrm .BackColor = RGB(191, 219, 255) .Height = 190 .Width = 240 .Caption = "Backup E-Mail" With .CommandButton1 .Caption = "Next" .Height = 24 .Width = 72 .Top = 126 .Left = 132 End With With .CommandButton2 .Caption = "Quit" .Height = 24 .Width = 72 .Top = 126 .Left = 24 End With With .ListBox1 .Height = 72 .Width = 180 .Left = 24 .Top = 42 For Each olStore In olNS.Stores If Not olStore.DisplayName = olBackup Then .AddItem olStore End If Next olStore End With With .Label1 .BackColor = RGB(191, 219, 255) .Height = 24 .Left = 24 .Width = 174 .Top = 6 .Font.Size = 10 .Caption = "Select e-mail store to backup" .TextAlign = fmTextAlignCenter End With .Show If .Tag = 0 Then GoTo lbl_Exit With oFrm.ListBox1 For i = 0 To .ListCount - 1 If .Selected(i) Then strAcc = .List(i) Exit For End If Next i End With Set olFolder = olNS.Stores(strAcc).GetDefaultFolder(olFolderInbox) olFolder.CopyTo olBackup DoEvents Set olFolder = olNS.Stores(strAcc).GetDefaultFolder(olFolderSentMail) olFolder.CopyTo olBackup End With lbl_Exit: Unload oFrm Set olStore = Nothing Set olFolder = Nothing Exit Sub End Sub