Script to import appointments from Excel to Outlook

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
David MurrayAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

ShumsExcel & VBA ExpertCommented:
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

David MurrayAuthor 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
ShumsExcel & VBA ExpertCommented:
Could you please send me your excel file?
Your Guide to Achieving IT Business Success

The IT Service Excellence Tool Kit has best practices to keep your clients happy and business booming. Inside, you’ll find everything you need to increase client satisfaction and retention, become more competitive, and increase your overall success.

David MurrayAuthor Commented:
Shums

Here you go.
OutLook-input-test-data.xlsm
ShumsExcel & VBA ExpertCommented:
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

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
ShumsExcel & VBA ExpertCommented:
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.
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
R

From novice to tech pro — start learning today.