Option Explicit


Private Function GetMessageSeparatePos(ByRef msg As String)
    Dim msgStartPosPlain As Long
    Dim msgStartPosHTML As Long
    Dim msgStartPosRTF As Long
    Dim minPos As Long
    
    minPos = Len(msg) + 1
    
    ' For plain text mail
    msgStartPosPlain = InStr(msg, "-----Original Message-----")
    ' For HTML mail
    msgStartPosHTML = InStr(msg, " _____ ")
    If msgStartPosHTML > 1 And msgStartPosHTML + 7 <= Len(msg) Then
        If Asc(Mid(msg, msgStartPosHTML - 1, 1)) = 63 And Asc(Mid(msg, msgStartPosHTML + 7, 1)) = 63 Then
            msgStartPosHTML = msgStartPosHTML - 1
        Else
            msgStartPosHTML = 0
        End If
    End If
    ' For RTF mail
    msgStartPosRTF = InStr(msg, "_____________________________________________")
    
    If msgStartPosPlain <> 0 And msgStartPosPlain < minPos Then minPos = msgStartPosPlain
    If msgStartPosHTML <> 0 And msgStartPosHTML < minPos Then minPos = msgStartPosHTML
    If msgStartPosRTF <> 0 And msgStartPosRTF < minPos Then minPos = msgStartPosRTF
    
    If minPos = Len(msg) + 1 Then
        GetMessageSeparatePos = 0
    Else
        GetMessageSeparatePos = minPos
    End If

End Function

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

    ' Originally from http://www.danevans.co.uk/vba/
    ' Modified by Li Fanxi (lifanxi <AT> freemindworld.com)
    
    Dim oldMsgStartPos As Long
    Dim thisMsg As String
    Dim i As Integer
    Dim found As Boolean
    Dim promptMsg As String
    
    ' The array for strings that want to be detected
    ' If you add strings to this array, don't forget to change the ubound of the array in the definition
    ' The strings should be stored in lower case
    Dim pattern(2) As String
    pattern(0) = "attach"
    pattern(1) = "附件"
    pattern(2) = "enclos"
    
    found = False
    
    
    ' Find out the old message start position
    oldMsgStartPos = GetMessageSeparatePos(Item.Body)
    
    ' Get the lower case version of the message body and subject for this message
    If oldMsgStartPos = 0 Then
        thisMsg = LCase(Item.Body + " " + Item.Subject)
    Else
        thisMsg = LCase(Left(Item.Body, oldMsgStartPos) + " " + Item.Subject)
    End If
   
    ' Search each pattern in the message body and subject
    For i = LBound(pattern) To UBound(pattern)
        If InStr(thisMsg, pattern(i)) > 0 Then
            found = True
            Exit For
        End If
    Next i
    
    ' If found, prompt the user
    If found And Item.Attachments.Count = 0 Then
        promptMsg = "You have mentioned about an attachment in the message but it doesn't have one." & vbCrLf & "Send the message anyway?"
        If MsgBox(promptMsg, vbYesNo + vbDefaultButton2 + vbInformation, "You may forget the attachment") = vbNo Then
            Cancel = True
        End If
    End If
    
End Sub