Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

Outlook macro to copy PST

Posted on 2010-01-04
7
Medium Priority
?
1,092 Views
Last Modified: 2012-05-08
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
0
Comment
Question by:Dabosa
  • 4
  • 3
7 Comments
 

Author Comment

by:Dabosa
ID: 26169672

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

0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 26169694
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
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 26169697
Dabosa,

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

chris_bottomley
0
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 

Author Comment

by:Dabosa
ID: 26169701
Ok, Thanks Chris!
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 2000 total points
ID: 26169814
Try using the new function GetPST in place of getDefaultStore i.e. in CopyFolderStructure replace:

    Set srcfolder = getDefaultStore
with
    Set srcfolder = GetPST

NOTE: The calling sub expects a valid input therefore defaults to the default if an invalid entry is made

Chris
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

Open in new window

0
 

Author Comment

by:Dabosa
ID: 26169858
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

0
 
LVL 59

Expert Comment

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

Chris
0

Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article will help to fix the below errors for MS Exchange Server 2013 I. Certificate error "name on the security certificate is invalid or does not match the name of the site" II. Out of Office not working III. Make Internal URLs and Externa…
The core idea of this article is to make you acquainted with the best way in which you can export Exchange mailbox to PST format.
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…
Whether it be Exchange Server Crash Issues, Dirty Shutdown Errors or Failed to mount error, Stellar Phoenix Mailbox Exchange Recovery has always got your back. With the help of its easy to understand user interface and 3 simple steps recovery proced…
Suggested Courses

810 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question