VBA - 创建Outlook任务 - 基于动态范围的收件人

Question

截至目前，下面的函数可以工作，但是我需要将Recipient.Add字段更改为相应的电子邮件地址，每次更改。我的所有电子邮件地址都列在工作表的一列中，理想情况下，我希望该功能能够根据行自动添加正确的电子邮件。

我使用= AddtoTasks（A1，C1，D1）调用函数，其中A1是日期，C1和文本，D1是A1之前的天数，我需要提醒弹出。我所有的Outlook引用都已正确添加，只需要帮助计算出电子邮件地址即可。

的Excel和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 = "[email protected]" 
     .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

看来你需要一个参数传递给函数：

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