Solved

Auto Export Calendar Based on Date

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

Want Experts Exchange at your fingertips?

With Experts Exchange’s latest app release, you can now experience our most recent features, updates, and the same community interface while on-the-go. Download our latest app release at the Android or Apple stores today!

Question has a verified solution.

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

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…
In this article I discuss my selections of the Top Four free Outlook OST File Viewers available. Open, view and read even damaged OST files by using these tools. They all provide a clear preview of all data such as emails, notes, tasks, calendars, 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…
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…

635 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