Outlook 365 Outlook folder export to PST archival tool - close, but need a nudge

[macdotcom]

Operating system::    Win 11 & 10
Outlook version:     Office 365
Email type or host:    IMAP

---

I've been working on a PST archival tool based on this thread (Export Folder to PST).

My background is strong in Excel VBA and VB, but Outlook VBA is new to me so I probably have a declaration wrong or using a wrong object type. I'm sure members here will probably spot it easily, but i'm lost on what I've missed.

Some background: We are an engineering firm. In my office, we have about 200 projects a year, some large (1000's of emails, go on for years) and some small (maybe 10, quick and done). In the last 10 years, I've hit the limit 4 times on size of my account. In the past, I manually exported stored project emails to PSTs to save on the network server in the projects folder. I have to save them, in case there's an issue down the line. But when I need to manually archive 50 folders once a year, typing each one and making 10 clicks to use the built in export tool, it's a royal PITA.

So when I found the thread above, I was excited to get something going -- and it did for a while. And I started this little side project, trying to make it universal so I can share with others in my company, who may not be so Outlook/VBA savvy. I had it working at one point, but now it's not. The problem is that when I get to the indicated section below, I am getting the old "Object or With Variable ..." error and I am blind to see what I'm messed up because this new Outlook object model is a little alien to me.

Finally, the one thing that has driven me nuts for years with PST archival. The Outlook file lock, even after the PST is closed. Is there a way around that?

Help appreciated to push me in the right direction.

Option Explicit

Sub ArchiveEmailtoPST()
'Outlook email archival tool - moves all contents of a folder in Outlook
' to an external PST file, without encryption or passwords
' you can move this PST file afterwards to a project folder for long
' term storage

Dim olNS As Outlook.NameSpace
Dim olPickedFld As Outlook.Folder
Dim olPickedItem, olPSTFile As Object
Dim strPath, strFileName, strUserInitials As String
Dim N, NumItems As Long

Set olNS = GetNamespace("MAPI")

strUserInitials = GetInitials
If Len(strUserInitials) = 0 Then
MsgBox "Please set your user initials. Go to 'File' | 'Options' | 'General'"
GoTo CleanExit 'Don't know who the user is
End If

On Error Resume Next
Set olPickedFld = olNS.PickFolder
strFileName = olPickedFld.Name
If TypeName(olPickedFld) = "Nothing" Then GoTo CleanExit 'Command was cancelled

NumItems = olPickedFld.Items.Count

On Error GoTo 0 'Disable error handling

If IsDefaultFolder(olPickedFld) Then 'Test for a Outlook Default folder being picked
MsgBox "You selected '" & olPickedFld & "' ... archival not allowed."
GoTo CleanExit
End If

strPath = AddTrailSlash(SelectFolder(GetDesktop)) 'Default file location but user can pick

'Develop the File pathname for export using users initials and today's date
strFileName = strFileName & "_" & strUserInitials & "_" & Format(Date, "yyyymmdd") & ".pst"
strPath = strPath & strFileName

'Creates a PST file at the path (strPath).
olNS.AddStore strPath
Set olPSTFile = olNS.Folders.GetLast
olPSTFile.Name = strFileName

'Moves across all the items in the selected folder to the PST
For N = NumItems To 1 Step -1
Set olPickedItem = olPickedFld.Items(N) '********************************************************************** I GET ERROR HERE
olPickedItem.Move olPSTFile
Next

'Closes the PST file - you will need to restart Outlook
' before you can move this file to its final location
olNS.RemoveStore olPSTFile 'Is there a workaround to have Outlook release the lock on the PST so it can be moved without closing/restarting Outlook?

'Deletes the old email folder in Outlook - it should be already empty, so no concern.
If olPickedFld.Items.Count = 0 Then olPickedFld.Delete

CleanExit:
Set olNS = Nothing
Set olPickedFld = Nothing
Set olPSTFile = Nothing
Set olPickedItem = Nothing

End Sub

Function IsDefaultFolder(fld As MAPIFolder) As Boolean
' test if selected folder in an Outlook internal default folder
' trying to rename a default folder will produce an error

Dim strTestName, strSaveName As String
strSaveName = fld.Name
strTestName = "DeleteTest_" & fld.Name

On Error GoTo Errorhandler 'error trap
fld.Name = strTestName 'try to rename the folder
On Error GoTo 0 ' diable error handling

fld.Name = strSaveName 'rename it back to original
IsDefaultFolder = False ' it's not a default folder
GoTo CleanExit

Errorhandler:
'an error occurred renaming, it's probably becuase of a default folder selected.
IsDefaultFolder = True 'assume it's a default folder

CleanExit:
Set fld = Nothing
End Function

Function RegKeyRead(i_RegKey As String) As String
'this function reads registry key entries
Dim myWS As Object
On Error Resume Next
Set myWS = CreateObject("WScript.Shell")
RegKeyRead = myWS.RegRead(i_RegKey)
End Function

Function GetInitials() As String
'this function reads the user initials from MS Office in registry keys
GetInitials = RegKeyRead("HKEY_CURRENT_USER\Software\Microsoft\Office\Common\UserInfo\UserInitials")
End Function

Function GetDesktop() As String
'returns the path to the User's Desktop folder
GetDesktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
End Function

Function SelectFolder(strStartPath As String) As String
'PURPOSE: Have User Select a Folder Path and Store it to a variable
'based on ~~~ TheSpreadsheetGuru.com/the-code-vault

Dim FldrPicker As FileDialog
Dim strLastChar As String
Dim xlApp As Object

'Remove the Trail \ if it's there
strStartPath = RemTrailSlash(strStartPath)

Set xlApp = CreateObject("Excel.Application") 'Outlook doesn't have dialog, so we'll use Excel's
xlApp.Visible = False

Dim fd As Office.FileDialog
Set fd = xlApp.Application.FileDialog(msoFileDialogFilePicker)

'Have User Select Folder to Save to with Dialog Box
' for help, see: VBA File Dialogs
Set FldrPicker = xlApp.Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.ButtonName = "Select Folder"
.InitialFileName = strStartPath
.Filters.Clear
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
.Title = "Select A Target Folder"
If .Show <> -1 Then 'Check if user clicked cancel button
SelectFolder = strStartPath
Else
SelectFolder = .SelectedItems(1) 'Default will put it on the Desktop
End If
End With

xlApp.Quit
Set xlApp = Nothing
Set FldrPicker = Nothing

End Function

Function AddTrailSlash(strPath As String) As String
' adds Trailing backslash on a path string
If Right$(strPath, 1) = "\" Then
AddTrailSlash = strPath
Else
AddTrailSlash = strPath & "\"
End If
End Function

Function RemTrailSlash(strPath As String) As String
' removes Trailing backslash on a path string
If Right$(strPath, 1) = "\" Then
RemTrailSlash = strPath = Left$(strPath, Len(strPath) - 1)
Else
RemTrailSlash = strPath
End If
End Function

 

[Diane Poremsky]

Is the pst file open in the profile? That error seems to say it is not.


>>
Finally, the one thing that has driven me nuts for years with PST archival. The Outlook file lock, even after the PST is closed. Is there a way around that?
>>
It should be locked if open in Outlook - no way to avoid it, but if the folder is not used for 10 minutes or so, it might unlock. Otherwise, close the pst - that should be locked after 10 minutes or until you close outlook.

 

[macdotcom]

Is the pst file open in the profile? That error seems to say it is not.


>>
Finally, the one thing that has driven me nuts for years with PST archival. The Outlook file lock, even after the PST is closed. Is there a way around that?
>>
It should be locked if open in Outlook - no way to avoid it, but if the folder is not used for 10 minutes or so, it might unlock. Otherwise, close the pst - that should be locked after 10 minutes or until you close outlook.

It is created and opened in the block just above the step where it generates the RTE.

I'm feeling like I don't have the objects dim'd correctly.