Question

我使用了此代码（http://www.jpsoftwaretech.com/using-excel-vba-to-set-up-task-reminders-in-outlook/）并自行添加了strRecipient字段。我是一个完整的VBA菜鸟，显然，它不起作用。任何人都可以提供一个建议，如何添加一个收件人部分，例如自动从A4单元格中取出？

由于

Option Explicit

Dim bWeStartedOutlook As Boolean

Function AddToTasks(strDate As String, strText As String, DaysOut As Integer, strRecipient As String) As Boolean
    ' Adds a task reminder to Outlook Tasks a specific number of days before the date specified
    ' Returns TRUE if successful
    ' Will not trigger OMG because no protected properties are accessed
    ' by Jimmy Pena, http://www.jpsoftwaretech.com, 10/30/2008
    '
    ' Usage:
    ' =AddToTasks("12/31/2008", "Something to remember", 30)
    ' or:
    ' =AddToTasks(A1, A2, A3)
    ' where A1 contains valid date, A2 contains task information, A3 contains number of days before A1 date to trigger task reminder
    '
    ' can also be used in VBA :
    'If AddToTasks("12/31/2008", "Christmas shopping", 30) Then
    '  MsgBox "ok!"
    'End If

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

' make sure all fields were filled in
If (Not IsDate(strDate)) Or (strText = "") Or (DaysOut <= 0) Or (strRecipient = "") Then
  AddToTasks = False
  GoTo ExitProc
End If

' We want the task reminder a certain number of days BEFORE the due date
' ex: if DaysOut = 120, then we want the due date to be -120 before the date specified
' we need to pass -120 to the NextBusinessDay function, so to go from 120 to -120,
' we subtract double the number (240) from the number provided (120).
' 120 - (120 * 2); 120 - 240 = -120

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 & ", due on: " & strDate
        .ReminderSet = True
        .Recipients.Add = strRecipient
        .Save
        .Assign
        .Send
    End With

Else
  AddToTasks = False
  GoTo ExitProc
End If

' if we got this far, it must have worked
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

在With objTask

之前添加以下内容

strRecipient = Sheets("sheet name here").Range("A4").Value

strRecipient = Sheets("sheet name here").Range("A4").Value
With objTask
    .startdate = dteDate
    .CC = strRecipient
    .Subject = strText & ", due on: " & strDate
    .ReminderSet = True
    .Save
    .Assign
    .Send
End With

Excel VBA收件人添加基于相关的单元格

1 个答案: