Question

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

我使用= AddtoTasks（A1，C1，D1）调用函数，其中A1是Date，C1和Text，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

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

1 个答案: