Auto Creation of Folders in .pst File

[JValenti]

Hello All,

So I feel like this should be relatively, easy but really have been struggling on the syntax. I currently have a functioning Excel macro to create a folder in my Outlook Inbox, but what I really need to do is create it in my .pst file folder structure since our Outlook storage is insufficient to just use the normal Outlook email inboxes for storage needs.

My .pst file is named Local Email and I would specifically want to add to the Sub Folder Local Email/RFQs/ZZZ - Non RFQ Customers

The file location fopr the .pst file is C:\Local Email File

I know my issue centers around the GetDefaultFolder(olFolderInbox) part but I cannot figure out how to change to the .pst

Also, I would highly prefer to keep this within Excel so it is non user specific and I do not need to modify others Outlook code.

Sub CreateCustomerEmailFolder()

'Purpose - Creates folder in Email Folder for Customer Name

Application.ScreenUpdating = False

If ActiveCell.Column <> 2 Then
MsgBox ("Starting Column must be B, macro aborted!!")
Exit Sub
End If

If Selection.Value = "" Then
Exit Sub
End If

Const olFolderInbox As Long = 6
Dim OutlApp As Object
Dim a(), x
Dim IsCreated As Boolean

' Use already open Outlook application if possible
'On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If

CustName = Selection.Value

With OutlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
FoldName = CustName
.Folders.Add FoldName
End With


If IsCreated Then OutlApp.Quit
Set OutlApp = Nothing

End Sub

 

[shknbk2]

I know my issue centers around the GetDefaultFolder(olFolderInbox)

This is the issue. The PST folder is not a default folder. Therefore, the code needs to go through each folder to find which one it is. I wrote the code so that it goes to the RFQs subfolder and then to its subfolder ZZZ(etc) based on my understanding of your explanation. If the folder tree isn't right, you can change it to be what it needs to.

Also, I did not include further error checking to make sure that the 2 subfolders were actually there. You might need to add some error checking if you need to.

Sub CreateCustomerEmailFolder()
    'Purpose - Creates folder in Email Folder for Customer Name
    Application.ScreenUpdating = False
    If ActiveCell.Column <> 2 Then
        MsgBox ("Starting Column must be B, macro aborted!!")
        Exit Sub
    End If
    
    If Selection.Value = "" Then
        Exit Sub
    End If
    
    Dim OutlApp As Object, fldr As Object
    Dim a(), x
    Dim IsCreated As Boolean
    Dim pstFolder As String, subFldr1 As String, subFldr2 As String
    
    [COLOR=#ff0000]pstFolder [/COLOR]= "Local Email"
    [COLOR=#ff0000]subFldr1 [/COLOR]= "RFQs"
    [COLOR=#ff0000]subFldr2 [/COLOR]= "ZZZ - Non RFQ Customers"
    
    ' Use already open Outlook application if possible
    'On Error Resume Next
    Set OutlApp = GetObject(, "Outlook.Application")
    If Err Then
        Set OutlApp = CreateObject("Outlook.Application")
        IsCreated = True
    End If
    
    CustName = Selection.Value
    
    With OutlApp.GetNamespace("MAPI")
        For Each fldr In .Folders
            If InStr(1, fldr.Name, pstFolder) > 0 Then
                Exit For
            End If
        Next
        If Not fldr Is Nothing Then
            Set fldr = fldr.Folders(subFldr1)
            Set fldr = fldr.Folders(subFldr2)
            FoldName = CustName
            fldr.Folders.Add FoldName
        Else
            MsgBox "The PST file must be open first."
        End If
    End With
    
    If IsCreated Then OutlApp.Quit
    Set OutlApp = Nothing
End Sub

 

[John_w]

So I feel like this should be relatively, easy but really have been struggling on the syntax. I currently have a functioning Excel macro to create a folder in my Outlook Inbox, but what I really need to do is create it in my .pst file folder structure since our Outlook storage is insufficient to just use the normal Outlook email inboxes for storage needs.

My .pst file is named Local Email and I would specifically want to add to the Sub Folder Local Email/RFQs/ZZZ - Non RFQ Customers

The file location fopr the .pst file is C:\Local Email File

You have to add the .pst file as a Store to Outlook (temporarily) and then you can add the new folder to the Store.

Try this macro:

Public Sub Add_Folder_To_pst_File()

    Dim outApp As Object
    Dim outNameSpace As Object
    Dim outStore As Object
    Dim outFolder As Object
    Dim outNextFolder As Object
    Dim pstFilePath As String
    Dim newFolderPath As String
    Dim parts As Variant, i As Long
    Dim storeIds As String, storeAlreadyOpen As Boolean
    
    'Add a new folder to an Outlook .pst file
    
    pstFilePath = "C:\Local Email File\Local Email.pst"
    newFolderPath = "RFQs\ZZZ - Non RFQ Customers"

    'Use already open Outlook application if possible
    
    On Error Resume Next
    Set outApp = GetObject(, "Outlook.Application")
    If Err Then
        Set outApp = CreateObject("Outlook.Application")
    End If
    Err.Clear
    On Error GoTo 0
    
    Set outNameSpace = outApp.GetNamespace("MAPI")
    
    'See if the Store (.pst file) is already open in Outlook
        
    storeAlreadyOpen = True
    Set outStore = Nothing
    i = 1
    While i <= outNameSpace.Stores.Count And outStore Is Nothing
        If StrComp(outNameSpace.Stores.Item(i).FilePath, pstFilePath, vbTextCompare) = 0 Then Set outStore = outNameSpace.Stores.Item(i)
        i = i + 1
    Wend
    
    If outStore Is Nothing Then
    
        'The Store is not open in Outlook, so add it
        
        storeAlreadyOpen = False
        
        'Get Store ids of existing Stores
        
        storeIds = ","
        For i = 1 To outNameSpace.Stores.Count
            storeIds = storeIds & outNameSpace.Stores.Item(i).StoreID & ","
        Next
        
        'Add the .pst file as a new Store
        
        outNameSpace.AddStore pstFilePath
    
        'Find the Store that was just added
        
        Set outStore = Nothing
        i = 1
        While i <= outNameSpace.Stores.Count And outStore Is Nothing
            If InStr(storeIds, "," & outNameSpace.Stores.Item(i).StoreID & ",") = 0 Then Set outStore = outNameSpace.Stores.Item(i)
            i = i + 1
        Wend
    
    End If
            
    'Add the new folder path to the Store, creating any intermediate folders which don't exist
    
    Set outFolder = outStore.GetRootFolder
    parts = Split(newFolderPath, "\")
    For i = 0 To UBound(parts)
        Set outNextFolder = Nothing
        On Error Resume Next
        Set outNextFolder = outFolder.Folders(parts(i))
        On Error GoTo 0
        If outNextFolder Is Nothing Then
            Set outFolder = outFolder.Folders.Add(parts(i))
        Else
            Set outFolder = outNextFolder
        End If
    Next
    
    'Remove the Store if it was added
    
    If Not storeAlreadyOpen Then outNameSpace.RemoveStore outStore.GetRootFolder
    
End Sub

 

[JValenti]

John, that worked right away with no manipulation to code at al, thank you so much for your help