How To add Appointments on Exchange Server?

[essnrv]

Hi all,

I need to write an application, which has to add appointments for a specific user on Exchange server. How can I do this task ?

Thanks in advance

 

[paulbent]

The program has to run on a client PC with Outlook 97 or later. Can use the Outlook object model.

When the app automates Outlook it will be logged onto Exchange Server as the current user on the local PC, the target users will need to grant permissions to their calendar folders for the users who can create appointments.

The strategy is to create a recipient object for the target user, pass it to GetSharedDefaultFolder to return the calendar folder then create the appointment item. Here's an outline:

Set objOLApp = CreateObject("Outlook.Application")
Set objNS = objOLApp.GetNamespace("MAPI")
strUser = "Bloggs, Fred"
Set objRecip = objNS.CreateRecipient(strUser)
objRecip.Resolve
Set objFolder = objNS.GetSharedDefaultFolder( _
objRecip, olFolderCalendar)
Set objAppt = objFolder.Items.Add
With objAppt
 'Set the appointment properties here
 .Save
End With

Paul Bent
Northwind IT Systems

http://www.northwindit.co.uk

 

[essnrv]

Hi,

Thank you for your reply. But,I am getting following error 'does not recognize more than one user'. How can I fix this problem

 

[paulbent]

Which version of Outlook. What's the error number? Please post your code and indicate on which line the error occurs.

Paul Bent
Northwind IT Systems

http://www.northwindit.co.uk

 

[essnrv]

Hi paulbent,

Thank you for your responses.

Version: Microsoft Outlook 97

Set objOutlook = CreateObject("Outlook.Application&quot
Set ObjNameSpace = objOutlook.GetNamespace("MAPI&quot
Set objUser = ObjNameSpace.CreateRecipient(smUser)
Set objFolder = ObjNameSpace.GetSharedDefaultFolder(objUser, olFolderCalendar)
Set objItem = objFolder.Items

'Delete All previous appointments

For Each Item In objItem
If InStr(Item.Body, "BART&quot > 0 Then blnpDelete = True
If blnpDelete Then Item.Delete
Next

'Add New appointments
Set objAppItem = objOutlook.CreateItem(olAppointmentItem)
With objAppItem
.Start = CDate(spStartTime)
.End = CDate(spEndTime)
.Subject = UCase(spSubject)
.Body = UCase(spBody)
'.CreationTime = Now
.Save
End With

'Clear the memory
Set objAppItem = Nothing
Set objFolder = Nothing
Set objItem = Nothing
Set ObjNameSpace = Nothing
Set objUser = Nothing
Set objOutlook = Nothing
Set Item = Nothing


Thanks in advance

 

[paulbent]

OK but what's the error number and which line of code does it occur on?

The code is deleting appointments in a shared folder and creating an appointment in the user's own calendar folder. Is that what's intended?

Paul Bent
Northwind IT Systems

http://www.northwindit.co.uk

 

[essnrv]

An error saying that it does not recognize more than one user. I need to add the appointment to that particular user only.

Thank you,

 

[paulbent]

CreateItem will create an appointment item for the current user. See the code I posted originally which uses the Add method of the Items collection of the shared folder to create the appointment item in the shared folder.

Since you won't tell us which version of Outlook, the error number or which line it occurs on, I'm unable to research the issue further.

Paul Bent
Northwind IT Systems

http://www.northwindit.co.uk

 

[essnrv]

I am Sorry for not posting required information.
we are using Microsoft Outlook 97 (MSOUTL8.OLB). I am getting Error at below line

Set objFolder = ObjNameSpace.GetSharedDefaultFolder(objUser, olFolderCalendar)


Thank you for your quick responses

 

[paulbent]

GetSharedDefaultFolder is supported by OL97 according to my documentation but I don't have an OL97 system these days to test with.

The only thing I can see in your code is that you haven't resolved the recipient per the code example I posted originally.

Are you sure that the target user has granted the necessary permissions to the calendar folder for the user running your app?

If you'd post the error number I can try and research it further.

Paul Bent
Northwind IT Systems

http://www.northwindit.co.uk

 

[essnrv]

Hi paulbent,

Yes, they have permissions to Add/Delete appointments. Error number is -2147352567.

Thank you

 

[paulbent]

There's nothing in the KB relating to this error number and GetSharedDefaultFolder. I've no idea what the problem is, I know it works fine in OL98 and later from my own programming.

Did you resolve the recipient before passing it to GetSharedDefaultFolder?

Have you tested if a user can open another user's calendar folder manually in Outlook and add an appointment without error?

Paul Bent
Northwind IT Systems

http://www.northwindit.co.uk

 

[nakkii]

Here's a little function I ran across, Hope it helps




Function OutlookAppointment(sAttendees As String, sSubject As String, dtStart As Date, lDuration As Long, lReminder As Long sLocation As String, bRecurrence As Boolean) As String

Dim oAppointment As Outlook.AppointmentItem
Dim oRecurrence As Outlook.RecurrencePattern
Dim oOutlook As Outlook.Application
Dim asAttendees() As String, lThisAttendee As Long
Dim oFolder As MAPIFolder
Dim oItems As Items

' Start Outlook
' If it is already running, you'll use the same instance...
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application&quot

' Logon. Doesn't hurt if you are already running and logged on...
Dim olNs As Outlook.NameSpace
Set olNs = olApp.GetNamespace("MAPI&quot
olNs.Logon

Set oOutlook = New Outlook.Application
Set oAppointment = Outlook.CreateItem(olAppointmentItem)

'Set meeting parameters>
With oAppointment

.Duration = lDuration '(in minutes)
.Location = sLocation
.MeetingStatus = olMeeting
.Start = dtStart
.Subject = sSubject
.BusyStatus = olBusy
'.RecurrenceState
.ReminderSet = True
.ReminderMinutesBeforeStart = lReminder '(in Minutes)


End With

oAppointment.Save

'Add attendees
asAttendees = Split(sAttendees, ",&quot
For lThisAttendee = 0 To UBound(asAttendees)
With oAppointment.Recipients.Add(asAttendees(lThisAttendee))
.Type = 1 '1 = Required, 2 = Optional
End With
Next
oAppointment.Recipients.Add (sAttendees)
'Send the appointment>
oAppointment.Send

Set olApp = Nothing
Set olNs = Nothing
Set oAppointment = Nothing
Set oOutlook = Nothing
Set oRecurrence = Nothing

End Function

Persistence....Nothing in the world can take the place of persistence. Talent will not; nothing is more common than unsuccessful men with talent. Genius will not; unrewarded genius is almost a proverb. Education will not; the world is full of educated derelicts. Persistence and determination alone are omnipotent. -Calvin Coolidge