Copy calender items

[Peekhof]

Hi there,
I am looking for a solution (read: code) where i can do the following.
When user A. is makin a appointment in his local Outlook diary and hits the save button it
will automaticaly show up a popup with 3 options.
Option 1 : copy this appointment to company shared diary (without details).
Option 2 : copy this appointment to other (preselected) diary
Option 3 : do nothing and quit this popup.
All users have full access to the other calenders so that's no problem.
goal is that users have there own appointments and shared ones within the company.
to avoid that collegue's cannot see there availabilty on that day.
Who can help me?
i have a little code that puts it in direction but it's based on a predifined message and not
the actual appointment that has been placed by the local user.



Sub CreateOtherUserAppointment()
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim objDummy As Outlook.MailItem
Dim objRecip As Outlook.Recipient
Dim objAppt As Outlook.AppointmentItem
Dim strMsg As String
Dim strName As String
On Error Resume Next

strName = "Webmaster"

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objDummy = objApp.CreateItem(olMailItem)
Set objRecip = objDummy.Recipients.Add(strName)
objRecip.Resolve
If objRecip.Resolved Then
On Error Resume Next
Set objFolder = _
objNS.GetSharedDefaultFolder(objRecip, _
olFolderCalendar)
If Not objFolder Is Nothing Then
Set objAppt = objFolder.Items.Add
If Not objAppt Is Nothing Then
With objAppt
.Subject = "Test Afspraak"
.Start = Date + 0
.AllDayEvent = True
.Save
End With
End If
End If
Else
MsgBox "Kan niet vinden : " & Chr(34) & strName & Chr(34), , _
"Gebruiker niet gevonden"
End If
Set objApp = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Set objDummy = Nothing
Set objRecip = Nothing
Set objAppt = Nothing
End Sub


Who can help me out?