• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Vba to check name in the body and email ID.

JD


Check this!!!


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

Dim strSubject As String
Dim StrTo As String
Dim strBody As String
Dim mypeople As Variant, i As Integer, m As Integer

On Error GoTo e
strSubject = Item.Subject
StrTo = Item.To
strBody = Mid(Item.Body, InStr(Item.Body, " ") + 1, InStr(Item.Body, ",") - InStr(Item.Body, " ") - 1)
On Error GoTo 0

mypeople = Array("abc@xyz.com", "abc1@xyz.com", "abc2@xyz.com", "abc3@xyz.com", "abc4@xyz.com", "abc5@xyz.com", "abc6@xyz.com", "abc7@xyz.com", "abc8@xyz.com", "abc9@xyz.com", "abc10@xyz.com", "abc11@xyz.com", "abc12@xyz.com", "abc13@xyz.com", "abc14@xyz.com", "abc15@xyz.com", "abc16@xyz.com", "abc17@xyz.com", "abc18@xyz.com", "abc19@xyz.com", "abc20@xyz.com")

Dim mail As Outlook.MailItem
Set mail = Item

Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Dim StrEmail As String
Const PR_SMTP_ADDRESS As String = _
        "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = mail.Recipients
    For Each recip In recips
        Set pa = recip.PropertyAccessor
        StrEmail = StrEmail & "," & pa.GetProperty(PR_SMTP_ADDRESS)
    Next
   
StrEmail = Mid(StrEmail, 2)

For i = LBound(mypeople) To UBound(mypeople)
    If InStr(LCase(StrTo), mypeople(i)) Then m = m + 1
Next i

If Not m - 1 <> (Len(StrTo) - Len(Replace(StrTo, ";", ""))) Then Exit Sub

Prompt$ = "Verify it " & vbNewLine & "Subject - " & strSubject & vbNewLine & _
            "Mail to - " & StrEmail & vbNewLine & _
            "Person - " & strBody & vbNewLine & vbNewLine & "Are you sure you want to send the Mail?"

