[Lil Help]

Hi,

I've been trying to put together a macro in excel that will loop through my Outlook Calendar to see if an appointment already exists, and if it doesn't exist, to create it.

The Macro works to create a new appointment. The problem arises when I try to loop through my calendar. When I try to run the macro via Excel>Tools>Macro>Run Maco I receive an error message, "Out of Memory"; However while Debugging in VB, I receive the error message, "Run-Time Error" followed by a series of numbers that changes every time I try to debug it, then "Automation Error"

If anyone has any insight as to what I should do, or how to fix my problem, I'd really appreciate it. Thank you very much.

Sub ExportAppointmentsToOutlook()
    Dim olApp As Outlook.Application
    Dim olApt As AppointmentItem
    Dim olAptS1 As AppointmentItem
    Dim olAptS2 As AppointmentItem
    Dim olAptS3 As AppointmentItem
    Dim blnCreated As Boolean
    Dim olCalendarFolder As Outlook.MAPIFolder   'use MAPI to loop through folder
    Dim olMessage As Object
    Dim olInboxMessages As Object
    Dim olNS As Outlook.Namespace
    Dim strSubject As String
 
    Application.ScreenUpdating = False
 
'Read the table with appointments:
    Dim arrAppt() As Variant, i As Long
    arrAppt = Range("A2", Cells(Rows.Count, "F").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
 
    Set olNS = olApp.GetNamespace("MAPI")
    Set olCalendarFolder = olNS.GetDefaultFolder(olFolderCalendar)
'Create the outlook item for the table entries:
'Rows:
' Column A = Job Name
' Column B = Permit Type
' Column C = Date Received
' Column D = Renewal Process
' Column E = Expiration Date
    For i = LBound(arrAppt) To UBound(arrAppt)
 
        strSubject = " Permit Expiration Approaching"
 
        'Attempting a loop for all appointments by date
           Set olAptS1 = olCalendarFolder.Items.Find(arrAppt(i, 5)) 'This Line is the Debug error = Run-Time Error (various numbers) Automation Error
                If olAptS1 Is Nothing Then
                    'Creating new appointments
                    Set olApt = olApp.CreateItem(olAppointmentItem)
                    With olApt
                    .Start = arrAppt(i, 5)
                    .End = arrAppt(i, 5)
                    .AllDayEvent = True
                    .Subject = arrAppt(i, 1) & strSubject
                    .Location = arrAppt(i, 1)
                    .Body = arrAppt(1, 3) & " expires " & arrAppt(i, 6) & ".  Please begin the renewal process. Do you need a new water sample? Don't forget the letter from the owner. - Created by excel tool"
                    .BusyStatus = olBusy
                    .ReminderSet = True
                    .ReminderMinutesBeforeStart = 0
                    .Save
                     End With
 
                Else
                            'Attempting to loop for all appointments on same date by subject
                            Set olAptS2 = olAptS1.Items.Find(arrAppt(i, 1))
                               If olAptS2 Is Nothing Then
                                'Creating new appointments
                                 Set olApt = olApp.CreateItem(olAppointmentItem)
                                 With olApt
                                 .Start = arrAppt(i, 5)
                                 .End = arrAppt(i, 5)
                                 .AllDayEvent = True
                                 .Subject = arrAppt(i, 1) & strSubject
                                 .Location = arrAppt(i, 1)
                                 .Body = arrAppt(1, 3) & " expires " & arrAppt(i, 6) & ".  Please begin the renewal process. Do you need a new water sample? Don't forget the letter from the owner. - Created by excel tool"
                                 .BusyStatus = olBusy
                                 .ReminderSet = True
                                 .ReminderMinutesBeforeStart = 0
                                 .Save
                                 End With
 
                               Else
                                      'Attempting to loop through filtered subjects with more filtering
                                    Set olAptS3 = olAptS3.Items.Find(strSubject)
                                        If olAptS3 Is Nothing Then
 
                                                    'Creating new appointments
                                                     Set olApt = olApp.CreateItem(olAppointmentItem)
                                                     With olApt
                                                    .Start = arrAppt(i, 5)
                                                    .End = arrAppt(i, 5)
                                                    .AllDayEvent = True
                                                    .Subject = arrAppt(i, 1) & strSubject
                                                    .Location = arrAppt(i, 1)
                                                    .Body = arrAppt(1, 3) & " expires " & arrAppt(i, 6) & ".  Please begin the renewal process. Do you need a new water sample? Don't forget the letter from the owner. - Created by excel tool"
                                                    .BusyStatus = olBusy
                                                    .ReminderSet = True
                                                    .ReminderMinutesBeforeStart = 0
                                                    .Save
                                                    End With
                                       Else
                End If
                    End If
                        End If
 
    Next i
 
    Set olApt = Nothing
    Set olApp = Nothing
    Set olAppSession = Nothing
    Set olCalendarFolder = Nothing
    Set olInboxMessages = Nothing
    Set olNS = Nothing
    Application.ScreenUpdating = True
End Sub

I thought of having a For Each olApt In olCalendarFolder.Items loop, however I would need the loop to compare the i's in excel to the apt Items, not the other way around. I can't figure out how to do that.

[Zack Barresse]

Well, I would think - and highly recommend - you NOT loop through your entire calendar. I would say try to think of some other criteria you can use. Can you explain the project you're trying to do here? What would be the criteria for finding an appointment? Can't you just look on the day you're referring to? Or how about a specific date range? Looping like that will probably make your machine smoke.

Edit: And btw, you're not looping, you're using multiple/nested If/Then statements. Much better than a loop if you have a specific number of conditions to check for, but loops should be avoided when they can be.

[Lil Help]

The concept of the project is to keep track of expiration dates for training and permits so as to know when to begin work to renew the training or permit.

The criteria I am currently using is the start date followed by the subject of the appointment. However I am doing it backwards. I would like to read the date in the excel column and check if an appointment exists on that date, then compare the subjects. I can't figure out how to do that properly.

The dates can be as far as multiple years in the future, and after a little while the program could just run "after today" but initially it may need some back tracking.

Excellent. Thank you for the explanation.

I also realize that I unnecessarily have the create appointment three times under the "Else" area of an "If". I was trying to use Not Nothing. Please, if you would be willling, feel free to clean it up.

Thank you very much.