Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

Auto Export Calendar Based on Date

Posted on 2008-09-30
5
Medium Priority
?
831 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 2
  • 2
5 Comments
 
LVL 76

Accepted Solution

by:
David Lee earned 2000 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

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

When you have clients or friends from around the world, it becomes a challenge to arrange a meeting or effectively manage your time. This is where Outlook's capability to show 2 time zones in one calendar comes in handy.
Outlook for dependable use in a very small business   This article is about using the Outlook application (part of Microsoft Office) in a very small business, or for homeowners where dependability and reliability are critical requirements. This …
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…
This is my first video review of Microsoft Bookings, I will be doing a part two with a bit more information, but wanted to get this out to you folks.

722 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