VBA Excel to Outlook Appointment

[WarPigl3t]

Hi. I am doing a job for someone. I got most of this code online, but I made some changes to it. The original code doesn't work and neither does this new code that I made. I was hoping someone could help me out. Each row is going to be a new calendar appointment in Outlook. I also want to know how to make it into a meeting instead of an appointment. The code I wrote is self explanatory but the code I didn't write is hard to understand. Help me troubleshoot the code and explain what the lines I highlighted in red are. No rush. Need to figure it out by Saturday. You don't even have to write the code for me. I can figure it out if someone explains the red highlighted areas. Thanks.

	A	B	C	D	E	F	G	H
1	Sequence	Subject	Location	Description	Date	Start Time	End Time	Attendees
2	1001	Test 1	Location 1	Description 1	9/28/2016	9:00 PM	9:15 PM	sean@seangirvan.com;sean.girvan@utegration.com
3	1002	Test 2	Location 2	Description 2	9/28/2016	9:15 PM	9:30 PM	sean@seangirvan.com;sean.girvan@utegration.com
4	1003	Test 3	Location 3	Description 3	9/28/2016	9:30 PM	9:45 PM	sean@seangirvan.com;sean.girvan@utegration.com
5	1004	Test 4	Location 4	Description 4	9/28/2016	9:45 PM	10:00 PM	sean@seangirvan.com;sean.girvan@utegration.com
6	1005	Test 5	Location 5	Description 5	9/28/2016	10:00 PM	10:15 PM	sean@seangirvan.com;sean.girvan@utegration.com

<tbody>
</tbody>

