'This program is provided as is.
'  There are no claims made that it will work, not cause your pc problems, etc etc.
'
'  If this program causes your PC to explode, which in turn sets your house on fire,
'  killing your goldfish, you assume all responsibility for such and not me.
'  Use at your own risk!

Attribute VB_Name = "ExportCal"
Option Explicit

Global fileLocation As String
Global daysToExport As Integer
Global addressToEmail As String

Private Sub SetOptions()
'********************************************************************
'*  Created on 7/13/2009
'*  Created by LJ Earnest, http://simpleproductivityblog.com
'*  Purpose: set adjustable parameters
'*  Modification History
'*-------------------------------------------------------------------
'*  Date        Who     Description
'*  20080502    LJE       Creation
'********************************************************************

'default location if the full path is not given
'example: c:\documents and settings\testuser\my documents
fileLocation = "C:\mycal.ics"
    
'set default number of days to export
daysToExport = 90

addressToEmail = "putyouremailaddress@someplace.here"
End Sub

Public Sub ExportCalendarAndMail()
'********************************************************************
'*  Created on 7/13/2009
'*  Created by LJ Earnest, http://simpleproductivityblog.com
'*  Purpose: export and email calendar file
'*  Modification History
'*-------------------------------------------------------------------
'*  Date        Who     Description
'*  20090713    LJE       Creation
'********************************************************************

    Dim oNamespace As NameSpace
    Dim oFolder As Folder
    Dim oCalendarSharing As CalendarSharing
    
    SetOptions
    
    On Error GoTo ErrRoutine
            
    ' Get a reference to the Calendar default folder
    Set oNamespace = Application.GetNamespace("MAPI")
    Set oFolder = oNamespace.GetDefaultFolder(olFolderCalendar)
    
    ' Get a CalendarSharing object for the Calendar default folder.
    Set oCalendarSharing = oFolder.GetCalendarExporter
    
    ' Set the CalendarSharing object to export the contents of
    ' the entire Calendar folder, including attachments and
    ' private items, in full detail.
    With oCalendarSharing
        .CalendarDetail = olFullDetails
        .IncludeAttachments = False
        .IncludePrivateDetails = True
        .IncludeWholeCalendar = False
        .StartDate = Now()
        .EndDate = DateAdd("d", daysToExport, Now())
    End With
    
    ' Export calendar to an iCalendar calendar (.ics) file.
    oCalendarSharing.SaveAsICal fileLocation
    
    'mail the calendar
    Dim oEmail As Outlook.MailItem
    Set oEmail = CreateNewEmail
    oEmail.Attachments.Add fileLocation
    oEmail.To = addressToEmail
    oEmail.Body = "Calendar export on " & Now()
    oEmail.Subject = "Updated Outlook Calendar"
    oEmail.Send
    
EndRoutine:
    On Error GoTo 0
    Set oCalendarSharing = Nothing
    Set oFolder = Nothing
    Set oNamespace = Nothing
Exit Sub
 
ErrRoutine:
    MsgBox Err.Description, vbOKOnly, Err.Number & " - " & Err.Source
    GoTo EndRoutine
End Sub


Private Function CreateNewEmail() As Outlook.MailItem
'********************************************************************
'*  Created on 7/13/2009
'*  Created by LJ Earnest, http://simpleproductivityblog.com
'*
'*  Modification History
'*-------------------------------------------------------------------
'*  Date        Who     Description
'*  20080502    LJE       Creation
'********************************************************************

Dim oNamespace As Outlook.NameSpace
Dim oMapiFolder As Outlook.MAPIFolder
Dim oMailItem As Outlook.MailItem

Set oNamespace = Application.Session
If Not oNamespace Is Nothing Then
    oNamespace.Logon , , True, False
    
    Set oMapiFolder = oNamespace.GetDefaultFolder(olFolderOutbox)
    If Not oMapiFolder Is Nothing Then
        Set oMailItem = oMapiFolder.Items.Add(olMailItem)
    End If
End If
Set CreateNewEmail = oMailItem

End Function