[VBA] Macro per rilevare gli allegati mancanti Outlook 2010

[Raid]

Mettere in ThisOutlookSession

Code: [Select]

'SUB per verificare la presenza della parola ALLEG e ATTACH nel messaggio
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

'per il codice che cerca ALLEG
Dim answer As Variant

'per il codice che cerca ATTACH
Dim lngPos As Long
Dim strText As String
Dim strSearchText As String
Dim lngStringCount As Long
lngPos = 1
lngStringCount = 0
   
'Facciamo prima cercare gli allegati
   If InStr(1, Item.Body, "alleg", vbTextCompare) > 0 Then
        If Item.Attachments.count = 0 Then
          answer = MsgBox("E' stato rilevata la parola Allegato ma non è presente nessun allegato, inviare comunque?", vbYesNo)
            If answer = vbNo Then
                Cancel = True
            End If
        End If
'Se non ci sono allegati, cerchiamo gli attachments
    Else
        Do
            lngPos = InStr(lngPos, Item.Body, "attach")
            If lngPos > 0 Then
                lngStringCount = lngStringCount + 1
                lngPos = lngPos + Len("alleg")
            End If
        Loop Until lngPos = 0

        'MsgBox lngStringCount & " occorrenze"

' >3 perchè nella firma compare 3 volte quindi devo ignorare le prime 3 volte       
        If lngStringCount > 3 Then
            answer = MsgBox("E' stato rilevata la parola Attachment ma non è presente nessun allegato, inviare comunque?", vbYesNo)
            If answer = vbNo Then
                Cancel = True
            End If
        End If

    End If

End Sub