excel - 检查excel中的重复提醒
问题描述
我有一些 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
解决方案
编辑(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