在邮件正文中查找日期并使用它在 Outlook 日历中设置提醒

Question

目前，我在所有已发送的项目上运行一个宏，以检查我是否正在向特定客户发送电子邮件。如果是，它会检查是否存在客户对所有消息的要求之一，如果不是，它会询问是否需要“下一次更新到期”。见下文；

Public Sub application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim addrType
Dim addr
Dim recip

For Each recip In Item.Recipients
If recip.Type = olTo Then
    addrType = recip.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3002001F")
        If addrType = "EX" Then
            addr = recip.AddressEntry.GetExchangeUser.PrimarySmtpAddress
        Else
            addr = recip.Address
        End If
If LCase(addr) = "relevantemail1@outlook.com" Or LCase(addr) = "relevantemail2@outlook.com" Then
    If InStr(1, Item.Body, LCase("next update due"), vbTextCompare) > 0 Then

        Call errhandler
        Else
        'ask if we've added the date
            prompt$ = "You're sending this to company x and have not added a 'next update due' date, do you need to add one?"
            If MsgBox(prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check Address") = vbYes Then
                Cancel = True
            End If
Exit For
    End If
End If
End If
Next

End Sub

我仍然真正掌握了其中的 Outlook VBA 和字符串函数等基础知识。所以我的问题是：我可以在文本“下一次更新到期：”之后找到字符串（理想情况下我想要一个格式化的日期，但暂时可以使用一个字符串）？本质上，总会有两个分隔符“：”来开始日期，回车结束日期。一旦我可以检索到它，我就可以将相关信息导出到一个 excel 文档中，但是我正在为字符串/日期的初始检索而苦苦挣扎。

希望你们能提供帮助，如果需要，非常乐意扩展上述代码。

Answer 1

相对简单的正则表达式可用于从正文中提取特定的日期模式

"next update due:(*):"

你的结果会被括号括起来

或使用特定的日期格式：

"next update due:*(\d\d\/\d\d\/\d\d)*:"

如果你的日期是 10/01/15

Answer 2

我对您的代码进行了一些更改，希望它能让您走上正轨。

一些观察可以帮助您编写代码。

• 总是将长代码分解成更小的函数来帮助您
• 始终声明变量
• 总是写 cmets 来帮助你。

这是我希望对您有帮助的代码

Public Sub application_ItemSend(ByVal Item As Object, Cancel As Boolean)

    Dim strAddress As String
    Dim oRecipient As Recipient
    Dim strNextDueDate As String

    For Each oRecipient In Item.Recipients
        If oRecipient.Type = olTo Then

            ' Get the address
            strAddress = GetAddress(oRecipient)

            ' Check the adress for de
            If HasToBeChecked(strAddress) Then
                If InStr(1, Item.Body, LCase("next update due"), vbTextCompare) > 0 Then

                    'Get the value for the date.
                    strNextDueDate = GetStringBetweenStrings(Item.Body, "next update due:", vbCr)

                    ' ------------------------------------------
                    ' The rest of your code here.....
                    ' ------------------------------------------
                    'Call errhandler
                Else
                    'ask if we've added the date
                    prompt$ = "You're sending this to company x and have not added a 'next update due' date, do you need to add one?"
                    If MsgBox(prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check Address") = vbYes Then
                        Cancel = True
                    End If
                    Exit For
                End If
            End If
        End If
    Next

End Sub

' Fucntion to check if the address should be chnaged.
' We have it as a separate function so we can add more
' emails if needed.
Function HasToBeChecked(ByVal strAddress As String)

    Dim arrAddresses As Variant
    Dim i As Long
    Dim ret As Boolean

    ' Load the array of addresses
    arrAddresses = Array("relevantemail1@outlook.com", "relevantemail2@outlook.com")

    For i = LBound(arrAddresses) To UBound(arrAddresses)
        If LCase$(strAddress) = LCase$(arrAddresses(i)) Then
            ret = True
            Exit For
        End If
    Next i

    'Return the value
    HasToBeChecked = ret
End Function

' Function to retrive the address from a recipient object
Function GetAddress(ByRef oRecipient As Recipient) As String

    Const strSCHEMA_PROPERTY_TYPE As String = "http://schemas.microsoft.com/mapi/proptag/0x3002001F"

    Dim strAddresType As String
    Dim ret As String

    ' Get the address accoring to if it's an excahnge or a regular email
    strAddresType = oRecipient.PropertyAccessor.GetProperty(strSCHEMA_PROPERTY_TYPE)
    If addrType = "EX" Then
        ret = oRecipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
    Else
        ret = oRecipient.Address
    End If

    ' Return the value
    GetAddress = ret

End Function

' Function to get he string between teo strings
Function GetStringBetweenStrings(ByVal strToCheck As String, _
                                 ByVal strStart As String, _
                                 ByVal strEnd As String) As String

    Dim lPosStart As Long
    Dim lPostEnd As Long
    Dim ret As String

    lPosStart = InStr(1, strToCheck, strStart)
    If Not lPosStart = 0 Then
        lPosStart = lPosStart + Len(strStart) + 1
        lPostEnd = InStr(lPosStart, strToCheck, strEnd)

        If Not lPostEnd = 0 Then
            ret = Mid$(strToCheck, lPosStart, lPostEnd - lPosStart)
        End If
    End If

    ' Return the value
    GetStringBetweenStrings = ret

End Function

谢谢