Script to import appointments from Excel to Outlook

David Murray
David Murray used Ask the Experts™
on
Thanks in advance to all. ( I am a novice VBA user)

I trying to right a script that will import appointments in into Outlook 2016 from excel 2016. I have add some lines to the follow, but still no Joy.

What I would like to do is use the headings ,  to import, update the group calendar.

Subject      Categories            Location                        Start Date      Start Time      End Date      End Time      Description      Required Attendees      Show Time As      Reminder Set      Remind Beforehand      



Sub RegisterAppointmentList()
    ‘ adds a list of appontments to the Calendar in Outlook
    Dim olApp As Outlook.Application
    Dim olAppItem As Outlook.AppointmentItem
    Dim r As Long
   
    On Error Resume Next
    Worksheets("Schedule").Activate

    Set olApp = GetObject("", "Outlook.Application")
    On Error GoTo 0
    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
    r = 6 ‘ first row with appointment data in the active worksheet
    Dim mysub, myStart, myEnd
    While Len(Cells(r, 2).Text) <> 0
        mysub = Cells(r, 2) & ", " & Cells(r, 3)
        myStart = DateValue(Cells(r, 5).Value) + Cells(r, 6).Value
        myEnd = DateValue(Cells(r, 5).Value) + Cells(r, 7).Value
        ‘DeleteTestAppointments mysub, myStart, myEnd
        Set olAppItem = olApp.CreateItem(olAppointmentItem) ‘ creates a new appointment
        With olAppItem
            ‘ set default appointment values
            .Location = Cells(r, 3)
            .Body = "" 
            .ReminderSet = True
            .BusyStatus = olFree
            ‘.RequiredAttendees = "johndoe@microsoft.com"
            On Error Resume Next
            .Start = myStart
            .End = myEnd
            .Subject = Cells(r, 2) & ", " & .Location
            .Attachments.Add ("c:\temp\somefile.msg")
            .Location = Cells(r, 3).Value
            .Body = .Subject & ", " & Cells(r, 4).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
        r = r + 1
    Wend
    Set olAppItem = Nothing
    Set olApp = Nothing
    MsgBox "Done !"
End Sub


Once again thanks for any help.

Dave
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
ShumsManaging Director/Excel VBA Developer
Distinguished Expert 2018

Commented:
This Example illustrates how to import appointment items from EXCEL file. Assuming that XLS file is in following format: Subject, Contact, Categories, Start_Date, End_Date, Start_Time, End_Time, Reminder. Possible Values for Reminder Field is :'No Reminder','0 Minutes','1 Day','2 Days', '1 Week' Yes you can modify the code according to your requirements:
Sub ImportAppointments()
    Dim exlApp As Excel.Application
    Dim exlWkb As Workbook
    Dim exlSht As Worksheet
    Dim rng As Range
     
    Dim itmAppt As Outlook.AppointmentItem
    Dim aptPtrn As Outlook.RecurrencePattern
     
    Dim fso As FileSystemObject
    Dim fl As File
     
    Set exlApp = New Excel.Application
     
    strFilepath = exlApp.GetOpenFilename
    If strFilepath = False Then
        exlApp.Quit
        Set exlApp = Nothing
        Exit Sub
    End If
     
    Set exlSht = Excel.Application.Workbooks.Open(strFilepath).Worksheets(1)
    Dim iRow As Integer
    Dim iCol As Integer
     
    Dim tmpItm As Outlook.Link
    Dim mpiFolder As MAPIFolder
    Dim oNs As NameSpace
     
    Set oNs = Outlook.GetNamespace("MAPI")
     
    Set mpiFolder = oNs.GetDefaultFolder(olFolderContacts)
     
    iRow = 2
    iCol = 1
     
    While exlSht.Cells(iRow, 1) <> ""
        Dim cnct As ContactItem
        Set itmAppt = Outlook.CreateItem(olAppointmentItem)
        itmAppt.Subject = exlSht.Cells(iRow, 1)
        Set cnct = mpiFolder.Items.Find("[FullName] = " & exlSht.Cells(iRow, 2))
        If cnct Is Nothing Then
            Set cnct = Outlook.CreateItem(olContactItem)
            cnct.FullName = exlSht.Cells(iRow, 2)
            cnct.Save
        End If
        itmAppt.Categories = exlSht.Cells(iRow, 3)
        itmAppt.Start = exlSht.Cells(iRow, 4)
        itmAppt.AllDayEvent = True
         
        itmAppt.Links.Add cnct
        Set aptPtrn = itmAppt.GetRecurrencePattern
        aptPtrn.StartTime = exlSht.Cells(iRow, 5)
        aptPtrn.EndTime = exlSht.Cells(iRow, 6)
        aptPtrn.RecurrenceType = olRecursYearly
        aptPtrn.NoEndDate = True
        If aptPtrn.Duration > 1440 Then aptPtrn.Duration = aptPtrn.Duration - 1440
        Select Case exlSht.Cells(iRow, 7)
        Case "No Reminder"
            itmAppt.ReminderSet = False
        Case "0 minutes"
            itmAppt.ReminderSet = True
            itmAppt.ReminderMinutesBeforeStart = 0
        Case "1 day"
            itmAppt.ReminderSet = True
            itmAppt.ReminderMinutesBeforeStart = 1440
        Case "2 days"
            itmAppt.ReminderSet = True
            itmAppt.ReminderMinutesBeforeStart = 2880
        Case "1 week"
            itmAppt.ReminderSet = True
            itmAppt.ReminderMinutesBeforeStart = 10080
        End Select
        itmAppt.Save
        iRow = iRow + 1
    Wend
    Excel.Application.Workbooks.Close
    exlApp.Quit
    Set exlApp = Nothing
MsgBox "Done !"

End Sub

Open in new window

Author

Commented:
Hi Shums

Thank you very much for your prompt answer.

I am probaly missing something, I can not get past this error.

Line 7      Dim tmpItm As Outlook.Link

Tells me user-type not defined
ShumsManaging Director/Excel VBA Developer
Distinguished Expert 2018

Commented:
Could you please send me your excel file?
Ensure you’re charging the right price for your IT

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!

Author

Commented:
Shums

Here you go.
OutLook-input-test-data.xlsm
Managing Director/Excel VBA Developer
Distinguished Expert 2018
Commented:
Hi David,

Please try attached....I re-arranged the columns as per above VBA code, but I can't test as I am not using Outlook.

Please check and let me know
OutLook-input-test-data_V2.xlsm
ShumsManaging Director/Excel VBA Developer
Distinguished Expert 2018

Commented:
No comment has been added to this question in more than 14 days, so it is now classified as abandoned.

I have recommended this question be closed as follows:
Force Accept: Shums (42003479)

If you feel this question should be closed differently, post an objection and a moderator will read all objections and then close it as they feel fit. If no one objects, this question will be closed automatically the way described above.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial