Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

Auto Export Calendar Based on Date

Posted on 2008-09-30
5
Medium Priority
?
833 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 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

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

Question has a verified solution.

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

You need to know the location of the Office templates folder, so that when you create new templates, they are saved to that location, and thus are available for selection when creating new documents.  The steps to find the Templates folder path are …
There can be many situations demanding the conversion of Outlook OST files to PST format and as such, there is no shortage of automated tools to perform this conversion. However, what makes Stellar OST to PST converter stand above the rest? Let us e…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
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…

916 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