CODEWITHSUNDEEP
excelvbaoutlook
Deivid
Deivid

Reputation: 23

Create non-duplicate appointments from list in worksheet

I am trying to make appointments from a given date.

To avoid duplicates I tried coloring the cells but that does not seem viable.

Now I am trying to check if an appointment with the same "subject" as the cell exists and if so go to the next line.

I get the error

Object required

Private Sub Workbook_Open()
    Set myOutlook = CreateObject("Outlook.Application")
    r = 2
          
    Do Until Trim(Cells(r, 8).Value) = ""   
        If Cells(r, 9).Value = myapt.Subject = Cells(r, 9).Value Then
            r = r + 1      
        Else
            Set myapt = myOutlook.createitem(1)
            
            myapt.Subject = Cells(r, 9).Value
            myapt.Start = Cells(r, 8).Value
            myapt.AllDayEvent = True
            myapt.BusyStatus = 5
            myapt.ReminderSet = True
            'myapt.Body = ""
            myapt.Save
            
            Cells(r, 8).Interior.ColorIndex = 4
            r = r + 1
        End If    
    Loop
End Sub

Upvotes: 2

Views: 172

Answers (1)

Pᴇʜ
Pᴇʜ

Reputation: 57683

To check if an item exists you need to filter the existing items:

Option Explicit

Public Sub CreateItemsIfNotExist()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1") 'define your sheet!

    Dim olApp As Object  'create outlook application
    Set olApp = CreateObject("Outlook.Application")

    Dim olNS As Object 'get namespace
    Set olNS = olApp.GetNamespace("MAPI")

    'define constants if using late binding 
    Const olFolderCalendar As Long = 9
    Const olAppointmentItem As Long = 1

    Dim olRecItems As Object 'get all appointments
    Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)

    Dim strFilter As String  'filter for appointments
    Dim olFilterRecItems As Object 'filtered appointments

    Dim iRow As Long
    iRow = 2

    Do Until Trim$(ws.Cells(iRow, 8).Value) = vbNullString
        'filter appointments for subject
        strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 9).Value) & "'"
        Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)

        If olFilterRecItems.Count = 0 Then 'if subject does not exist
            With olApp.CreateItem(olAppointmentItem)
                .Subject = ws.Cells(iRow, 9).Value
                .Start = ws.Cells(iRow, 8).Value
                .AllDayEvent = True
                .BusyStatus = 5
                .ReminderSet = True
                .Save
            End With
            ws.Cells(iRow, 8).Interior.ColorIndex = 4
        End If

        iRow = iRow + 1
    Loop
End Sub

Note that maybe you want to quit outlook in the end olApp.Quit.

Upvotes: 1

Related Questions