Solved: Excel generate calendar appointments in Outlook.

[ukdane]

Is it possible to have a worksheet generate an calendar appointment in Microsoft Outlook?

For example If my worksheet has a list of customers names, and a list of when they next have to be contacted, is it possible to generate a calendar reminder that will show up the day the customer needs to be contacted?

Cheers

[Bob Phillips]

Sub Appointments()
Const olAppointmentItem As Long = 1
Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object

On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0

If Not OLApp Is Nothing Then

Set OLNS = OLApp.GetNamespace("MAPI")
OLNS.Logon

Set OLAppointment = OLApp.CreateItem(olAppointmentItem)
OLAppointment.Subject = Range("A1").Value
OLAppointment.Start = Range("B1").Value
OLAppointment.Duration = Range("C1").Value
OLAppointment.ReminderMinutesBeforeStart = Range("D1").Value
OLAppointment.Save

Set OLAppointment = Nothing
Set OLNS = Nothing
Set OLApp = Nothing
End If

End Sub

[ukdane]

Super thanks.

[slamet Harto]

Hi Bob,

I'm interesting with the case.
My question is how to expand the code to send the information for the following box.

Thanks in advance.
Harto

[Bob Phillips]

Sorry Slamet, what extra information are you asking for?

[slamet Harto]

Dear Bob

I just modified your code in order to invite someone and give a note in the body text. Can you help me on this?.
I can't figure out how to create a loop to create another appointment for entire row.

Thank you as always.

pls have a look into the attachement also.

Sub Appointments()
Const olAppointmentItem As Long = 1
Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object
Dim Tanggal As Date

On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0

If Not OLApp Is Nothing Then

Set OLNS = OLApp.GetNamespace("MAPI")
OLNS.Logon

Set OLAppointment = OLApp.CreateItem(olAppointmentItem)
OLAppointment.To = Range("A1").Value
OLAppointment.Subject = Range("B1").Value
OLAppointment.Start = Range("C1").Value
OLAppointment.Duration = Range("D1").Value
OLAppointment.ReminderMinutesBeforeStart = Range("E1").Value
OLAppointment.body = Range("F1").Value

OLAppointment.Save

Set OLAppointment = Nothing
Set OLNS = Nothing
Set OLApp = Nothing
End If

End Sub

[tifosi0101]

Thanks, this is great!

[bholmstrom]

Sub Appointments()
Const olAppointmentItem As Long = 1
Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object

On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0

If Not OLApp Is Nothing Then

Set OLNS = OLApp.GetNamespace("MAPI")
OLNS.Logon

Set OLAppointment = OLApp.CreateItem(olAppointmentItem)
OLAppointment.Subject = Range("A1").Value
OLAppointment.Start = Range("B1").Value
OLAppointment.Duration = Range("C1").Value
OLAppointment.ReminderMinutesBeforeStart = Range("D1").Value
OLAppointment.Save

Set OLAppointment = Nothing
Set OLNS = Nothing
Set OLApp = Nothing
End If

End Sub


How can I get the name of a spreadsheet from inside of Outlook Calendar before running this ?????

[Bob Phillips]

What is the connection between a spreadsheet name and the OUtlook calendar?

[bholmstrom]

I have solved most of it......but I do thank you guys for your quick responses

[bholmstrom]

I do have a question about conficting appointments during the import..should I create a new post?

[Bob Phillips]

Yes.

[bholmstrom]

my bad...cant find out where to start a new post...or do i just do it here?

[bholmstrom]

Heres what I have so far:
iRow = 2
iCol = 1

While exlSht.Cells(iRow, 1) <> ""
Dim cnct As ContactItem
Set itmAppt = Outlook.CreateItem(olAppointmentItem)
Dim BodyText As String
BodyText = "File #: " + exlSht.Cells(iRow, 1) + " " + exlSht.Cells(iRow, 3) + " vs. " + exlSht.Cells(iRow, 2)
itmAppt.Categories = exlSht.Cells(iRow, 1) ' Fileno
itmAppt.Companies = exlSht.Cells(iRow, 3) ' D1_Name
itmAppt.Start = exlSht.Cells(iRow, 5) ' "04/02/2011 11:15 AM" ' exlSht.Cells(iRow, 3) ' Date
itmAppt.Subject = exlSht.Cells(iRow, 7) ' Diary_Des
itmAppt.Location = exlSht.Cells(iRow, 8) ' Clerk_Name
itmAppt.AllDayEvent = False
itmAppt.Body = BodyText
itmAppt.ReminderSet = True
itmAppt.ReminderMinutesBeforeStart = 120

