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.

[vba]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[/vba]

[tifosi0101]

Thanks, this is great!

[bholmstrom]

[vba]

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
[/vba]

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.

Cal-screen1.JPG

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

Cheers...

BTW- thanks for formatting my post xld - 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