Solved

Auto Export Calendar Based on Date

Posted on 2008-09-30
5
820 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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Suggested Solutions

What does UTC stand for?  “Coordinated Universal Time” – Think of this as the true time on Planet Earth that never changes with the exception of minor leap seconds here and there to account for the changes in the planet's rotation.   What does th…
Sometimes Outlook might have problems sending a message. There may be various causes- corrupted PST, AV scanner etc. The message, instead of going to the Sent Items folder, sits in the Outbox indefinitely. To remove it you can use a free tool cal…
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…
CodeTwo Sync for iCloud (http://www.codetwo.com/sync-for-icloud?sts=6554) automatically synchronizes your Outlook 2016, 2013, 2010 or 2007 folders with iCloud folders available via iCloud Control Panel. This lets you automatically sync them with…

910 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

Need Help in Real-Time?

Connect with top rated Experts

16 Experts available now in Live!

Get 1:1 Help Now