VBA

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

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

VBA - Outlook Task Creation - Recipient based on Dynamic Range

excel

excel-2010