' itmAppt.Links.Add cnct
' Set aptPtrn = itmAppt.GetRecurrencePattern
' aptPtrn.StartTime = exlSht.Cells(iRow, 5)
' aptPtrn.EndTime = exlSht.Cells(iRow, 6)
' aptPtrn.RecurrenceType = olRecursYearly

' If aptPtrn.Duration > 1440 Then aptPtrn.Duration = aptPtrn.Duration - 1440
' Select Case exlSht.Cells(iRow, 7)
' Case "No Reminder"
' itmAppt.ReminderSet = False
' Case "0 minutes"
' itmAppt.ReminderSet = True
' itmAppt.ReminderMinutesBeforeStart = 0
' Case "1 day"
' itmAppt.ReminderSet = True
' itmAppt.ReminderMinutesBeforeStart = 1440
' Case "2 days"
' itmAppt.ReminderSet = True
' itmAppt.ReminderMinutesBeforeStart = 2880
' Case "1 week"
' itmAppt.ReminderSet = True
' itmAppt.ReminderMinutesBeforeStart = 10080
' End Select
IsAppointmentInConflict (isConflicted)
itmAppt.Save
iRow = iRow + 1
Wend
Excel.Application.DisplayAlerts = True
Excel.Application.Workbooks.Close
Excel.Application.Quit

exlApp.Quit
Set exlApp = Nothing


End Sub

Function IsAppointmentInConflict(itappt As Outlook.AppointmentItem) As Boolean
IsAppointmentInConflict = ((itmAppt.Conflicts.Count > 0) Or (itmAppt.isConflict))
End Function

The code above works....(too well...keeps ojn duplicating appointments)
Now I need to find out how to check for conflicts and if found simpley REPLACE the current item

Thanks again in advance

[glennlawr]

I know this is an old thread but I am trying to use the below code, can anyone tell me how to edit this so it does not create duplicate appointments every time I execute the macro? Also, how do I make it add appointments from rows below row 1?Currently it only adds appointments for details entered in row 1, column A1, B1, C1 & D1. When I add dates and infor to A2, B2, C2 & D2 it does not create these appointments.Many thanks in advance...


Sub Appointments()
Const olAppointmentItem As Long = 1
Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object

On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0

If Not OLApp Is Nothing Then

Set OLNS = OLApp.GetNamespace("MAPI")
OLNS.Logon
Set OLAppointment = OLApp.CreateItem(olAppointmentItem)
OLAppointment.Subject = Range("A1").Value
OLAppointment.Start = Range("B1").Value
OLAppointment.Duration = Range("C1").Value
OLAppointment.ReminderMinutesBeforeStart = Range("D1").Value
OLAppointment.Save
Set OLAppointment = Nothing
Set OLNS = Nothing
Set OLApp = Nothing
End If
End Sub

[glennlawr]

Sorry about the format of the above post, I can't figure out how to format it nicely!

[nelmey]

you need to change your ranges to a2 b2 etc as for duplicates you could try this script

Sub ExportTasksToOutlook() 'Reference set to (Tools | References) ...
'Microsoft Outlook 12.0 Object Library
'Exchange "12.0" with your version number
'Outlook 2007 = 12.0
'Outlook 2003 = 11.0
'Outlook 2002 = 10.0
'Outlook 2000 = 9.0
Dim olApp As Outlook.Application
Dim blnCreated As Boolean
Dim arrTasks() As Variant, i As Long
arrTasks = Range("A2", Cells(Rows.Count, "B").End(xlUp)).Value
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
blnCreated = True
Err.Clear
Else
blnCreated = False
End If
On Error GoTo 0
For i = LBound(arrTasks) To UBound(arrTasks)
With olApp.CreateItem(olTaskItem)
.DueDate = arrTasks(i, 1)
.Subject = arrTasks(i, 2)
.Save
' .Close
End With
Next i
If blnCreated = True Then
olApp.Quit
End If
End Sub

