Convert Outlook Vba to use Outlookex

[HighlanderSword]

Hello,

 

I have the code below that works great in outlook VBA Project, I want to convert this over to use outlookex

This basically goes thru the outlook folder grabs the parent folder name for each parent folder , then creates a new pst

and re-creates all of the Parent folder and the subfolders underneath.

 

I'm ok creating the pst using outlookex , after that is where i get lost, appreciate any guidance

 

expandcollapse popup

' Creates a new Outlook PST named after the windows username and current year
' Binds the new PST to Outlook and copies the directory structure to the new PST

' filename: make_new_pst.vbs

Const olFolderInbox = 6

'Grab the user name
Set wSHNetwork = CreateObject("WScript.Network")
strUser = WSHNetwork.UserName

'grab user profile
Set oShell = CreateObject("Wscript.Shell")
strUserProfile = oShell.ExpandEnvironmentStrings("%USERPROFILE%")

pstName = strUser & "_" & Year(now)
strPSTPath = strUserProfile & "\Local Settings\Application Data\Microsoft\Outlook\" & pstName & ".pst"

' win7/vista:
'strPSTPath = strUserProfile & "\AppData\Local\Microsoft\Outlook\" & pstName & ".pst"

'hook into MAPI and create pst
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
objNameSpace.AddStoreEx strPSTPath, 2

'Renames PST File To Unique Display Name 
Set pstrename = objNameSpace.Folders.GetLast
pstrename.name = pstName

'Set Namspace to Default Mailbox Inbox Folder 
Set objOldInbox = objNamespace.GetDefaultFolder(olFolderInbox)    
strOldFolderName = objOldInbox.Parent

'Sets Default to Mailbox Root vs Inbox. Must bind to inbox like above first Before Parent Below this is by design
Set objOldMailbox = objNamespace.Folders(strOldFolderName)    
     
'set collection for mailbox contents at root
Set colOldFolders = objOldMailbox.Folders

' set destination PST
Set destPst = objNameSpace.folders(pstName)

' loop through each folder in original PST   
For Each objFolder In colOldFolders

    ' only create 'else' folders
    select case objFolder.Name
        case "Calendar"
        case "Contacts"
        case "Deleted Items"
        case "Journal"
        case "Junk E-Mail"
        case "Notes"
        case "Outbox"
        case "RSS Feeds"
        case "Sent Items"
        case "Tasks"
        case else
            copyFolders objFolder, destPst
    end select
           
Next

'clean things up
Set objNameSpace = Nothing
Set objOutlook = Nothing


' creates all subfolders recursively
Sub copyFolders(pObjFolder, pDestPst)
    Set myNewFolder = pDestPst.Folders.Add(pObjFolder.Name)
    For Each SubFolder in pObjFolder.Folders
        copyFolders SubFolder, pDestPst.Folders(myNewFolder.Name)
    Next
End Sub

 

[water]

So you just want to create the folder structure in the destination PST without copying the content?

[HighlanderSword]

Yes !!!

[HighlanderSword]

Any Luck converting the code ?

[Juvigy]

I would say this is a lot faster and easier to convert:

 

Sub Archive_Outlook_eMails_To_Backup_PST_Folder()
    ' Declare Objects
    Dim SourceFolder As Outlook.MAPIFolder, DestFolder As Outlook.MAPIFolder
    Dim MailItem As Outlook.MailItem
    Dim SourceMailBoxName As String, DestMailBoxName As String
    Dim Source_Pst_Folder_Name As String, Dest_Pst_Folder_Name  As String
    Dim MailsCount As Double, NumberOfDays As Double

    'Set Number of days for aging check
    NumberOfDays = 1

    'Source Mailbox or PST name
    SourceMailBoxName = "YourEmailAccount@gmail.com"
    Source_Pst_Folder_Name = "SourcePSTFolder"
    Set SourceFolder = Outlook.Session.Folders(SourceMailBoxName).Folders(Source_Pst_Folder_Name)

    'Backup to this Mailbox or PST name
    DestMailBoxName = "Archive Folders"
    Dest_Pst_Folder_Name = "Inbox"
    Set DestFolder = Outlook.Session.Folders(DestMailBoxName).Folders(Dest_Pst_Folder_Name)

    MailsCount = SourceFolder.Items.Count
    While MailsCount > 0

        'Backup Mails Older than "Number of Days"
        Set MailItem = SourceFolder.Items.Item(MailsCount)
        If VBA.DateValue(VBA.Now) - VBA.DateValue(MailItem.ReceivedTime) >= NumberOfDays Then
            SourceFolder.Items.Item(MailsCount).Move DestFolder
        End If

        MailsCount = MailsCount - 1
    Wend

    MsgBox "Mailes in " & Source_Pst_Folder_Name & " are Processed"
End Sub

When you play with the numberofdays parameter is such a way that  no mails to be moved , it will only create the folder structure in the PST. At least this is how it works when you do it from the Outlook GUI, i wonder if it going to work via the converted vba code the same way.

[water]

3 hours ago, HighlanderSword said:

Any Luck converting the code ?

Unfortunately I didn't find the required spare time to translate the code
Hope I will be able to start working on it in the next few days .

[water]

@Juvigy
Does this VBA code work for subfolders as well?

[Earthshine]

https://www.msoutlook.info/question/copy-mailbox-folder-structure-to-new-pst

can you automate that?

Edited December 11, 2017 by Earthshine

[HighlanderSword]

Yes the code I posted does work on the subfolders as well.

[water]

I was addressing Juvigy

[HighlanderSword]

ok, thanks, key thing to note I'm looking for only true mail folders , not calendars , tasks etc....

 

Think you will have any time this week to convert the code

Edited December 11, 2017 by HighlanderSword

[water]

BTW:
For archiving purposes the OutlookEX UDF offers two functions: _OL_FolderArchiveGet and _OL_FolderArchiveSet.
This allows to let Outlook do the archiving automatically.

[Juvigy]

In Outlook when you do "archive" but choose a condition ">date that is the future" it will create the folder structure and dont move any mail to the PST.

@Water, does _OL_FolderArchiveGet and _OL_FolderArchiveSet  have the same behavior ?

Otherwise the above vba code i posted should be creating the folder structure ONLY if you select a future 'older than date' condition. I haven't been able to test it though!

[water]

I wasn't able to test those _OL_FolderArchive* functions as well.
It seems I only translated this functions from MS example scripts