Auto Export Calendar Based on Date

Hi experts.  I am trying to write a script that will automatically backup my calendar items everytime I close Outlook.  The code below does that - thanks to all experts so far.  I now would like to backup only those appointments that are a week old and two weeks ahead.  I have found the following but am now totally stuck.

    datStart = Date - 7 & " 12:01:00 AM"
    datEnd = Date + 14 & " 11:59:00 PM"

Sub BackupCalendarToPSTFile()
    Const BACKUPPATH = "C:\Outlook Calendar Backups\"
    Dim User As String, _
        UserCalendarBackupPath As String
    Dim strBackupFileName As String, _
        strOldBackupFileName As String, _
        objFSO As Object, _
        olkApp As Outlook.Application, _
        olkCalendar As Outlook.MAPIFolder, _
        olkCalendarCopy As Outlook.MAPIFolder, _
        olkBackup As Outlook.MAPIFolder
    
    Set objShell = CreateObject("WScript.Shell")
    User = objShell.ExpandEnvironmentStrings("%USERNAME%")
    UserCalendarBackupPath = BACKUPPATH & User & "\"
    
    strOldBackupFileName = "OldCalendar" & ".pst"
    strBackupFileName = "Calendar" & ".pst"
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If objFSO.FileExists(UserCalendarBackupPath & strOldBackupFileName) Then
        objFSO.DeleteFile (UserCalendarBackupPath & strOldBackupFileName)
    End If
    
    If objFSO.FileExists(UserCalendarBackupPath & strBackupFileName) Then
        objFSO.MoveFile (UserCalendarBackupPath & strBackupFileName), (UserCalendarBackupPath & strOldBackupFileName)
    End If
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set olkApp = CreateObject("Outlook.Application")
    olkApp.Session.AddStore UserCalendarBackupPath & strBackupFileName
    Set olkBackup = OpenMAPIFolder("\Personal Folders")
    olkBackup.Name = strBackupFileName
    olkApp.Session.RemoveStore olkBackup
    olkApp.Session.AddStore UserCalendarBackupPath & strBackupFileName
    Set olkBackup = OpenMAPIFolder("\" & strBackupFileName)
    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar)          'Use to capture Default Calendar
    ' Set olkCalendar = OpenMAPIFolder("\Mailbox - TSClark\Calendar")   'Use to capture Shared calender
    Set olkCalendarCopy = olkCalendar.CopyTo(olkBackup)
    olkCalendarCopy.Name = "Calendar"
    olkApp.Session.RemoveStore olkBackup
    'olkCalendarCopy.Display        ' Displays newly copied calendar if desired.
    
    MsgBox "Backup complete."
    
    Set objFSO = Nothing
    Set olApp = Nothing
    Set olkBackup = Nothing
    Set olkCalendar = Nothing
    Set olkCalendarCopy = Nothing
End Sub
 
