asked on

Outlook macro to copy PST

Hi

Im running this macro in outlook 2007, but I want it to clone a selectable PST of my choice, not my defaultstore mailbox.

Can it be modifiable so that you can select a PST file to clone folder structure.

So that I get "select PST location and PST file after selecting new PST file name and location"

Thanks!

Dab

Dabosa

ASKER

Sub CopyFolderStructure()
Dim myNameSpace As Outlook.NameSpace
Dim RootFolder As Outlook.MAPIFolder
Dim tgtFolderString As String
Dim srcfolder As MAPIFolder
Dim tgtfolder As MAPIFolder
    
    Set myNameSpace = Application.GetNamespace("MAPI")
    tgtFolderString = InputBox("Enter the title for the new PST", "PST Structure Clone", "PST Copy")
    If Right(tgtFolderString, 4) <> ".pst" Then tgtFolderString = tgtFolderString & ".pst"
    myNameSpace.AddStore "C:\" & tgtFolderString
    Set srcfolder = getDefaultStore
    Set tgtfolder = myNameSpace.Folders.GetLast
    ProcessFolder srcfolder, tgtfolder.StoreID
'    MsgBox "Done"
End Sub
 
Private Sub ProcessFolder(FolderName As MAPIFolder, strtgtstoreid As String)
Dim SubFolder As Outlook.MAPIFolder
Dim Itm As Object
    nav2Folder FolderName, strtgtstoreid
    For Each SubFolder In FolderName.Folders
        ProcessFolder SubFolder, strtgtstoreid
    Next
End Sub
 
Function getDefaultStore() As MAPIFolder
Dim fldr As MAPIFolder
    
    For Each fldr In Application.GetNamespace("MAPI").Folders
        If Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).StoreID = fldr.StoreID Then Set getDefaultStore = fldr
    Next
End Function
 
Public Function nav2Folder(FolderName As MAPIFolder, tgtfolder As String) As Outlook.MAPIFolder
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olfldr As Outlook.Folders
Dim reqdFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    FolderName = Replace(Replace(FolderName, "/", "\"), "\\", "")
    If Right(FolderName, 1) = "\" Then FolderName = Left(FolderName, Len(FolderName) - 1)
    arrFolders() = Split(Replace(FolderName.folderPath, "\\", ""), "\")
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNS.GetFolderFromID(tgtfolder)
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.Folders
            Set reqdFolder = olfldr.item(arrFolders(nestCount))
            If reqdFolder <> olfldr.item(arrFolders(nestCount)) Then
                reqdFolder.Folders.Add (arrFolders(nestCount))
                Set olfldr = reqdFolder.Folders
                Set reqdFolder = olfldr.item(arrFolders(nestCount))
            End If
        Else
        End If
    Next
    Set nav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNS = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

Chris Bottomley

Hello Dabosa,

If you are using 2007 then the answer is yes and if earlier then i'm afraid the answer is no. If using 2007 then please let me know and i'll try and knock up the changes necessary.

Regards,

chris_bottomley

Chris Bottomley

Dabosa,

Ignore my last ... i'll post again shortly!

chris_bottomley

Dabosa

ASKER

Ok, Thanks Chris!

ASKER CERTIFIED SOLUTION

Chris Bottomley

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Dabosa

ASKER

Outstanding, exactly what I needed! Posting complete script for others to copy.

Thanks Chris!

Sub CopyFolderStructure()
Dim myNameSpace As Outlook.NameSpace
Dim RootFolder As Outlook.MAPIFolder
Dim tgtFolderString As String
Dim srcfolder As MAPIFolder
Dim tgtfolder As MAPIFolder
    
    Set myNameSpace = Application.GetNamespace("MAPI")
    tgtFolderString = InputBox("Enter the title for the new PST", "PST Structure Clone", "PST Copy")
    If Right(tgtFolderString, 4) <> ".pst" Then tgtFolderString = tgtFolderString & ".pst"
    myNameSpace.AddStore "C:\" & tgtFolderString
    Set srcfolder = GetPST
    Set tgtfolder = myNameSpace.Folders.GetLast
    ProcessFolder srcfolder, tgtfolder.StoreID
'    MsgBox "Done"
End Sub
 
Private Sub ProcessFolder(FolderName As MAPIFolder, strtgtstoreid As String)
Dim SubFolder As Outlook.MAPIFolder
Dim Itm As Object
    nav2Folder FolderName, strtgtstoreid
    For Each SubFolder In FolderName.Folders
        ProcessFolder SubFolder, strtgtstoreid
    Next
End Sub
 
Function GetPST() As MAPIFolder
Dim strPST As String
Dim intPST As Integer
Dim intSelection As Variant
Dim pst As Folder

    For Each pst In Application.Session.Folders
        intPST = intPST + 1
        strPST = strPST & intPST & ". " & pst.Name & vbCrLf
    Next
    intSelection = InputBox("Please select required PST" & vbCrLf & vbCrLf & strPST, "PST Selection", 1)
    Set GetPST = Application.Session.Folders(1)
    If IsNumeric(intSelection) Then
        If intSelection >= 1 And intSelection <= intPST Then
            Set GetPST = Application.Session.Folders(intSelection)
        End If
    End If

End Function
 
Public Function nav2Folder(FolderName As MAPIFolder, tgtfolder As String) As Outlook.MAPIFolder
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olfldr As Outlook.Folders
Dim reqdFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    FolderName = Replace(Replace(FolderName, "/", "\"), "\\", "")
    If Right(FolderName, 1) = "\" Then FolderName = Left(FolderName, Len(FolderName) - 1)
    arrFolders() = Split(Replace(FolderName.FolderPath, "\\", ""), "\")
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNS.GetFolderFromID(tgtfolder)
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.Folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                reqdFolder.Folders.Add (arrFolders(nestCount))
                Set olfldr = reqdFolder.Folders
                Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            End If
        Else
        End If
    Next
    Set nav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNS = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

Chris Bottomley

Glad to help ... and well done for a particularly broad minded approach by uploading the set of working code.

Chris