Проверьте наличие дубликата напоминания из Excel - PullRequest
Новая
       31

Проверьте наличие дубликата напоминания из Excel

0 голосов
/ 02 апреля 2019

У меня есть некоторый код VBA, который создает напоминание в моем календаре Outlook из данных в Excel.Но у меня нет способа узнать, есть ли у меня напоминание в 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

1 Ответ

0 голосов
/ 02 апреля 2019

РЕДАКТИРОВАТЬ (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
...