Macro to create Outlook appointment from excel file

[blandreth]

Let me start by saying I know nothing about writing code for macros and I do not have code to start with for what I'm looking for help with. The most I have done with macro coding is modify code for specific file paths or cell designations.

Now that I have that out of the way, I'm looking for code to run a macro that will pull a cell from an Excel file that contains a date and match that date in Outlook then create an all day appointment on this date with .5 day reminder. The subject line of the appointment would be the title of the Excel file that is shown in another cell in the form. Ultimately, I would like to run the macro so that it is run in the background without having to acknowledge anything in Outlook to create this appointment. I am currently using Office 2016. This Excel file would also be used by multiple people. I would want the macro to create the appointment in the users Outlook.

Any help would be greatly appreciated.

Thanks!

 

[lrobbo314]

This will get you started. There is too much we don't know to go much further. If this is running in the background without the user's knowledge, there are questions like, how does the code decide to create an appointment. Is it anytime the user adds a value to a certain column?

Either way, here is the code.

Sub CreateAppt()
On Error GoTo erHandle
Dim olApp As Object
Dim olItem As Object
Dim dt As Date


dt = ActiveCell.Value 'Change to range with date
Set olApp = CreateObject("Outlook.Application")
Set olItem = olApp.CreateItem(olAppointmentItem)


With olItem
    .Subject = Range("A1") 'Change to cell that has value for subject
    .Body = "Appointment Details" 'Can refer to another cell in sheet, i.e. range("A2")
    .ReminderMinutesBeforeStart = 12 * 60 '12 hours times 60 minutes
    .Start = dt
    .End = dt
    .AllDayEvent = True
    .Save
End With


Exit Sub


erHandle:
If Err.Number = 13 Then
    MsgBox "Active cell must containt a date", vbCritical
Else
    MsgBox "Error #" & Err.Number & vbCrLf & Err.Description
End If
End Sub

 

[blandreth]

Thank you for the reply. I'm confused on the line that states 'change to range with date. Do I replace my information for this phrase or is there something else I'm supposed to include? The cell I will pull the date from is B13. Also, I will run/activate this macro with a button in the form. Once the button is pushed it would run this macro in the background.

Again, I appreciate your feedback. Please let me know if you need any further information.

Brian

This will get you started. There is too much we don't know to go much further. If this is running in the background without the user's knowledge, there are questions like, how does the code decide to create an appointment. Is it anytime the user adds a value to a certain column?

Either way, here is the code.

Sub CreateAppt()
On Error GoTo erHandle
Dim olApp As Object
Dim olItem As Object
Dim dt As Date


dt = ActiveCell.Value 'Change to range with date
Set olApp = CreateObject("Outlook.Application")
Set olItem = olApp.CreateItem(olAppointmentItem)


With olItem
    .Subject = Range("A1") 'Change to cell that has value for subject
    .Body = "Appointment Details" 'Can refer to another cell in sheet, i.e. range("A2")
    .ReminderMinutesBeforeStart = 12 * 60 '12 hours times 60 minutes
    .Start = dt
    .End = dt
    .AllDayEvent = True
    .Save
End With


Exit Sub


erHandle:
If Err.Number = 13 Then
    MsgBox "Active cell must containt a date", vbCritical
Else
    MsgBox "Error #" & Err.Number & vbCrLf & Err.Description
End If
End Sub

 

[lrobbo314]

All I meant was that you could change the line of code to refer to a cell with the date. Here is the updated code referring to cell B13. Likewise, you can change the .Subject and .Body lines to refer to cells in the workbook. Or, you can hard code text in there the way the .Body line is now.

Private Sub CommandButton1_Click()
On Error GoTo erHandle
Dim olApp As Object
Dim olItem As Object
Dim dt As Date


dt = Range("B13").Value
Set olApp = CreateObject("Outlook.Application")
Set olItem = olApp.CreateItem(1)


With olItem
    .Subject = Range("A1") 'Change to cell that has value for subject
    .Body = "Appointment Details" 'Can refer to another cell in sheet, i.e. range("A2")
    .ReminderMinutesBeforeStart = 12 * 60 '12 hours times 60 minutes
    .Start = dt
    .End = dt
    .AllDayEvent = True
    .Save
End With


Exit Sub


erHandle:
If Err.Number = 13 Then
    MsgBox "Active cell must containt a date", vbCritical
Else
    MsgBox "Error #" & Err.Number & vbCrLf & Err.Description
End If
End Sub

 

[blandreth]

Oh OK. As previously state, I know nothing about writing code.

I copied the code in my form, however it won't let me run the macro. It gives me this error message: "Cannot run the macro "Quality Alert.xlsm'!CreateAppt.CreateAppt'. The macro may not be available in this workbook or all macros may be disabled." I know my macros are turned on, because I used another one in this workbook to create information before trying to create the appointment.

Thanks again for your help!!

 

[lrobbo314]

On your userform, create a button. Then right click the button and select view code. Then paste the following in between Private Sub CommandButton and End Sub...

On Error GoTo erHandle
Dim olApp As Object
Dim olItem As Object
Dim dt As Date


dt = Range("B13").Value
Set olApp = CreateObject("Outlook.Application")
Set olItem = olApp.CreateItem(1)


With olItem
    .Subject = Range("A1") 'Change to cell that has value for subject
    .Body = "Appointment Details" 'Can refer to another cell in sheet, i.e. range("A2")
    .ReminderMinutesBeforeStart = 12 * 60 '12 hours times 60 minutes
    .Start = dt
    .End = dt
    .AllDayEvent = True
    .Save
End With


Exit Sub


erHandle:
If Err.Number = 13 Then
    MsgBox "Active cell must containt a date", vbCritical
Else
    MsgBox "Error #" & Err.Number & vbCrLf & Err.Description
End If

Let me know if that works.

 

[blandreth]

I copied as you stated, however it did not work. Usually I can click on my button and assign the macro to it, however it is not even showing up in my list. When I click assign macro after right clicking it gives me a list of macros already in the file and then next to the selection box it gives me the option to create a new macro. I'm not sure what is going on, it has worked for me for all of the other macros this way.

 

[lrobbo314]

I see. I thought you were using a userform. It seems like you're using an activeX control. Ok, create a new module and paste the code below...

Sub CreateAppt()
On Error GoTo erHandle
Dim olApp As Object
Dim olItem As Object
Dim dt As Date


dt = Range("B13").Value
Set olApp = CreateObject("Outlook.Application")
Set olItem = olApp.CreateItem(1)


With olItem
    .Subject = Range("A1") 'Change to cell that has value for subject
    .Body = "Appointment Details" 'Can refer to another cell in sheet, i.e. range("A2")
    .ReminderMinutesBeforeStart = 12 * 60 '12 hours times 60 minutes
    .Start = dt
    .End = dt
    .AllDayEvent = True
    .Save
End With


Exit Sub


erHandle:
If Err.Number = 13 Then
    MsgBox "Active cell must containt a date", vbCritical
Else
    MsgBox "Error #" & Err.Number & vbCrLf & Err.Description
End If
End Sub

Then you should be able to assign the macro 'CreateAppt' the way you explained.

 

[blandreth]

PERFECT!!!! That worked.

Thank you so much for your help!!!

Have a great day!

 

[lrobbo314]

You're welcome. Happy to help. And welcome to the forum!