Copying calender entries via code

J

John

Hi

Is there a way to copy entries from a calendar in the public folders to the
standard calendar via code ? A code example would be highly appreciated. If
this code can run under a timer then that would be even great.

Many Thanks

Regards
 
E

Eric Legault [MVP - Outlook]

Try this macro, which will copy all of the selected items in the active
Calendar to the default Calendar:

Sub CopyAppointmentItem()
Dim objNS As Outlook.NameSpace
Dim objAppt As Outlook.AppointmentItem
Dim objCopiedAppt As Outlook.AppointmentItem

If ActiveExplorer.Selection.Count = 0 Then Exit Sub

Set objNS = Application.GetNamespace("MAPI")
For Each objAppt In ActiveExplorer.Selection
Set objCopiedAppt = objAppt.Copy
objCopiedAppt.Move objNS.GetDefaultFolder(olFolderCalendar)
Next

Set objAppt = Nothing
Set objCopiedAppt = Nothing
Set objNS = Nothing
End Sub
 
J

John

Thanks for that. Any way to use "my calendar" under the public folders as
the source instead of the current calendar?

Thanks

Regards
 
E

Eric Legault [MVP - Outlook]

You can obtain the handle to a folder (other than the active one using
ActiveExplorer.CurrentFolder) by using the NameSpace.GetFolderFromID method
if you know the unique ID of the folder in question.

Otherwise, you can pass the folder path (\\Public Folders\All Public
Folders\My Calendar) as an argument to the function below to obtain a
MAPIFolder object to use in the macro I gave you:

Function OpenMAPIFolder(ByVal strPath) As Outlook.MAPIFolder
Dim objFldr As MAPIFolder
Dim strDir As String
Dim strName As String
Dim i As Integer
On Error Resume Next
If Left(strPath, Len("\")) = "\" Then
strPath = Mid(strPath, Len("\") + 1)
Else
Set objFldr = m_olApp.ActiveExplorer.CurrentFolder
End If
While strPath <> ""
i = InStr(strPath, "\")
If i Then
strDir = Left(strPath, i - 1)
strPath = Mid(strPath, i + Len("\"))
Else
strDir = strPath
strPath = ""
End If
If objFldr Is Nothing Then
Set objFldr = m_olApp.GetNamespace("MAPI").Folders(strDir)
On Error GoTo 0
Else
Set objFldr = objFldr.Folders(strDir)
End If
Wend
Set OpenMAPIFolder = objFldr
End Function

--
Eric Legault - B.A, MCP, MCSD, Outlook MVP
Try Picture Attachments Wizard for Outlook! http://tinyurl.com/9bby8
Job: http://www.imaginets.com
Blog: http://blogs.officezealot.com/legault/
 
Top