Macro to create outlook appointment

[Dan Wood]

I have posted a number of questions recently based around this subject. I
have nearly finished but need a couple more things before it is perfect.

My code is as follows:-

Macro 1:-

Sub RunIf()
For Each c In Range("C3:F14")
If c.Value = "A/L" Then
If c.Offset(0, 1).Value = "done" Then
'skip it'
Else
'do it'
Call Add_Appointment
c.Offset(0, 1).Value = "done"
Call Add_Appointment
End If
End If
Next
End Sub


Macro 2 -

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
.ReminderSet = False
.Subject = Range("C1").Value & " - A/L"
.Save

End With

Set myitem = Nothing
Set myOlapp = Nothing

End Sub

The last bit of help i need is:-

1) Within the .Subject field in Macro 2 is there a way i can get this to
look at the top field in the column? I may just assign macro 1 to a button
for each column, which may be from 'C' up to 'Z', but instead of creating
mulpitple macro's for each row, can .Subject field be completed automatically?

2) When creating the appointment, the annual leave will be assigned next to
a date, but when running it will only populate all appoinments onto the
current day. How would i set it to cross reference the date field to create
the appointment against the correct date?

3) How can i specify which calender it adds the appointment to? This macro
will be running for a shared calender.

4) How do i stop the entries duplicating in the calender?

Again any answers to the above questions are really appreciated.

Thanks

 

[Jarek Kujawa]

1) yes
put the following line at the top of your module:
Private c as Range

then in Macro2 replace
..Subject = Range("C1").Value & " - A/L"
with
..Subject = cells(1,c.Column).Value & " - A/L"

HIH

 

[Dan Wood]

I have entered what you said but it doesnt seem to work. This is how it now
looks:-

Private c As Range
---------------------------------------------------
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
.ReminderSet = False
.Subject = Cells(1, c.Column).Value & " - A/L"
.Save

End With

Set myitem = Nothing
Set myOlapp = Nothing

End Sub

 

[Dave Peterson]

Check your other post, too.

I have posted a number of questions recently based around this subject. I
have nearly finished but need a couple more things before it is perfect.

My code is as follows:-

Macro 1:-

Sub RunIf()
For Each c In Range("C3:F14")
If c.Value = "A/L" Then
If c.Offset(0, 1).Value = "done" Then
'skip it'
Else
'do it'
Call Add_Appointment
c.Offset(0, 1).Value = "done"
Call Add_Appointment
End If
End If
Next
End Sub

Macro 2 -

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
.ReminderSet = False
.Subject = Range("C1").Value & " - A/L"
.Save

End With

Set myitem = Nothing
Set myOlapp = Nothing

End Sub

The last bit of help i need is:-

1) Within the .Subject field in Macro 2 is there a way i can get this to
look at the top field in the column? I may just assign macro 1 to a button
for each column, which may be from 'C' up to 'Z', but instead of creating
mulpitple macro's for each row, can .Subject field be completed automatically?

2) When creating the appointment, the annual leave will be assigned next to
a date, but when running it will only populate all appoinments onto the
current day. How would i set it to cross reference the date field to create
the appointment against the correct date?

3) How can i specify which calender it adds the appointment to? This macro
will be running for a shared calender.

4) How do i stop the entries duplicating in the calender?

Again any answers to the above questions are really appreciated.

Thanks