[glennlawr]

Thanks for getting back to me on this nelmey!

But I cannot get this to work. After trying to use your code I got some compile errors, but then enabled some options in "Tools>References". Now I don't get any errors, but it does not create any calendar entries when I run my macro, nothing seems to happen.

Do you have any advice? See below the values I have in my sheet to create these.

11091

One thing to keep in mind, I have no experience with this code, none at all!

Cheers...

BTW- thanks for formatting my post xld :thumb- something funny with the browser I used...

[glennlawr]

I have just realized that this is actually creating items in my calendar, but in the tasks, not as appointments like the original code. Also, it does not set any reminder and it is still duplicating the entries when run again.

Can you maybe advise how to work around this nelmey?

Many thanks...

[nelmey]

sorry this is what i am currently using hope it helps i have tried to modify it to your needs bassed on colmn a containing start date/time column b subject column c reminder and column d end time i have also left appointment body (column e) and location (column f) in there also make sure you move your data down to row 2 and you can put headers in row 1 code starts from row 2


Option Explicit


Sub AddToOutlook()


Dim OL As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim NS As Outlook.Namespace
Dim colItems As Outlook.Items
Dim olApptSearch As Outlook.AppointmentItem
Dim r As Long, sSubject As String, sBody As String, sLocation As String
Dim dStartTime As Date, dEndTIme As Double, dReminder As Double, dCatagory As Double
Dim sSearch As String, bOLOpen As Boolean






On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
bOLOpen = True
If OL Is Nothing Then
Set OL = CreateObject("Outlook.Application")
bOLOpen = False
End If
Set NS = OL.GetNamespace("MAPI")
Set colItems = NS.GetDefaultFolder(olFolderCalendar).Items


For r = 2 To 10


If Len(Sheet1.Cells(r, 2).Value & Sheet1.Cells(r, 1).Value) = 0 Then GoTo NextRow
sSubject = Sheet1.Cells(r, 2).Value
sBody = Sheet1.Cells(r, 5).Value
dStartTime = Sheet1.Cells(r, 1).Value
dEndTIme = Sheet1.Cells(r, 4).Value
sLocation = Sheet1.Cells(r, 6).Value
dReminder = 120

sSearch = "[Subject] = " & sQuote(sSubject)
Set olApptSearch = colItems.Find(sSearch)


If olApptSearch Is Nothing Then
Set olAppt = OL.CreateItem(olAppointmentItem)
olAppt.Body = sBody
olAppt.Subject = sSubject
olAppt.Start = dStartTime
olAppt.Duration = dEndTIme
olAppt.Location = sLocation
olAppt.Catagory = dCatagory
olAppt.Close olSave
End If


NextRow:
Next r


If bOLOpen = False Then OL.Quit


End Sub


Function sQuote(sTextToQuote)
sQuote = Chr(34) & sTextToQuote & Chr(34)
End Function

[glennlawr]

Sorry to hassle you with this again nelmey, but I can't seem to get this to work!