Const firstRow_withData = 2
Const sequenceColumn = 1
Const subjectColumn = 2
Const locationColumn = 3
Const descriptionColumn = 4
Const dateColumn = 5
Const startTimeColumn = 6
Const endTimeColumn = 7
Const attendeesColumn = 8
Sub RegisterAppointmentList()
   [COLOR=#008000] 'adds a list of appontments to the Calendar in Outlook[/COLOR]
    Dim olApp As Outlook.Application
    Dim olAppItem As Outlook.AppointmentItem
    Dim r As Long
    On Error Resume Next
   [COLOR=#008000] 'Worksheets("Schedule").Activate 'unnecessary[/COLOR]
    Set olApp =[COLOR=#ff0000] GetObject("", "Outlook.Application")[/COLOR]
    On Error GoTo 0
    If olApp [COLOR=#ff0000]Is Nothing[/COLOR] Then
        On Error Resume Next
        Set olApp = CreateObject("Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If
    r = firstRow_withData [COLOR=#008000]'first row with appointment data in the active worksheet[/COLOR]
    Dim mysub, myStart, myEnd
    lastRow = Cells(Rows.Count, sequenceColumn).End(xlUp).Row
    Do Until r > lastRow
        mysub = Cells(r, locationColumn) & ", " & Cells(r, descriptionColumn)
        myStart = DateValue(Cells(r, dateColumn).Value) + Cells(r, startTimeColumn).Value
        myEnd = DateValue(Cells(r, dateColumn).Value) + Cells(r, endTimeColumn).Value
        [COLOR=#008000]'DeleteTestAppointments mysub, myStart, myEnd '??? No idea what this is[/COLOR]
        Set olAppItem = olApp.CreateItem(olAppointmentItem) [COLOR=#008000]'creates a new appointment[/COLOR]
        With olAppItem
            [COLOR=#008000]'set default appointment values[/COLOR]
            [COLOR=#008000]'[/COLOR][COLOR=#ff0000].Location[/COLOR][COLOR=#008000] = Cells(r, locationColumn) 'Error here[/COLOR]
            .Body = ""
            .[COLOR=#ff0000]ReminderSet [/COLOR]= True
            .[COLOR=#ff0000]BusyStatus = olFree[/COLOR]
            '.RequiredAttendees = "johndoe@microsoft.com"
            On Error Resume Next
            .Start = myStart
            .End = myEnd
            .Subject = Cells(r, subjectColumn) & ", " & .Location
            .[COLOR=#ff0000]Attachments.Add ("c:\temp\somefile.msg")[/COLOR]
            .Location = Cells(r, locationColumn).Value
            .Body = .Subject & ", " & Cells(r, dateColumn).Value
            .ReminderSet = True
            .[COLOR=#ff0000]BusyStatus = olBusy[/COLOR]
            .[COLOR=#ff0000]Categories = "Orange Category[/COLOR]" [COLOR=#008000]'add this to be able to delete the testappointments[/COLOR]
            On Error GoTo 0
            .Save [COLOR=#008000]'saves the new appointment to the default folder[/COLOR]
        End With
        r = r + 1
    Loop
    Set olAppItem = Nothing
    Set olApp = Nothing
    MsgBox "Done !"
End Sub

 

[Rijnsent]

Hi WarPig,
I hope your question is still relevant, but:

    'Take the opened Outlook as the base for the appointment, which causes an error if it isn't open. Therefore, skip over the error (don't crash the code)
    On Error Resume Next
    Set olApp = GetObject("", "Outlook.Application")
    On Error GoTo 0
    'If olApp isn't loaded (is Nothing), that means Outlook isn't active at this moment, start an instance of Outlook or fail when it isn't installed/available
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = CreateObject("Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If


        ' Create a new appointment
        Set olAppItem = olApp.CreateItem(olAppointmentItem)
        ' Modify/update all kind of properties of that appointment, see https://technet.microsoft.com/en-us/library/ee692864.aspx for another example 
        With olAppItem
            'set default appointment values
            '.Location = Cells(r, locationColumn) 'Error here -> this can give an error if Cells(r, locationColumn) doesn't give back a string, as that's what Location would need
            .Body = ""
            .ReminderSet = True  ' Will Outlook show a popup/reminder to the user when the time for the appointment is there
            .BusyStatus = olFree  ' olFree & olBusy are constants of Outlook to tell whether the appointment has to be displayed as "free", "busy" or "away", you could also use the numbered value: https://msdn.microsoft.com/en-us/library/office/ff864234.aspx
            '.RequiredAttendees = "johndoe@microsoft.com"
            On Error Resume Next
            .Start = myStart
            .End = myEnd
            .Subject = Cells(r, subjectColumn) & ", " & .Location
            .Attachments.Add ("c:\temp\somefile.msg")  'Add this file to the meeting/appointment, will be uploaded to Outlook
            .Location = Cells(r, locationColumn).Value
            .Body = .Subject & ", " & Cells(r, dateColumn).Value
            .ReminderSet = True
            .BusyStatus = olBusy
            .Categories = "Orange Category" 'add this to be able to delete the testappointments
            On Error GoTo 0
            .Save 'saves the new appointment to the default folder
        End With

Hope that helps a bit,

Koen

 

[WarPigl3t]

I appreciate you getting back with me. I solved it yesterday. I gave up trying to call Outlook from Excel and decided to call Excel from Outlook. Here was my solution.

[COLOR=#008000]'This VBA code needs to be entered into the VBE of Outlook.
'While in the VBE, you need to go to Tools, References, and add the Microsoft Excel 14.0 Object Library as a reference.[/COLOR]

Const firstRow_withData = 2
Const sequenceColumn = 1
Const subjectColumn = 2
Const locationColumn = 3
Const descriptionColumn = 4
Const dateColumn = 5
Const startTimeColumn = 6
Const endTimeColumn = 7
Const attendeesColumn = 8
Const myPath = "C:\Users\sean\Desktop\"
Const sheetName = "Sheet1"

Sub CreateAppt()
    myFileName = InputBox("Enter the name of the file without the path.  File must be on desktop.", "Enter File")
    If StrPtr(myFileName) = 0 Or myFileName = "" Then End
    myFile = myPath & myFileName
    
   [COLOR=#008000] 'Open Excel File[/COLOR]
    Dim strFldr As String
    Dim OutMail As Object
    Dim xlApp As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Application.Visible = False

    [COLOR=#008000]'Reference the workbook here[/COLOR]
    Set myWB = Workbooks.Open(myFile, , False, , , , , , , True)
    
    [COLOR=#008000]'Reference the worksheet here[/COLOR]
    Set myWS = myWB.Worksheets(sheetName)
    myWS.Activate
    
    Dim myItem As Object
    Dim myRequiredAttendee, myOptionalAttendee, myResourceAttendee As Outlook.Recipient
    r = firstRow_withData
    lastRow = myWS.Cells(Rows.Count, sequenceColumn).End(xlUp).Row
    Do Until r > lastRow
        DoEvents
        sequenceValue = myWS.Cells(r, sequenceColumn).Value
        subjectValue = myWS.Cells(r, subjectColumn).Value
        locationValue = myWS.Cells(r, locationColumn).Value
        descriptionValue = myWS.Cells(r, descriptionColumn).Value
        cellDateValue = myWS.Cells(r, dateColumn).Value
        startTimeValue = myWS.Cells(r, startTimeColumn).Value
        endTimeValue = myWS.Cells(r, endTimeColumn).Value
        attendeesValue = myWS.Cells(r, attendeesColumn).Value
        splitAttendees = splitAttendees_Fuction(attendeesValue)

        Set myItem = Application.CreateItem(olAppointmentItem)
        myItem.MeetingStatus = olMeeting
        myItem.Subject = subjectValue
        myItem.Location = locationValue
        myItem.Start = cellDateValue + startTimeValue
        myItem.Duration = Abs(DateDiff("n", cellDateValue + endTimeValue, cellDateValue + startTimeValue))
        myItem.Body = descriptionValue
        For Each element In splitAttendees
            Set myRequiredAttendee = myItem.Recipients.Add(element)
            myRequiredAttendee.Type = olRequired
        Next element
        myItem.Display
        myItem.Send
        r = r + 1
    Loop
    ActiveWorkbook.Close SaveChanges:=False
End Sub

Function splitAttendees_Fuction(attendeesValue)
   [COLOR=#008000] 'The attendees column in the Excel file might have a semi-colon delimiter for each attendee in a cell.[/COLOR]
    If attendeesValue Like "*;*" Then
        mySplit = Split(attendeesValue, ";")
        splitAttendees_Fuction = mySplit
        Exit Function
    End If
    Dim myArray() As Variant
    a = 0
    ReDim myArray(a)
    myArray(a) = attendeesValue
    splitAttendees_Fuction = myArray
End Function