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 = "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

看來你需要一個參數傳遞給函數：

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