Solved: Excel generate calendar appointments in Outlook.

[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.

Cal-screen2.JPG

Many thanks in advance...

Glenn

[nelmey]

make your sheet in this format with date and time serated

Untitled.jpg

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:

Cal-screen3.JPG

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/show...nts-With-Excel