Home » Forums » Open Source Learning Center » Question and Answer

Creating appointments for outlook in VBA

Submitted by dt_lakers on 20 April, 2011 - 05:44
Hi Guys, This is my first post. I have a database full of tools that i need to create appointments for in outlook when they are due to be tested again. The database is quite large, so i want the code to figure out if there is already an appointment for tool testing on that day, and if there is, add the tool to the body of the message. so if more than one tool is due for testing, it will come up in one appointment. After lots of research, i thought the formula could look something like this: 
Sub AddAppointments2()
    ' Create the Outlook session
    Set myOutlook = CreateObject("Outlook.Application")
 
    ' Start at row 2
    r = 2
 
        Do Until Trim(Cells(r, 1).Value) = ""
        For Each olApt In olFldr.Items
        If TypeName(myApt) = "AppointmentItem" Then
        If InStr(1, myApt.Subject, "Test and Tag", vbTextCompare) Then
        myApt.Body = appt.Body & Cells(r, 2)
        myApt.Save
        Else
        ' Create the AppointmentItem
        Set myApt = myOutlook.createitem(1)
        ' Set the appointment properties
        myApt.Subject = Cells(r, 1).Value
        myApt.Location = Cells(r, 2).Value
        myApt.Start = Cells(r, 4).Value + TimeValue("08:00:00")
        myApt.Duration = Cells(r, 5).Value
        ' If Busy Status is not specified, default to 2 (Busy)
        If Trim(Cells(r, 6).Value) = "" Then
            myApt.BusyStatus = 2
        Else
            myApt.BusyStatus = Cells(r, 6).Value
        End If
        If Cells(r, 7).Value > 0 Then
            myApt.ReminderSet = True
            myApt.ReminderMinutesBeforeStart = Cells(r, 7).Value
        Else
            myApt.ReminderSet = False
        End If
        myApt.Body = Cells(r, 12).Value
        myApt.Save
        r = r + 1
 
        End If
        End If
 
        Loop   
 
End Sub '
This was made based on a few that i had seen around and i tried to tailor it to suit my needs. However, i keep getting the "loop without do" error or the "for without next error. Can anyone tweak this code to make it work?? Thanks in advance.
‹ help me to solve this issue How can I drag/autofill formula from source document in destination document ›
»

How can I create an

Submitted by Anonymous on 27 April, 2011 - 20:11.

How can I create an appointment in a public folder calendar? What code do I need to change folders and select another calendar?

»
Vishesh's picture

Outlook Appointment Error Solved

Submitted by Vishesh on 20 April, 2011 - 17:38.
Sub AddAppointments2()
    ' Create the Outlook session
    Set myOutlook = CreateObject("Outlook.Application")
 
    ' Start at row 2
    r = 2
 
    Do Until Trim(Cells(r, 1).Value) = ""
        For Each olapt In olFldr.Items
            If TypeName(myApt) = "AppointmentItem" Then
                If InStr(1, myApt.Subject, "Test and Tag", vbTextCompare) Then
                    myApt.Body = appt.Body & Cells(r, 2)
                    myApt.Save
                Else
                    ' Create the AppointmentItem
                    Set myApt = myOutlook.createitem(1)
                    ' Set the appointment properties
                    myApt.Subject = Cells(r, 1).Value
                    myApt.Location = Cells(r, 2).Value
                    myApt.Start = Cells(r, 4).Value + TimeValue("08:00:00")
                    myApt.Duration = Cells(r, 5).Value
                    ' If Busy Status is not specified, default to 2 (Busy)
                    If Trim(Cells(r, 6).Value) = "" Then
                        myApt.BusyStatus = 2
                    Else
                        myApt.BusyStatus = Cells(r, 6).Value
                    End If
                    If Cells(r, 7).Value > 0 Then
                        myApt.ReminderSet = True
                        myApt.ReminderMinutesBeforeStart = Cells(r, 7).Value
                    Else
                        myApt.ReminderSet = False
                    End If
                    myApt.Body = Cells(r, 12).Value
                    myApt.Save
                    r = r + 1
                End If
            End If
        Next olapt
    Loop
End Sub
»

Another error

Submitted by Anonymous on 20 April, 2011 - 20:36.

Thanks Vishesh.

This has gotten me past the errors i was having, altough now i have a different one. As i got this part of the code off the net, i'm not sure if it is entirely correct.

I now get an error message saying: "Object required". It specifies this line in the code.

For Each olapt In olFldr.Items

Can you, or anyone else see a problem with this line?

Thanks.

»

do you suppose i am missing a

Submitted by dt_lakers on 21 April, 2011 - 05:10.

do you suppose i am missing a "dim" or something at the start somewhere?

»
Vishesh's picture

Ans

Submitted by Vishesh on 21 April, 2011 - 08:43.

Yes

»

still having trouble

Submitted by dt_lakers on 26 April, 2011 - 21:06.
Vishesh, I am still struggling to get this right. Is this Dim correct or have i done this wrong? can you see anything else that could stop this from working? i also tried the line: Dim myApt As outlook.AppointmentItem. I am finding this very hard to work out. if you could help me here i would appreciate it. Many thanks. 
Sub AddAppointments2()
    ' Create the Outlook session
    Set myOutlook = CreateObject("Outlook.Application")
    Dim myApt As AppointmentItem
 
    ' Start at row 2
    r = 2
 
    Do Until Trim(Cells(r, 1).Value) = ""
        For Each olApt In olFldr.Items
            If TypeName(myApt) = "AppointmentItem" Then
                If InStr(1, myApt.Subject, "Test and Tag", vbTextCompare) Then
                    myApt.Body = appt.Body & Cells(r, 2)
                    myApt.Save
                Else
                    ' Create the AppointmentItem
                    Set myApt = myOutlook.createitem(1)
                    ' Set the appointment properties
                    myApt.Subject = Cells(r, 1).Value
                    myApt.Location = Cells(r, 2).Value
                    myApt.Start = Cells(r, 4).Value + TimeValue("08:00:00")
                    myApt.Duration = Cells(r, 5).Value
                    ' If Busy Status is not specified, default to 2 (Busy)
                    If Trim(Cells(r, 6).Value) = "" Then
                        myApt.BusyStatus = 2
                    Else
                        myApt.BusyStatus = Cells(r, 6).Value
                    End If
                    If Cells(r, 7).Value > 0 Then
                        myApt.ReminderSet = True
                        myApt.ReminderMinutesBeforeStart = Cells(r, 7).Value
                    Else
                        myApt.ReminderSet = False
                    End If
                    myApt.Body = Cells(r, 12).Value
                    myApt.Save
                    r = r + 1
                End If
            End If
        Next myApt
    Loop
End Sub
»