To Import icalendar (*.ics) to calendar using Macro

After long time i am posting this blog. Although this information is not totally about peoplesoft someway we can relate it.

Basically in peoplesoft we will send Appointment/Meeting request [which is in icalendar(.ics) format] as attachment in the mail. It won’t put an entry in Calendar unless u open the icalendar . it is a tough call for managers/executives who wont open the mail but they want an entry in Calendar.

So i thought of doing this thru Macro. It works perfectly. I am not an Macro expert but this is quiet interesting.
Thanks to Yogesh and Raja for giving Microsoft VBA tips :-)

'written by Vijay (psoftadmirer)

Public Sub Moveicstocalendar()
' This Outlook macro checks at the Outlook Inbox for messages
' with attached files (of *.ics type) and put a entry in the calendar.

On Error GoTo GetAttachments_err
'Declarations
Dim outApp As Outlook.Application
Dim InboxFolder As Outlook.MAPIFolder
Dim myCalendarFolder As Outlook.MAPIFolder
Dim ImportAppointmentitem As MeetingItem
Dim mynamespace As NameSpace
Dim Atmt As Attachment
Dim FileName As String
Dim Count As Integer

Set outApp = CreateObject("outlook.application")
Set mynamespace = outApp.GetNamespace("MAPI")
mynamespace.Logon
Set InboxFolder = outApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set myCalendarFolder = outApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
Set filesys = CreateObject("Scripting.FileSystemObject")

'Check whether folder exists if not create a new folder
FilePath = "C:\temp\"

If Not filesys.FolderExists(FilePath) Then
Set newfolder = filesys.CreateFolder(FilePath)
End If
i = 0
' Check each message for attachments

For Each Item In InboxFolder.Items
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "ics" Then
'Save the attachment in folder
FileName = FilePath & Atmt.FileName
Atmt.SaveAsFile FileName
'Import the ics from the folder and put an entry in Calendar
Set ImportAppointmentitem = mynamespace.OpenSharedItem(FileName)
ImportAppointmentitem.GetAssociatedAppointment (True)
i = i + 1

End If
Next Atmt
Next Item
' Clear memory
GetAttachments_exit:

Set Atmt = Nothing
Set Item = Nothing
Set ImportAppointmentitem = Nothing
Exit Sub
' Handle errors

GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit

End Sub