Solved

Auto Export Calendar Based on Date

Posted on 2008-09-30
5
826 Views
Last Modified: 2012-02-20
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

0
Comment
Question by:DavidHardisty
  • 2
  • 2
5 Comments
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 22607480
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
 

Author Comment

by:DavidHardisty
ID: 22612409
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
 
LVL 76

Expert Comment

by:David Lee
ID: 22612599
You're welcome.  Glad I could help.
0
 

Expert Comment

by:syseng007
ID: 37620320
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
 

Expert Comment

by:syseng007
ID: 37620351
I get thsi error message: C:\Scripts\scriptfile.vbs(3, 14) Microsoft VBScript compilation
 error: Expected end of statement
0

Featured Post

Free learning courses: Active Directory Deep Dive

Get a firm grasp on your IT environment when you learn Active Directory best practices with Veeam! Watch all, or choose any amount, of this three-part webinar series to improve your skills. From the basics to virtualization and backup, we got you covered.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Find out what you should include to make the best professional email signature for your organization.
How to resolve IMCEAEX NDRs in Exchange or Exchange Online related to invalid X500 addresses.
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …
Many of my clients call in with monstrous Gmail overloading issues with Outlook. A quick tip is to turn off the All Mail and Important folders from synching. Here is a quick video I made to show you how to turn off these and other folders in Gmail s…

830 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question