I put your latest code in and when I tried to run I got a "Compile error: User-defined type not defined". I then enabled the "Microsoft Outlook 14.0 Object Library" Reference and when I ran again I got no error. I thought great, but my happiness was short lived. Although I got no error, I also got no appointment :(

I have tried to mess around with the data in the sheet to see if this works by putting in different date formats, different values for the Reminder etc. etc. however nothing will make it create the appointment. I also checked my tasks to make sure that nothing was created in here, but it was not.

See below my spreadsheet layout, do you have any ideas why this could not be working? I am using VB for Application 7 in Excel 2010.

11097

Many thanks in advance...

Glenn

[nelmey]

make your sheet in this format with date and time serated
11099
then copy and paste this code


Option Explicit

Sub AddToOutlook()


Dim OL As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim NS As Outlook.Namespace
Dim colItems As Outlook.Items
Dim olApptSearch As Outlook.AppointmentItem
Dim r As Long, sSubject As String, sBody As String, sLocation As String
Dim dStartTime As Date, dEndTime As Date, dReminder As Double, dCatagory As Double
Dim sSearch As String, bOLOpen As Boolean






On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
bOLOpen = True
If OL Is Nothing Then
Set OL = CreateObject("Outlook.Application")
bOLOpen = False
End If
Set NS = OL.GetNamespace("MAPI")
Set colItems = NS.GetDefaultFolder(olFolderCalendar).Items


For r = 2 To 4


If Len(Sheet1.Cells(r, 2).Value & Sheet1.Cells(r, 1).Value) = 0 Then GoTo NextRow
sSubject = Sheet1.Cells(r, 2).Value
sBody = Sheet1.Cells(r, 5).Value
dStartTime = Sheet1.Cells(r, 1).Value + Sheet1.Cells(r, 2).Value
dEndTime = Sheet1.Cells(r, 4).Value
sLocation = Sheet1.Cells(r, 6).Value
dReminder = Sheet1.Cells(r, 3).Value


sSearch = "[Subject] = " & sQuote(sSubject)
Set olApptSearch = colItems.Find(sSearch)


If olApptSearch Is Nothing Then
Set olAppt = OL.CreateItem(olAppointmentItem)
olAppt.Body = sBody
olAppt.Subject = sSubject
olAppt.Start = dStartTime
olAppt.End = dEndTime
olAppt.Location = sLocation
olAppt.Catagory = dCatagory
olAppt.Close olSave
End If


NextRow:
Next r


If bOLOpen = False Then OL.Quit


End Sub


Function sQuote(sTextToQuote)
sQuote = Chr(34) & sTextToQuote & Chr(34)
End Function

[glennlawr]

nelmey,

Can you confirm that this is working for you with this layout in your sheet and the code you posted in your project?

Here is my sheet:

11103

I have your code in my project, but when I run it nothing happens. I get no error but no appointment is created.

Many thanks again...

Glenn

[nelmey]

I can confirm it is working for me I presume you are using a single sheet or sheet 1 of your workbook

[nelmey]

have made a couple of adjustments try this


Option Explicit
Sub AddToOutlook()


Dim OL As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim NS As Outlook.Namespace
Dim colItems As Outlook.Items
Dim olApptSearch As Outlook.AppointmentItem
Dim r As Long, sSubject As String, sBody As String, sLocation As String
Dim dStartTime As Date, dEndTime As Date, dReminder As String, dCatagory As Double
Dim sSearch As String, bOLOpen As Boolean






On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
bOLOpen = True
If OL Is Nothing Then
Set OL = CreateObject("Outlook.Application")
bOLOpen = False
End If
Set NS = OL.GetNamespace("MAPI")
Set colItems = NS.GetDefaultFolder(olFolderCalendar).Items


For r = 2 To 20




If Len(Sheet1.Cells(r, 1).Value + Sheet1.Cells(r, 5).Value) = 0 Then GoTo NextRow
sSubject = Sheet1.Cells(r, 3).Value
sBody = Sheet1.Cells(r, 6).Value
dStartTime = Sheet1.Cells(r, 1).Value + Sheet1.Cells(r, 2).Value
dEndTime = Sheet1.Cells(r, 5).Value
sLocation = Sheet1.Cells(r, 7).Value
dReminder = Sheet1.Cells(r, 4).Value


sSearch = "[Subject] = " & sQuote(sSubject)
Set olApptSearch = colItems.Find(sSearch)


If olApptSearch Is Nothing Then
Set olAppt = OL.CreateItem(olAppointmentItem)
olAppt.Body = sBody
olAppt.Subject = sSubject
olAppt.Start = dStartTime
olAppt.End = dEndTime
olAppt.Location = sLocation
olAppt.Catagory = dCatagory
olAppt.Close olSave
End If


NextRow:
Next r


If bOLOpen = False Then OL.Quit


End Sub


Function sQuote(sTextToQuote)
sQuote = Chr(34) & sTextToQuote & Chr(34)
End Function

[glennlawr]

This did the trick nemley! Got it working now :) Many thanks for all your help and advice on this... Glenn

[SamT]

@ Jarhead
I moved your question to : http://www.vbaexpress.com/forum/showthread.php?62287-Outlook-Calander-Appointments-With-Excel