Create outlook task from excel

[gotido]

Hello

I have a gym and i want to create a worksheet that reminds me when i should contact a member to upgrade is training plan.

This is the workbook:


The ideia is that i insert the delivery date and then it gives me automaticly the 1º contact, 2 contact, 3 contact and 4 contact, each one with 30 days diference.

then, when i click create reminder, the macro will read the last written row and creates an outlook reminder/task.

Could someone hepl me with this, please?

thanks


https://www.dropbox.com/s/ifr2k5oww7moocu/Outlook%20reminder.xlsm?dl=0

 

[Worf]

Welcome to the Board

' sheet module
Function AddOlTask(sSubject$, sBody$, Due As Date, remdat As Date)
On Error GoTo Error_Handler
Dim OlApp As Object, OlTask As Object
Set OlApp = CreateObject("Outlook.Application")
Set OlTask = OlApp.CreateItem(3)
With OlTask
    .Subject = sSubject
    .DueDate = Due
    .Status = 1                 '0=not started, 1=in progress, 2=complete, 3=waiting
    .Importance = 1             '0=low, 1=normal, 2=high
    .ReminderSet = True
    .ReminderTime = remdat
    .Categories = "Business"
    .Body = sBody
    .display:    .Save
End With
Error_Handler_Exit:
    On Error Resume Next
    Set OlTask = Nothing:    Set OlApp = Nothing
    Exit Function
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: AddOlkTask" & vbCrLf & "Error Description: " & _
    Err.Description, vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function


Sub CreateTask()                                                                     ' button code
Dim r, LR%
LR = Range("b" & Rows.Count).End(xlUp).Row                                           ' last row
r = AddOlTask(Cells(LR, 3), "Upgrade Plan", Cells(LR, 5), CDate(Cells(LR, 5) - 2))   ' first contact
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
Dim i%
If Target.Column = 2 And Target.Row > 5 Then                    ' delivery date
    For i = 1 To 4
        Cells(Target.Row, 3 + 2 * i) = CDate(Target + 30 * i)   ' contact dates
    Next
End If
End Sub

 

[gotido]

thank you for your answer.
im sorry im a newbie.
where do i put this code in vba.
i´ve copied to general and then i press play and it works but when i click the button it doesn work. and instead of automaticly insert on outlook it opnes the task...

 

[gotido]

ive suceed at using the code but it only gives me the first date
how can i add the other three?

 

[gotido]

and last...instead of a task can it be a calendar entry?

 

[Worf]

New version:

' sheet module
' add a reference to Microsoft Outlook Object Library
Function AddCal(subj$, sBody$, Due As Date)
Dim OlApp As Object, a As AppointmentItem
Set OlApp = CreateObject("Outlook.Application")
Set a = OlApp.CreateItem(olAppointmentItem)
With a
    .MeetingStatus = olNonMeeting
    .Start = Due
    .Subject = subj
    .Importance = 1
    .ReminderSet = True
    .Categories = "Business"
    .Body = sBody
    .Save
End With
End Function


Sub CreateTask()                                                                     ' button code
Dim r, LR%, i%
LR = Range("b" & Rows.Count).End(xlUp).Row                                           ' last row
For i = 1 To 4
    r = AddCal(Cells(LR, 3), "Upgrade Plan", CDate(Cells(LR, 3 + 2 * i)))
Next
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
Dim i%
If Target.Column = 2 And Target.Row > 5 Then                    ' delivery date
    For i = 1 To 4
        Cells(Target.Row, 3 + 2 * i) = CDate(Target + 30 * i)   ' contact dates
    Next
End If
End Sub

 

[gotido]

Thank you so much for your help.
It gives me an error "compile Error: user-defined type not defined" in ths line:
Function AddCal(subj$, sBody$, Due As Date)
Dim OlApp As Object, a As AppointmentItem

what can i do to solve it?

 

[gotido]

i solved the problem. i neededd to activate the refetrences in libraries to Outlook.

Now the problem is the date. When i put the date it creates a task the year 1899!?

 

[Worf]

Maybe it is pulling data from a blank cell, are you still using merged cells?
The code below should help identifying the issue.

Sub CreateTask()                                                       ' button code
Dim r, LR%, i%, c As Range
LR = Range("b" & Rows.Count).End(xlUp).Row                             ' last row
For i = 1 To 4
    Set c = Cells(LR, 3 + 2 * i)
    MsgBox "Creating entry from cell " & c.Address & " with date " & CDate(c)
    r = AddCal(Cells(LR, 3), "Upgrade Plan", CDate(c))
Next
End Sub

 

[gotido]

Thank you again...it worked really well.

One last, and it´s really the last thing.

Ist there any possibility that, in here
r = AddCal(Cells(LR, 3), "Upgrade Plan", CDate(Cells(LR, 3 + 2 * i)))

it can also add the value of the first cell of the same row? ie, it gives this message, "upgrade plan, member "1234""

Thanks again...