Question

我有一些vba代码，可根据Excel中的数据在Outlook日历中创建提醒。但是我没有办法知道我是否已经在Excel中具有提醒功能。我想知道是否有人可以帮助我调整代码，以告诉我是否已经在Outlook中设置了此提醒。该提醒在主题行中将具有完全相同的文本。

Sub D_Reminders()

    Dim appOL As Object
    Dim objReminder As Object

    Set appOL = GetObject(, "Outlook.application")
    Set objReminder = appOL.CreateItem(1)
    objReminder.Start = ActiveSheet.Range("AC" & ActiveCell.Row).Value
    objReminder.Duration = 1
    objReminder.Subject = "Rate Expires for " & ActiveSheet.Range("A" & ActiveCell.Row).Value & " " & ActiveSheet.Range("B" & ActiveCell.Row).Value & " " & ActiveSheet.Range("AC" & ActiveCell.Row).Value
    objReminder.ReminderSet = True
    objReminder.Location = "N/A"
    objReminder.busystatus = olfree
    objReminder.body = "Loan Type = " & ActiveSheet.Range("I" & ActiveCell.Row).Value & "," & " Status = " & ActiveSheet.Range("BK" & ActiveCell.Row).Value & "," & " UW = " & ActiveSheet.Range("D" & ActiveCell.Row).Value & "," & " Proc = " & ActiveSheet.Range("C" & ActiveCell.Row).Value & "," & " MLO = " & ActiveSheet.Range("E" & ActiveCell.Row).Value
    objReminder.display

End Sub

Answer 1

编辑（2）：希望这可以解决问题。我们将检查日历主题的主题以查看主题是否存在，而不是检查提醒文本。如果没有，我们将其添加。

Function AppointmentTextExists(ByRef oOtlk As Object, appointmentSubjectText As String) As Boolean
    Dim oAppt As Object
    Dim oAppts As Object
    Dim output As Boolean

    output = False

    'Get all items from the calendar
    Set oAppts = oOtlk.Session.GetDefaultFolder(9).Items

    For Each oAppt In oAppts
        If oAppt.Subject = appointmentSubjectText Then
            output = True
            Exit For
        End If
    Next oAppt

    AppointmentTextExists = output
End Function

Sub D_Reminders()
    Dim appOL As Object
    Dim objReminder As Object
    Dim reminderText As String

    Set appOL = GetObject(, "Outlook.application")

    'The subject text for the reminder
    reminderText = "Rate Expires for " & ActiveSheet.Range("A" & ActiveCell.Row).Value & " " & ActiveSheet.Range("B" & ActiveCell.Row).Value & " " & ActiveSheet.Range("AC" & ActiveCell.Row).Value

    'Test if this reminder text is already in a subject line
    If AppointmentTextExists(appOL, reminderText) Then
        'Do whatever you want if the subject already exists
        'You can leave this blank if you don't want to do anything
    Else 'Subject does not exist
        Set objReminder = appOL.CreateItem(1)
        objReminder.Start = ActiveSheet.Range("AC" & ActiveCell.Row).Value
        objReminder.Duration = 1
        objReminder.Subject = "Rate Expires for " & ActiveSheet.Range("A" & ActiveCell.Row).Value & " " & ActiveSheet.Range("B" & ActiveCell.Row).Value & " " & ActiveSheet.Range("AC" & ActiveCell.Row).Value
        objReminder.ReminderSet = True
        objReminder.Location = "N/A"
        objReminder.BusyStatus = olFree
        objReminder.Body = "Loan Type = " & ActiveSheet.Range("I" & ActiveCell.Row).Value & "," & " Status = " & ActiveSheet.Range("BK" & ActiveCell.Row).Value & "," & " UW = " & ActiveSheet.Range("D" & ActiveCell.Row).Value & "," & " Proc = " & ActiveSheet.Range("C" & ActiveCell.Row).Value & "," & " MLO = " & ActiveSheet.Range("E" & ActiveCell.Row).Value
        objReminder.Display
    End If
End Sub

编辑：我进行了一些更改，将解决方案合并到您的代码中。我创建了一个单独的函数来包含用于测试主题行是否已存在的逻辑。看看是否可以从此代码中将其拼凑起来，或者写出更具体的问题。

'Function that checks to see if a reminder text already exists in Outlook
'Parameters: objOutlook     - A reference to an Outlook Objet
'            reminderText   - The lookup text
'Returns:    True/False if text exists
Function DoesReminderExist(ByRef objOutlook As Object, reminderText As String) As Boolean
    Dim oRem As Object
    Dim output As Boolean

    'Initially set output to false (in case reminder text isn't found)
    output = False

    'Loop through all reminders in Outlook, and test for equality
    For Each oRem In objOutlook.Reminders
        'Reminder text matches in outlook
        If oRem.Subject = reminderText Then
            output = True
            Exit For
        End If
    Next oRem

    'Return T/F output
    DoesReminderExist = output
End Function

Sub D_Reminders()
    Dim appOL As Object
    Dim objReminder As Object
    Dim reminderText As String

    Set appOL = GetObject(, "Outlook.application")

    'The subject text for the reminder
    reminderText = "Rate Expires for " & ActiveSheet.Range("A" & ActiveCell.Row).Value & " " & ActiveSheet.Range("B" & ActiveCell.Row).Value & " " & ActiveSheet.Range("AC" & ActiveCell.Row).Value

    'Test if this reminder text is already in a subject line
    If DoesReminderExist(appOL, reminderText) Then
        'Do whatever you want if the subject already exists
        'You can leave this blank if you don't want to do anything
    Else 'Subject does not exist
        Set objReminder = appOL.CreateItem(1)
        objReminder.Start = ActiveSheet.Range("AC" & ActiveCell.Row).Value
        objReminder.Duration = 1
        objReminder.Subject = "Rate Expires for " & ActiveSheet.Range("A" & ActiveCell.Row).Value & " " & ActiveSheet.Range("B" & ActiveCell.Row).Value & " " & ActiveSheet.Range("AC" & ActiveCell.Row).Value
        objReminder.ReminderSet = True
        objReminder.Location = "N/A"
        objReminder.BusyStatus = olFree
        objReminder.Body = "Loan Type = " & ActiveSheet.Range("I" & ActiveCell.Row).Value & "," & " Status = " & ActiveSheet.Range("BK" & ActiveCell.Row).Value & "," & " UW = " & ActiveSheet.Range("D" & ActiveCell.Row).Value & "," & " Proc = " & ActiveSheet.Range("C" & ActiveCell.Row).Value & "," & " MLO = " & ActiveSheet.Range("E" & ActiveCell.Row).Value
        objReminder.Display
    End If
End Sub

下面的代码将获取提醒列表及其相应的文本。您可以将其与代码进行比较以测试是否相等，然后根据需要忽略/更新。

Sub GetReminders()
    Dim appOl As Object
    Dim oRem As Object

    Set appOl = GetObject(, "Outlook.Application")

    For Each oRem In appOl.Reminders
        Debug.Print "Caption: " & oRem.Caption
    Next oRem

End Sub

检查来自Excel的重复提醒

1 个答案: