VBA - Outlook Task Creation - Recipient based on Dynamic Range

Question

As of right now, the below function works, however I need to change the Recipient.Add field to the corresponding email address, with each change. All of my email address are listed in a column on the worksheet, and ideally I would like the function to just automatically add the correct email based on the Row.

I am calling the function using =AddtoTasks(A1,C1,D1) where A1 is the Date, C1, and the Text, and D1, is the amount of days prior to A1, I need the reminder to pop up. All of my Outlook References are correctly added, just need help figuring out the email address.

Excel and Outlook 2010

Option Explicit


Dim bWeStartedOutlook As Boolean

Function AddToTasks(strDate As String, strText As String, DaysOut As Integer) As Boolean

Dim intDaysBack As Integer
Dim dteDate As Date
Dim olApp As Object ' Outlook.Application
Dim objTask As Object ' Outlook.TaskItem

If (Not IsDate(strDate)) Or (strText = "") Or (DaysOut <= 0) Then
  AddToTasks = False
  GoTo ExitProc
End If


intDaysBack = DaysOut - (DaysOut * 2)

dteDate = CDate(strDate) + intDaysBack

On Error Resume Next
  Set olApp = GetOutlookApp
On Error GoTo 0

If Not olApp Is Nothing Then
  Set objTask = olApp.CreateItem(3)  ' task item

    With objTask
        .StartDate = dteDate
        .Subject = strText & ", Audit Start Date: " & strDate
        .ReminderSet = True
        .Recipients.Add = "you@mail.com"
        .Save
        .Assign
        .Send
    End With

Else
  AddToTasks = False
  GoTo ExitProc
End If

AddToTasks = True

ExitProc:
If bWeStartedOutlook Then
  olApp.Quit
End If
Set olApp = Nothing
Set objTask = Nothing
End Function

Function GetOutlookApp() As Object

On Error Resume Next
  Set GetOutlookApp = GetObject(, "Outlook.Application")
  If Err.Number <> 0 Then
    Set GetOutlookApp = CreateObject("Outlook.Application")
    bWeStartedOutlook = True
  End If
On Error GoTo 0

End Function

Answer 1

It seems you need to pass one more parameter to the function:

Option Explicit


Dim bWeStartedOutlook As Boolean

Function AddToTasks(strDate As String, strText As String, DaysOut As Integer, email as String) As Boolean

Dim intDaysBack As Integer
Dim dteDate As Date
Dim olApp As Object ' Outlook.Application
Dim objTask As Object ' Outlook.TaskItem

If (Not IsDate(strDate)) Or (strText = "") Or (DaysOut <= 0) Then
  AddToTasks = False
  GoTo ExitProc
End If


intDaysBack = DaysOut - (DaysOut * 2)

dteDate = CDate(strDate) + intDaysBack

On Error Resume Next
  Set olApp = GetOutlookApp
On Error GoTo 0

If Not olApp Is Nothing Then
  Set objTask = olApp.CreateItem(3)  ' task item

    With objTask
        .StartDate = dteDate
        .Subject = strText & ", Audit Start Date: " & strDate
        .ReminderSet = True
        .Recipients.Add(email)
        .Recipients.ResolveAll()
        .Save
        .Assign
        .Send
    End With

Else
  AddToTasks = False
  GoTo ExitProc
End If

AddToTasks = True

ExitProc:
If bWeStartedOutlook Then
  olApp.Quit
End If
Set olApp = Nothing
Set objTask = Nothing
End Function

Function GetOutlookApp() As Object

On Error Resume Next
  Set GetOutlookApp = GetObject(, "Outlook.Application")
  If Err.Number <> 0 Then
    Set GetOutlookApp = CreateObject("Outlook.Application")
    bWeStartedOutlook = True
  End If
On Error GoTo 0

End Function