Trouble creating outlook event from

Hi Nick

Look at this link...

http://www.excelforum.com/excel-prog...-calendar.html

Hi Nick

If you'll post a sample file of your data I'll be happy to look at it. Make certain the Structure of your sample file is the same as your actual workbook.

Make sure there is just enough data to demonstrate your need. INCLUDE ANY CODE YOU'RE USING OR HAVE TRIED.

Remember to desensitize the data.

Click on GO ADVANCED and use the paperclip icon to open the upload window.

What is the NAME of the Calendar in which you'll be creating the appointments?

Hi Nick

Please populate your Workbook with some sample data...three or four items will suffice.

Hi Nick

Try this Code in the attached...

Option Explicit
Sub AddOutLookTask()
   ' add a refrence to Microsoft outlook object library
   Dim appOutLook   As Outlook.Application
   Dim taskOutLook  As Outlook.AppointmentItem
   Dim myItem       As Outlook.AppointmentItem
   Dim myItems      As Outlook.Items
   Dim data         As Worksheet
   Dim subject      As String
   Dim body         As String
   Dim wen          As Date
   Dim i            As Long
   Dim olNs         As Namespace
   Dim durationarray() As String
   Dim Duration     As Double
   Dim reminder1()  As String
   Dim Reminder     As Double

   Set appOutLook = CreateObject("Outlook.Application")
   Set olNs = appOutLook.GetNamespace("MAPI")
   Set myItems = olNs.GetDefaultFolder(olFolderCalendar).Items

   Set taskOutLook = appOutLook.CreateItem(olAppointmentItem)
   Set data = ThisWorkbook.Worksheets("Agenda")   ' change worksheetname as required
   For i = 2 To Application.CountA(Sheets("Agenda").Range("A:A"))   ' loop through each row starting at row 2  (loop uses column A as a count - ensure column A always contains a name
      subject = data.Cells(i, 1)
      body = "You have a meeting with " & subject
      wen = DateValue(data.Cells(i, 2)) + data.Cells(i, 3)
      If InStr(data.Cells(i, 4), "hr") Then   ' does duration contain 'hr'
         durationarray = Split(data.Cells(i, 4), " ")   ' get digits before first space
         Duration = Val(durationarray(0))
      Else
         durationarray = Split(data.Cells(i, 4), " ")
         Duration = Val(durationarray(0)) / 60   'if duration does not contain hr  (i.e. mins) then convert mins to decimal of an hour  (30 mins = 0.5)
      End If
      reminder1 = Split(data.Cells(i, 5), " ")   ' assume always days and get digits before first space
      Reminder = reminder1(0)

      Set myItem = myItems.Find("[Subject]=" & Chr(34) & subject & Chr(34))

      If Not myItem Is Nothing Then
         If myItem.subject = subject And _
            myItem.Duration / 60 = Duration And _
            myItem.Start = wen Then
            MsgBox subject & " Already Scheduled"
            GoTo Skip_Me
         End If

      Else
         Set taskOutLook = appOutLook.CreateItem(olAppointmentItem)
         With taskOutLook
            .subject = subject
            .body = body
            .ReminderSet = True
            .ReminderMinutesBeforeStart = Reminder * 24 * 60   ' reminder in hours converted to minutes
            .Duration = Duration * 60   ' duration converted to minutes
            .Start = wen   ' start date/time
            .Save
         End With
      End If
      Set myItem = myItems.FindNext
Skip_Me:
   Next
   Set appOutLook = Nothing
   Set taskOutLook = Nothing
   Set data = Nothing
   Set taskOutLook = Nothing
End Sub

You're welcome...glad I could help. Thanks for the Rep.

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED. Thanks.

Hi Nick

Do you really require the message? If so, what are you looking for, one message with ALL the "Already Scheduled" items?

Let me look at it...I have some ideas.

Hi Nick

Replace the Code with this...

Option Explicit
Sub AddOutLookTask()
   ' add a refrence to Microsoft outlook object library
   Dim appOutLook   As Outlook.Application
   Dim taskOutLook  As Outlook.AppointmentItem
   Dim myItem       As Outlook.AppointmentItem
   Dim myItems      As Outlook.Items
   Dim data         As Worksheet
   Dim subject      As String
   Dim body         As String
   Dim wen          As Date
   Dim i            As Long
   Dim olNs         As Namespace
   Dim durationarray() As String
   Dim Duration     As Double
   Dim reminder1()  As String
   Dim Reminder     As Double
   Dim myArray()    As Variant
   Dim msgString    As String

   ReDim myArray(0)
   Set appOutLook = CreateObject("Outlook.Application")
   Set olNs = appOutLook.GetNamespace("MAPI")
   Set myItems = olNs.GetDefaultFolder(olFolderCalendar).Items

   '   Set taskOutLook = appOutLook.CreateItem(olAppointmentItem)
   Set data = ThisWorkbook.Worksheets("Agenda")   ' change worksheetname as required
   For i = 2 To Application.CountA(Sheets("Agenda").Range("A:A"))   ' loop through each row starting at row 2  (loop uses column A as a count - ensure column A always contains a name
      subject = data.Cells(i, 1)
      body = "You have a meeting with " & subject
      wen = DateValue(data.Cells(i, 2)) + data.Cells(i, 3)
      If InStr(data.Cells(i, 4), "hr") Then   ' does duration contain 'hr'
         durationarray = Split(data.Cells(i, 4), " ")   ' get digits before first space
         Duration = Val(durationarray(0))
      Else
         durationarray = Split(data.Cells(i, 4), " ")
         Duration = Val(durationarray(0)) / 60   'if duration does not contain hr  (i.e. mins) then convert mins to decimal of an hour  (30 mins = 0.5)
      End If
      reminder1 = Split(data.Cells(i, 5), " ")   ' assume always days and get digits before first space
      Reminder = reminder1(0)

      '      ReDim myArray(0)
      Set myItem = myItems.Find("[Subject]=" & Chr(34) & subject & Chr(34))

      If Not myItem Is Nothing Then
         If myItem.subject = subject And _
            myItem.Duration / 60 = Duration And _
            myItem.Start = wen Then

            myArray(UBound(myArray)) = subject & " already acheduled"
            ReDim Preserve myArray(UBound(myArray) + 1)
            '            MsgBox subject & " Already Scheduled"
            GoTo Skip_Me
         End If

      Else
         Set taskOutLook = appOutLook.CreateItem(olAppointmentItem)
         With taskOutLook
            .subject = subject
            .body = body
            .ReminderSet = True
            .ReminderMinutesBeforeStart = Reminder * 24 * 60   ' reminder in hours converted to minutes
            .Duration = Duration * 60   ' duration converted to minutes
            .Start = wen   ' start date/time
            .Save
         End With
      End If
      Set myItem = myItems.FindNext
Skip_Me:
   Next
   On Error Resume Next
   ReDim Preserve myArray(UBound(myArray) - 1)
   On Error GoTo 0
   msgString = Join(myArray, vbCr)
   If Not IsError(Application.Match("*", (myArray), 0)) Then
      MsgBox msgString
   End If
   Set appOutLook = Nothing
   Set taskOutLook = Nothing
   Set data = Nothing
   Set taskOutLook = Nothing
End Sub