Hornblower409
New Member
- Outlook version
- Outlook 2010 32 bit
- Email Account
- IMAP
After reading the Slipstick article How to backup and save your Outlook VBA macros (and after losing a day's work because of a stupid mistake) I wrote an expanded version of wolfgang's macro from the article.
You can use it to automatically backup the VbaProject.OTM file at Application_Startup, Application_Quit, or manually with a Ribbon button. It can keep as many previous versions of the file as you want, so you can go back and look at your old code (this has saved my ass more than once.)
The modifications required (directory paths, number of versions to keep, etc.) are pretty obvious. You will need a Reference to the "Microsoft Scripting Runtime" (scrrun.dll) in your VBE Tools -> References to resolve the Scripting. names.
You can use it to automatically backup the VbaProject.OTM file at Application_Startup, Application_Quit, or manually with a Ribbon button. It can keep as many previous versions of the file as you want, so you can go back and look at your old code (this has saved my ass more than once.)
The modifications required (directory paths, number of versions to keep, etc.) are pretty obvious. You will need a Reference to the "Microsoft Scripting Runtime" (scrrun.dll) in your VBE Tools -> References to resolve the Scripting. names.
Code:
' Make a backup of the VbaProject.OTM file
'
' Called by App Startup and Shutdown or from a Ribbon Button
'
Public Sub File_BackupVbaProject()
Const ThisProc = "File_BackupVbaProject"
Const Source = "C:\Users\AGlassman\AppData\Roaming\Microsoft\Outlook\VbaProject.OTM"
Const DestPath = "C:\Data\Backups\Outlook\VbaProject\"
Dim FSO As Scripting.FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim Destination As String
Destination = DestPath & Format(Now, "yyyy-mm-dd") & "_" & Format(Now, "hh-mm-ss") & "-" & Right(Format(Timer, "0.00"), 2) & "_VbaProject.OTM"
FSO.CopyFile Source, Destination
If Not Files_DeleteOlder(DestPath, 128) Then Exit Sub
End Sub
' Delete older files in a folder based on DateCreated (NOT DateLastModified)
'
' Called by File_BackupVbaProject
'
' SPOS - Because VbaProject.OTM does not change it's DateLastModified or size on a reliable basis
' we have to look for older files based on the DateCreated (when I made the copy).
'
' See: https://stackoverflow.com/questions/24816147/outlook-vbaproject-otm-timestamp-is-not-updated-upon-changing
'
Public Function Files_DeleteOlder(ByVal FolderPath As String, ByVal NumberToKeep As Long) As Boolean
Const ThisProc = "Files_DeleteOlder"
Dim FSO As Scripting.FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
Files_DeleteOlder = False
If Not FSO.FolderExists(FolderPath) Then
MsgBox ("Folder '" & FolderPath & "' does not exist.")
Exit Function
End If
Dim oFolder As Scripting.Folder
Set oFolder = FSO.GetFolder(FolderPath)
Dim oFiles As Scripting.Files
Set oFiles = oFolder.Files
Do While oFiles.Count > NumberToKeep
' Get the DT Created of the first file in the Collection
'
Dim oOldest As Scripting.File
' SPOS - You can't get a member of the Files collection by index number.
'
' https://stackoverflow.com/questions/848851/asp-filesystemobject-collection-cannot-be-accessed-by-index
'
' "In general, collections can be accessed via index numbering, but the Files Collection is not a normal collection.
' It does have an item property, but it appears that the key that it uses is filename"
'
' Set oOldest = oFiles.Item(1) --> BOOM
'
' So we do a For Each, get the first file, and then immediatley exit the For.
'
Dim oFile As Scripting.File
For Each oFile In oFiles
Set oOldest = oFile
Exit For
Next oFile
' Find the oldest file in the collection and Delete it
'
For Each oFile In oFiles
If oFile.DateCreated < oOldest.DateCreated Then
Set oOldest = oFile
End If
Next oFile
FSO.DeleteFile oOldest.Path
Loop
Files_DeleteOlder = True
End Function
