Sync Outlook/Hotmail Calender into a local calender as a backup using VBA.

Problem:


Sync Outlook/Hot-mail Calender into a local calender as a backup using VBA.

Solution:

1.) Open your outlook window..


2.) Press Alt+F11 Key from Keyboard.


3) Past the code and save it.

Dim WithEvents newCal As Items

Private Sub Application_Startup()
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")
Set newCal = NS.GetDefaultFolder(olFolderCalendar).Items
Set NS = Nothing
End Sub

Private Sub newCal_ItemAdd(ByVal Item As Object)
Dim cAppt As AppointmentItem
Dim moveCal as AppointmentItem
On Error Resume Next
Set CalFolder = GetFolderPath("display name in folder list\Calendar\Test")

If Item.BusyStatus = olBusy Then

Set cAppt = Application.CreateItem(olAppointmentItem)

With cAppt
.Subject = "Copied: " & Item.Subject
.Start = Item.Start
.Duration = Item.Duration
.Location = Item.Location
.Body = Item.Body
.Save
End With

' set the category after it's moved to force EAS to sync changes
Set moveCal = cAppt.Move(CalFolder)
moveCal.Categories = "moved"
moveCal.Save

End If
End Sub


Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer

On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function

GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function

Note:If you are not sure about the VBA Write me an email for steps.