Function OpenMAPIFolder(szPath)
    Dim app, ns, flr, szDir, I
    Set flr = Nothing
    Set app = CreateObject("Outlook.Application")
    If Left(szPath, Len("\")) = "\" Then
        szPath = Mid(szPath, Len("\") + 1)
    Else
        Set flr = app.ActiveExplorer.CurrentFolder
    End If
    While szPath <> ""
        I = InStr(szPath, "\")
        If I Then
            szDir = Left(szPath, I - 1)
            szPath = Mid(szPath, I + Len("\"))
        Else
            szDir = szPath
            szPath = ""
        End If
        If IsNothing(flr) Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
        Else
            Set flr = flr.Folders(szDir)
        End If
    Wend
    Set OpenMAPIFolder = flr
End Function
 
 
Function IsNothing(obj)
  If TypeName(obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End Function

Open in new window

DavidHardistyAsked:
Who is Participating?
 
David LeeCommented:
Hi, DavidHardisty.

That looks like something I wrote.  Try this revised version.  I haven't tested, but I think it'll work for what you want.  Replace the BackupCalendartoPSTFile you have now with the one below.  Keep the rest of the code as is.

Sub BackupCalendarToPSTFile()
    Const BACKUPPATH = "C:\Outlook Calendar Backups\"
    Dim User As String, _
        UserCalendarBackupPath As String
    Dim strBackupFileName As String, _
        strOldBackupFileName As String, _
        objFSO As Object, _
        olkCalendar As Outlook.MAPIFolder, _
        olkCalendarCopy As Outlook.MAPIFolder, _
        olkBackup As Outlook.MAPIFolder, _
        olkItems As Outlook.items, _
        olkItem As Object, _
        olkCopy As Object
    'Get the current user'
    Set objShell = CreateObject("WScript.Shell")
    User = objShell.ExpandEnvironmentStrings("%USERNAME%")
    UserCalendarBackupPath = BACKUPPATH & User & "\"
    'Assign values to variables'
    strOldBackupFileName = "OldCalendar" & ".pst"
    strBackupFileName = "Calendar" & ".pst"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'Delete the old backup file, if it exists'
    If objFSO.FileExists(UserCalendarBackupPath & strOldBackupFileName) Then
        objFSO.DeleteFile (UserCalendarBackupPath & strOldBackupFileName)
    End If
    'Rename the most recent backup file to be the old backup file'
    If objFSO.FileExists(UserCalendarBackupPath & strBackupFileName) Then
        objFSO.MoveFile (UserCalendarBackupPath & strBackupFileName), (UserCalendarBackupPath & strOldBackupFileName)
    End If
    'Add a new PST file in Outlook'
    Session.AddStore UserCalendarBackupPath & strBackupFileName
    'Get the newly created PST file'
    Set olkBackup = OpenMAPIFolder("\Personal Folders")
    'Change its name'
    olkBackup.Name = strBackupFileName
    'Remove it'
    Session.RemoveStore olkBackup
    'Re-open it'
    Session.AddStore UserCalendarBackupPath & strBackupFileName
    'Get a reference to it'
    Set olkBackup = OpenMAPIFolder("\" & strBackupFileName)
    'Create the calendar folder in the backup file'
    Set olkCalendarCopy = olkBackup.Folders.Add("Calendar", olFolderCalendar)
    'Get the calendar to be backed up'
    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar)
    'Select the items to be backed up'
    Set olkItems = olkCalendar.items.Restrict("[Start] > '" & Format(DateAdd("d", -7, Date) & " 0:01am", "ddddd h:nn AMPM") & "' AND [Start] < '" & Format(DateAdd("d", 14, Date) & " 11:59pm", "ddddd h:nn AMPM") & "'")
    'Copy the items to the backup file'
    For Each olkItem In olkItems
        Set olkCopy = olkItem.Copy
        olkCopy.Move olkCalendarCopy
    Next
    'Remove the backup file from Outlook'
    Session.RemoveStore olkBackup
    'olkCalendarCopy.Display        ' Displays newly copied calendar if desired.
    MsgBox "Backup complete."
    
    Set objFSO = Nothing
    Set olkCalendar = Nothing
    Set olkCalendarCopy = Nothing
    Set olkBackup = Nothing
    Set olkItems = Nothing
    Set olkItem = Nothing
    Set olkCopy = Nothing
End Sub

Open in new window

0
 
DavidHardistyAuthor Commented:
Hi BlueDevilFan
Thanks for the quick response.  Yes the guts of the code was yours, I just changed a few bits.  Thanks for the updated code it works great.  Interestingly, recursive appointments get backed up as well.  Not what I was expecting but a very useful extra.
David
0
 
David LeeCommented:
You're welcome.  Glad I could help.
0
 
syseng007Commented:
Hello to you both, hopefully this message will be routed to both of you. I'd like to use this code but when I try to execute it using the command line cscript, I get the compilation error. PLease further assist. Thank you.
0
 
syseng007Commented:
I get thsi error message: C:\Scripts\scriptfile.vbs(3, 14) Microsoft VBScript compilation
 error: Expected end of statement
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.