If MsgBox(Prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Email Confirmation") = vbNo Then Cancel = True
Exit Sub

e:
Cancel = True
MsgBox "Pls Recheck as per pattern : To[@], Subject[<>], Body[ ,]"
End Sub

Ref : https://msdn.microsoft.com/en-us/library/office/ff868695.aspx
 
Hi Deepak

It is still throwing pop-up msg :(:(:(

mypeople = Array("Jagdev.Sinder@******.com", "Sinder, Jagdev", "Sinder, Jagdev <Jagdev.Sinder@******.com>", "jagdevsingh87@gmail.com", "abc4@xyz.com", "abc5@xyz.com", "abc6@xyz.com", "abc7@xyz.com", "abc8@xyz.com", "abc9@xyz.com", "abc10@xyz.com", "abc11@xyz.com", "abc12@xyz.com", "abc13@xyz.com", "abc14@xyz.com", "abc15@xyz.com", "abc16@xyz.com", "abc17@xyz.com", "abc18@xyz.com", "abc19@xyz.com", abc20@xyz.com)

I tried all the permutation.

Regards,
JD
 
Just tested & found working...

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

Dim strSubject As String
Dim StrTo As String
Dim strBody As String
Dim mypeople As Variant, i As Integer, m As Integer

On Error GoTo e
strSubject = Item.Subject
StrTo = Item.To
strBody = Mid(Item.Body, InStr(Item.Body, " ") + 1, InStr(Item.Body, ",") - InStr(Item.Body, " ") - 1)
On Error GoTo 0

mypeople = Array(".kumar@******", "abc@xyz.com", "abc1@xyz.com", "abc2@xyz.com", "abc3@xyz.com", "abc4@xyz.com", "abc5@xyz.com", "abc6@xyz.com", "abc7@xyz.com", "abc8@xyz.com", "abc9@xyz.com", "abc10@xyz.com", "abc11@xyz.com", "abc12@xyz.com", "abc13@xyz.com", "abc14@xyz.com", "abc15@xyz.com", "abc16@xyz.com", "abc17@xyz.com", "abc18@xyz.com", "abc19@xyz.com", "abc20@xyz.com")

Dim mail As Outlook.MailItem
Set mail = Item

Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Dim StrEmail As String
Const PR_SMTP_ADDRESS As String = _
        "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = mail.Recipients
    For Each recip In recips
        Set pa = recip.PropertyAccessor
        StrEmail = StrEmail & "," & pa.GetProperty(PR_SMTP_ADDRESS)
    Next
 
StrEmail = Mid(StrEmail, 2)

For i = LBound(mypeople) To UBound(mypeople)
    If InStr(LCase(StrEmail), mypeople(i)) Then m = m + 1
Next i

If Not m - 1 <> (Len(StrEmail) - Len(Replace(StrEmail, ",", ""))) Then Exit Sub

Prompt$ = "Verify it " & vbNewLine & "Subject - " & strSubject & vbNewLine & _
            "Mail to - " & StrEmail & vbNewLine & _
            "Person - " & strBody & vbNewLine & vbNewLine & "Are you sure you want to send the Mail?"

If MsgBox(Prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Email Confirmation") = vbNo Then Cancel = True
Exit Sub

e:
Cancel = True
MsgBox "Pls Recheck as per pattern : To[@], Subject[<>], Body[ ,]"
End Sub
 
Hi Deepak

Sorry for reposting one query here.

I was trying to find the way to display the list of attachment in the above code.

The code for attachment is - Item.Attachments

It works for count only. Isn’t there any way to display the name of the attached document.

Regards,

JD
 
Hi Deepak

The above link is used to attached the document. I want to display the name of the attached document with the other info in the pop-up msg.

Regards,
JD
 
Hi Deepak

I tried to incorporate the above code in our code, but failed to make it workable. Could you please guide me with it.

Regards,
JD
 
Jagdev Singh said:
Hi Deepak

I tried to incorporate the above code in our code, but failed to make it workable. Could you please guide me with it.

Regards,
JD
Click to expand...

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

Dim strSubject As String
Dim StrTo As String
Dim strBody As String
Dim mypeople As Variant, i As Integer, m As Integer
Dim myAttachments As Variant, at As String, atC As Integer


On Error GoTo e
strSubject = Item.Subject
StrTo = Item.To
strBody = Mid(Item.Body, InStr(Item.Body, " ") + 1, InStr(Item.Body, ",") - InStr(Item.Body, " ") - 1)
On Error GoTo 0

mypeople = Array(".kumar@******", "abc@xyz.com", "abc1@xyz.com", "abc2@xyz.com", "abc3@xyz.com", "abc4@xyz.com", "abc5@xyz.com", "abc6@xyz.com", "abc7@xyz.com", "abc8@xyz.com", "abc9@xyz.com", "abc10@xyz.com", "abc11@xyz.com", "abc12@xyz.com", "abc13@xyz.com", "abc14@xyz.com", "abc15@xyz.com", "abc16@xyz.com", "abc17@xyz.com", "abc18@xyz.com", "abc19@xyz.com", "abc20@xyz.com")

Dim mail As Outlook.MailItem
Set mail = Item

Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Dim StrEmail As String
Const PR_SMTP_ADDRESS As String = _
        "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = mail.Recipients
    For Each recip In recips
        Set pa = recip.PropertyAccessor
        StrEmail = StrEmail & "," & pa.GetProperty(PR_SMTP_ADDRESS)
    Next

StrEmail = Mid(StrEmail, 2)

For i = LBound(mypeople) To UBound(mypeople)
    If InStr(LCase(StrEmail), mypeople(i)) Then m = m + 1
Next i

If Not m - 1 <> (Len(StrEmail) - Len(Replace(StrEmail, ",", ""))) Then Exit Sub

Prompt$ = "Verify it " & vbNewLine & "Subject - " & strSubject & vbNewLine & _
            "Mail to - " & StrEmail & vbNewLine & _
            "Person - " & strBody & vbNewLine & vbNewLine & "Are you sure you want to send the Mail?"

If MsgBox(Prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Email Confirmation") = vbNo Then Cancel = True


'=============================================================
Set myAttachments = mail.Attachments
atC = myAttachments.Count

If atC > 0 Then
    For i = 1 To atC
        at = at & "," & myAttachments.Item(i).DisplayName
    Next
MsgBox Mid(at, 2)
End If
'=============================================================


Exit Sub

e:
Cancel = True
MsgBox "Pls Recheck as per pattern : To[@], Subject[<>], Body[ ,]"
End Sub
 
Deepak said:
Glad Buddy!!!
Click to expand...

Hi Deepak,
Sorry to jump on this post, however, being the guru you are I was wondering if you would be able to help...?
Similar to Jagdev, I'm looking to write a code which looks up the subject line vs the recipient domain name, and should the two not match flag an error message e.g. @business.plc vs. Business.plc Invoice
Is this possible?
Many thanks!
 
Hi. Thanks for getting back to me!
When sending an email in outlook, I need a script which scans the subject line content against the recipient domain name, if they do not match - an error message occurs. So for example, if the subject line was 'business Plc' and the recipient domains were joebloggs@business.plc the email will send, if the domain was joebloggs@company.plc - this would flag an error.

Alternatively, is it possible within outlook to create a script which ties a subject line of an email with a predefined set of email addresses and when a recipient is added outside of that predefined list, an error is flagged as the subject line does not match the predefined email addresses?

I'm trawling the Internet for similar things but am having no luck whatsoever! Thank you in advance.
 
Check it.
paste the code in ThisOutlookSession

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

Dim strSubject As String
Dim StrTo As String
Dim strBody As String
Dim mypeople As Variant, i As Integer, m As Integer
Dim myAttachments As Variant, at As String, atC As Integer, boolMsg As Boolean


On Error GoTo e
strSubject = Replace(Item.Subject, " ", "")
StrTo = Item.To
'strBody = Mid(Item.Body, InStr(Item.Body, " ") + 1, InStr(Item.Body, ",") - InStr(Item.Body, " ") - 1)

Dim mail As Outlook.MailItem
Set mail = Item

Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Dim StrEmail As String
Const PR_SMTP_ADDRESS As String = _
        "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = mail.Recipients
    For Each recip In recips
        Set pa = recip.PropertyAccessor
        If strSubject <> Replace(Split(pa.GetProperty(PR_SMTP_ADDRESS), "@")(1), ".", "") Then boolMsg = True
    Next


If boolMsg Then MsgBox "Pls Recheck as per pattern : To[@], Subject[<>]": GoTo e

Exit Sub
e:
Cancel = True
End Sub
 
Many thanks for this!
Can you hint as to where I need to put the email addresses and the Subject line? Keep breaking the code!!!
Thanks again :)
 
It's dynamic in nature.

check this...

Code: 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim strSubject As String, StrEmailDomain As String
Dim mail As Outlook.MailItem
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Dim StrEmail As String

Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

On Error GoTo e
'this is the subject where replace is used to remove spaces from the string
strSubject = Item.Subject
strSubject = Replace(strSubject, " ", "")


Set mail = Item
With mail
    For Each recip In .Recipients
        Set pa = recip.PropertyAccessor
            'get email address of Recipient
            StrEmail = pa.GetProperty(PR_SMTP_ADDRESS)
                'split it to get domian name
                StrEmailDomain = Split(StrEmail, "@")(1)
                    'replace dot from the domain
                    StrEmailDomain = Replace(StrEmailDomain, ".", "")
                    'compare domain with subject
                        If strSubject <> StrEmailDomain Then GoTo e
    Next
End With

Exit Sub
e:
Cancel = True
MsgBox "Pls Recheck as per pattern : To[@], Subject[<>]"
End Sub
 
You must log in or register to reply here.
Back
Top