Solved

Auto Export Calendar Based on Date

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

What Is Threat Intelligence?

Threat intelligence is often discussed, but rarely understood. Starting with a precise definition, along with clear business goals, is essential.

Join & Write a Comment

Get an idea of what you should include in an email disclaimer with these Top 5 email disclaimer tips.
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…
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
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…

744 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

13 Experts available now in Live!

Get 1:1 Help Now