Offsetting

[Dan Wood]

I have a macro to create an appointment in the outlook calender via a form on
excel. What i would now like to do it add some offsetting for the text in the
appoinment to show the name at the top of the form.

Within my spreadsheet i have names across from c1, d1, e1 and f1. Below
these headings will be what area somebody is working, for example from c3 to
c14 someone may be on annual leave. I want this to create a note saying 'Name
- Annual Leave'

My code can put the Annual Leave part but not he name:-

Sub Add_Appointment()
Dim myOlapp As Object
Dim myitem As Object

Set myOlapp = CreateObject("Outlook.Application")
Set myitem = myOlapp.createitem(1)

With myitem
.Body = "Annual Leave."
'.Duration = dur'
.AllDayEvent = True
.Subject = "A/L"
.Save

End With

Set myitem = Nothing
Set myOlapp = Nothing

End Sub

I need to update the 'Body' part of the text to look to c1 to get the column
title.

All help is much appreciated, and if any more detail is needed im happy to
provide

 

[Bernie Deitrick]

Dan,

You could simply use code like

.Body = Range("C1").Value & " - Annual Leave."

or, to be flexible and pick up the top of the current column:

.Body = Cells(1,Activecell.Column).Value & " - Annual Leave."

instead of

.Body = "Annual Leave."


HTH,
Bernie
MS Excel MVP

 

[Dan Wood]

That has worked eprfectly. Thank you.

Do you know of a way to stop the macro adding the same request again? It
works to add the request, but if i run it again the annual leave appointment
is added again, meaning multiple calender events for the same thing

 

[Bernie Deitrick]

Dan,

You need to check if the appointment exist, so you need to add a section
like that. I am not that good with the Outlook object model, so the code
below is probably not optimum but it works - but perhaps you can have
multiple appointments with the same Subject, so the check may need to be
modified.

HTH,
Bernie
MS Excel MVP


Sub Add_Appointment()
Dim myOlApp As Outlook.Application
Dim objNS As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Dim objAppt As Outlook.AppointmentItem
Dim strMsg As String
Dim strName As String
On Error Resume Next

Set myOlApp = CreateObject("Outlook.Application")
Set objNS = myOlApp.GetNamespace("MAPI")
Set objFolder = objNS.GetDefaultFolder(olFolderCalendar)

If Not objFolder Is Nothing Then
For Each objAppt In objFolder.Items
If objAppt.Subject = "A/L" And objAppt.Start = Date Then
MsgBox "That appointment already exists!"
Exit Sub
End If
Next objAppt
End If

Set objAppt = objFolder.Items.Add
If Not objAppt Is Nothing Then
With objAppt
..Body = Cells(1,Activecell.Column).Value & " - Annual Leave."
.AllDayEvent = True
.Subject = "A/L"
.Save
End With
End If

Set objAppt = Nothing
Set objNS = Nothing
Set myOlApp = Nothing
Set objFolder = Nothing
End Sub