• 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.

[Outlook] VBA to Match the 6 digit code in the email subject line with the same code in the name of the attachments

A

Abhishek A

Member
Hi,

I sent out lot of emails in a day and chances of attaching wrong attachment to wrong code is very high.
I am looking for an Prompt msg in Outlook when we hit on send by matching 6 digit code in the subject line with the name of the attachments. If the code in subject line does not match with the attachments email should not send and prompt a msg stating code not matching.

Any help will save a lot of my errors.
 
Here's what I envision for this (check my thinking):

1) You want a VBA/Outlook macro that runs whenever you hit <Send> on any email.
2) The program starts by checking the subject of the outgoing email and determining whether there's a six-digit code there. If not, then it's a "normal" email; the program exits and the Send proceeds normally.
3) The program looks through the attachments, making sure that at least one of them (or should it be all of them?) has that six-digit code in the filename. If the email passes this test, the program exits and the Send proceeds normally.
4) The program displays a message saying, in effect, "Hold on, there, buster! I don't see attachment 123456 here! Do you want to proceed anyway?".
5) If the operator hits the Yes button, the program exits and the Send proceeds normally.
6) The program cancels the Send, and the operator (that would be you, I presume) fixes the attachment and hits <Send> again.

Something like that?
 
Yes... point 3.. It should be all of the attachments.

Currently i am using below code. Where i need to enter the code manually.

>>> use code - tags <<<
Code: 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If (TypeOf Item Is MailItem) Then
Dim strMsg As String
Dim msgResult As Integer
Dim Myinput As Variant
Dim objMsg As Outlook.MailItem
Dim Store As String
Dim Store2 As String
Dim xAttachment As Attachment
Dim xFileName As String
Dim xInspector As Outlook.Inspector
Dim xDoc As Word.Document
Dim xWdSelection As Word.Selection
Dim Store3 As String
Dim Store4 As String
Dim Store5 As String
Dim Store6 As String
Dim i As String
Dim j As Integer
strMsg = "From Address: "
If Item.SenderEmailAddress <> Item.SentOnBehalfOfName Then
strMsg = strMsg & Item.SentOnBehalfOfName
End If
If Item.SentOnBehalfOfName = "" Then
strMsg = strMsg & Item.SendUsingAccount
Set objMsg = Application.ActiveInspector.CurrentItem
On Error Resume Next
For Each Recipient In objMsg.Recipients
If InStr(1, Recipient, "@") > 0 Then
msgResult = MsgBox("This is an external email contact:" & vbNewLine & vbNewLine & _
Recipient & vbNewLine & vbNewLine & "Please confirm do you still want to send this email?" & vbNewLine & vbNewLine, vbYesNo + vbDefaultButton2 + vbQuestion, "EXTERNAL EMAIL CONTACT")
If msgResult = vbNo Then
Cancel = True
Exit Sub
End If
End If
Next Recipient
Line:
If InStr(1, Item.To, "@") > 0 Then
Myinput = InputBox("Enter Plan Number", "Plan Number")
If Len(Myinput) <> 6 Then
MsgBox "Enter Six digit plan number"
GoTo Line
End If
Store = Myinput
If msgResult = vbNo Then
Cancel = True
Exit Sub
End If
Store2 = Item.Subject
If InStr(1, Store2, Store) = 0 Then
msgResult = MsgBox("Plan number is not matching with subject line:" & vbNewLine & vbNewLine & Item.Subject & vbNewLine & vbNewLine & _
"Please confirm do you still want to send this email?" & vbNewLine & vbNewLine, vbYesNo + vbDefaultButton2 + vbInformation, "Subject Line")
If msgResult = vbNo Then
Cancel = True
Exit Sub
End If
End If
If Item.Class = olMail Then
Set objMsg = Item
If objMsg.Attachments.Count > 0 Then
i = "image00"
j = 1
On Error Resume Next
Set objMsg = Outlook.ActiveInspector.CurrentItem
If objMsg.Attachments.Count = 0 Then
Exit Sub
End If
xFileName = ""
For Each xAttachment In objMsg.Attachments
If xFileName = "" Then
xFileName = " <" & xAttachment.FileName & "> "
Else
xFileName = xFileName & vbCrLf & " <" & xAttachment.FileName & "> "
End If
Store = Myinput
If InStr(1, xAttachment.FileName, Store) = 0 Then
If xAttachment.FileName = "image00" & j & ".png" Then
GoTo Line1
Else
msgResult = MsgBox("Plan number is not matching with the attachment name:" & vbNewLine & vbNewLine & xAttachment.FileName & vbNewLine & vbNewLine & _
"Please confirm do you still want to send this email?" & vbNewLine & vbNewLine, vbYesNo + vbDefaultButton2 + vbCritical, "Incorrect Attachment")
If msgResult = vbNo Then
Cancel = True
Exit Sub
End If
End If
End If
Line1:
j = j + 1
Next xAttachment
End If
End If
End If
If InStr(1, Item.To, "@") > 0 Then
MsgBox ("YOU CANNOT SEND THIS EMAIL")
Cancel = True
Exit Sub
Else
GoTo Line4
End If
ElseIf Item.SenderEmailAddress <> Item.SentOnBehalfOfName Then
Set objMsg = Application.ActiveInspector.CurrentItem
On Error Resume Next
For Each Recipient In objMsg.Recipients
If InStr(1, Recipient, "@") > 0 Then
Store4 = Right(Item.To, Len(Item.To) - InStr(1, Item.To, "@"))
Store5 = Left(Recipient, InStr(1, Recipient, "@"))
msgResult = MsgBox("This is an external email contact:" & vbNewLine & vbNewLine & _
Recipient & vbNewLine & vbNewLine & "Please confirm do you still want to send this email?" & vbNewLine & vbNewLine, vbYesNo + vbDefaultButton2 + vbQuestion, "EXTERNAL EMAIL CONTACT")
If msgResult = vbNo Then
Cancel = True
Exit Sub
End If
Line5:
Myinput = InputBox("Please enter the domain name for" & vbNewLine & vbNewLine & Store5, "Enter Domain Name")
Store6 = Store5 & Myinput
If UCase(Store6) <> UCase(Recipient) Then
MsgBox "Domain name did not matched for:" & vbNewLine & vbNewLine & Recipient
Cancel = True
Exit Sub
End If
End If
Next Recipient
Line2:
If InStr(1, Item.To, "@") > 0 Then
Myinput = InputBox("Enter Plan Number", "Plan Number")
If Len(Myinput) <> 6 Then
MsgBox "Enter Six digit plan number"
GoTo Line2
End If
Store = Myinput
If msgResult = vbNo Then
Cancel = True
Exit Sub
End If
Store2 = Item.Subject
If InStr(1, Store2, Store) = 0 Then
msgResult = MsgBox("Plan number is not matching with subject line:" & vbNewLine & vbNewLine & Item.Subject & vbNewLine & vbNewLine & _
"Please confirm do you still want to send this email?" & vbNewLine & vbNewLine, vbYesNo + vbDefaultButton2 + vbInformation, "Subject Line")
If msgResult = vbNo Then
Cancel = True
Exit Sub
End If
End If
If Item.Class = olMail Then
Set objMsg = Item
If objMsg.Attachments.Count > 0 Then
i = "image00"
j = 1
On Error Resume Next
Set objMsg = Outlook.ActiveInspector.CurrentItem
If objMsg.Attachments.Count = 0 Then
Exit Sub
End If
xFileName = ""
For Each xAttachment In objMsg.Attachments
If xFileName = "" Then
xFileName = " <" & xAttachment.FileName & "> "
Else
xFileName = xFileName & vbCrLf & " <" & xAttachment.FileName & "> "
End If
Store = Myinput
If InStr(1, xAttachment.FileName, Store) = 0 Then
If xAttachment.FileName = "image00" & j & ".png" Then
GoTo Line3
Else
msgResult = MsgBox("Plan number is not matching with the attachment name:" & vbNewLine & vbNewLine & xAttachment.FileName & vbNewLine & vbNewLine & _
"Please confirm do you still want to send this email?" & vbNewLine & vbNewLine, vbYesNo + vbDefaultButton2 + vbCritical, "Incorrect Attachment")
If msgResult = vbNo Then
Cancel = True
Exit Sub
End If
End If
End If
Line3:
j = j + 1
Next xAttachment
End If
End If
If Item.SentOnBehalfOfName = "SHR-US-Corporate TPA Plan Consultants" Then
If Left$(Store, 1) = "5" Then
MsgBox ("This is a BUNDLED Plan" & vbNewLine & vbNewLine & "Please send the email from BUNDLED shared mailbox")
Cancel = True
Exit Sub
ElseIf Left$(Store, 1) = "7" Then
MsgBox (" This is a BUNDLED Plan" & vbNewLine & vbNewLine & "Please send the email from BUNDLED shared mailbox")
Cancel = True
Exit Sub
Else
GoTo Line4:
End If
End If
If Item.SentOnBehalfOfName = "SHR-US-Corporate Bundled Plan Consultants" Then
If Left$(Store, 1) = "5" Then
GoTo Line4:
ElseIf Left$(Store, 1) = "7" Then
GoTo Line4:
ElseIf Left$(Store, 1) = "6" Then
GoTo Line4:
Else
MsgBox ("This is a TPA Plan" & vbNewLine & vbNewLine & "Please send the email from TPA shared mailbox")
Cancel = True
Exit Sub
End If
End If
End If
Line4:
strMsg = strMsg & vbNewLine & vbNewLine & "    To Address:  " & Item.To
msgResult = MsgBox(strMsg, vbOKCancel + vbDefaultButton2 + vbCritical, _
"Account Check")
If msgResult = vbCancel Then
Cancel = True
Exit Sub
End If
End If
End If
End Sub
 
Last edited by a moderator:
What I guess you want, then, is a procedure that executes automatically when you try to send an email. So there's gotta be a Mail Item in MS Outlook with a Send event, right? I googled around and found this (https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem.send(even)), which seems to say that the containing object is MailItem and the event is Send (all logical enough). There's some sample code for it.

But I have some of that set up in my Outlook and I can't see that it's doing anything. I have this in the module named ThisOutlookSession:
Code: 
Public WithEvents myItem As Outlook.MailItem
Private Sub myItem_Read()
  MsgBox "Email read!"
  End Sub
Private Sub myItem_Send(bCan As Boolean)
  MsgBox "Email send!"
  End Sub
What I would expect this to do, if I have it set up correctly, is display a MsgBox whenever I read an email or hit Send on one. But it doesn't seem to do anything.

I'm slowly become pretty competent with the Excel object model, but about Outlook I'm much less knowledgeable. I can send emails, and add attachments, and I have one that culls out all the extra styles from emails that I get from an AOL buddy, but not much more.

If you can get a routine working that does anything when you hit <Send> on an email, then you should be able to add the necessary code to do the rest of what I describe above, and I can probably help with that. But for some reason my attempt to react to the Send event isn't doing anything, so that's the hurdle we have to get over first.

...Wait, this just in: Upon more careful reading of the documentation, I think the MailItem.Send event relies on a particular mail item being identified with a VBA object; it can't just be any item, it has to have a name in the VBA program. Instead, there's an event in the Application object called ItemSend (see https://learn.microsoft.com/en-us/office/vba/api/outlook.application.itemsend). I'll be back with more, if that doesn't get you on your way.
 
Hm, it's still not working. Here's what I have now: In a class module (which I named EnableEvents) I've put
Code: 
Public WithEvents ool As Outlook.Application
Private Sub ool_ItemSend(ByVal oeml As Object, bCan As Boolean)
  Stop
  MsgBox "ItemSend!"
  Stop
  End Sub
Sub Class_Initialize()
  Stop
  Set ool = Outlook.Application
  End Sub
I execute a quick program that says simply "Set oee = EnableEvents", which executes the Class_Initialize procedure, thus setting ool to become the Application object. So when I send an email I expect to hit the first Stop statement. Instead it just unexcitedly sends the email.

Since I may want to do this sort of thing in the future, I think I'll post my own question about this. If I get a helpful answer I'll get back to you.
 
Marc L said:
Hi, crucial question : what is the link with this Excel VBA forum section ?‼
Click to expand...
Marc, is this really only for VBA/Excel discussions? The name of the forum is just "VBA Macros", and I've always supposed it's for VBA in general, not specifically Excel. Although most of the questions are about Excel, of course.
 
Abhishek, Debaser got me past the problem I was having with getting the ItemSend event to be recognized in my VBE/Outlook. So next, I'm looking at your program and thinking it can be simpler. I'll spend a little time on that and come back later today.
 
BobBridges said:
Abhishek, Debaser got me past the problem I was having with getting the ItemSend event to be recognized in my VBE/Outlook. So next, I'm looking at your program and thinking it can be simpler. I'll spend a little time on that and come back later today.
Click to expand...
Any progress or any update on simplification of my code
 
Ack! I forgot all about it! Abhishek, I apologize; my bad. I owe my paying client some attention first; I'll try to remember to do it later today, and please feel free to nag me sooner next time if you don't hear from me.
 
Ok, Abhishek, here are some preliminary thoughts. First, about programming style: Everyone has their own, and I wouldn't for the world try to convince you that yours is wrong and mine is right. But I (and most experienced coders) are really strict about indentation, to give the eye an easy clue to the way the logic flows. So let's start with this:
Code: 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
  If (TypeOf Item Is MailItem) Then
    Dim strMsg As String
    Dim msgResult As Integer
    Dim Myinput As Variant
    Dim objMsg As Outlook.MailItem
    Dim Store As String
    Dim Store2 As String
    Dim xAttachment As Attachment
    Dim xFileName As String
    Dim xInspector As Outlook.Inspector
    Dim xDoc As Word.Document
    Dim xWdSelection As Word.Selection
    Dim Store3 As String
    Dim Store4 As String
    Dim Store5 As String
    Dim Store6 As String
    Dim i As String
    Dim j As Integer
    strMsg = "From Address: "
    If Item.SenderEmailAddress <> Item.SentOnBehalfOfName Then
      strMsg = strMsg & Item.SentOnBehalfOfName
      End If
    If Item.SentOnBehalfOfName = "" Then
      strMsg = strMsg & Item.SendUsingAccount
      Set objMsg = Application.ActiveInspector.CurrentItem
      On Error Resume Next
      For Each Recipient In objMsg.Recipients
        If InStr(1, Recipient, "@") > 0 Then
          msgResult = MsgBox("This is an external email contact:" & vbNewLine & vbNewLine & _
            Recipient & vbNewLine & vbNewLine & "Please confirm do you still want to send this email?" _
            & vbNewLine & vbNewLine, vbYesNo + vbDefaultButton2 + vbQuestion, "EXTERNAL EMAIL CONTACT")
          If msgResult = vbNo Then
            Cancel = True
            Exit Sub
            End If
          End If
        Next Recipient
Line:
      If InStr(1, Item.To, "@") > 0 Then
        Myinput = InputBox("Enter Plan Number", "Plan Number")
        If Len(Myinput) <> 6 Then
          MsgBox "Enter Six digit plan number"
          GoTo Line
          End If
        Store = Myinput
        If msgResult = vbNo Then
          Cancel = True
          Exit Sub
          End If
        Store2 = Item.Subject
        If InStr(1, Store2, Store) = 0 Then
          msgResult = MsgBox("Plan number is not matching with subject line:" & vbNewLine & vbNewLine _
            & Item.Subject & vbNewLine & vbNewLine & "Please confirm do you still want to send this email?" _
            & vbNewLine & vbNewLine, vbYesNo + vbDefaultButton2 + vbInformation, "Subject Line")
          If msgResult = vbNo Then
            Cancel = True
            Exit Sub
            End If
          End If
        If Item.Class = olMail Then
          Set objMsg = Item
          If objMsg.Attachments.Count > 0 Then
            i = "image00"
            j = 1
            On Error Resume Next
            Set objMsg = Outlook.ActiveInspector.CurrentItem
            If objMsg.Attachments.Count = 0 Then
              Exit Sub
              End If
            xFileName = ""
            For Each xAttachment In objMsg.Attachments
              If xFileName = "" Then
                xFileName = " <" & xAttachment.FileName & "> "
              Else
                xFileName = xFileName & vbCrLf & " <" & xAttachment.FileName & "> "
                End If
              Store = Myinput
              If InStr(1, xAttachment.FileName, Store) = 0 Then
                If xAttachment.FileName = "image00" & j & ".png" Then
                  GoTo Line1
                Else
                  msgResult = MsgBox("Plan number is not matching with the attachment name:" & vbNewLine & vbNewLine _
                    & xAttachment.FileName & vbNewLine & vbNewLine & "Please confirm do you still want to send this email?" _
                    & vbNewLine & vbNewLine, vbYesNo + vbDefaultButton2 + vbCritical, "Incorrect Attachment")
                  If msgResult = vbNo Then
                    Cancel = True
                    Exit Sub
                    End If
                  End If
                End If
Line1:
              j = j + 1
              Next xAttachment
            End If
          End If
        End If
      If InStr(1, Item.To, "@") > 0 Then
        MsgBox ("YOU CANNOT SEND THIS EMAIL")
        Cancel = True
        Exit Sub
      Else
        GoTo Line4
        End If
      ElseIf Item.SenderEmailAddress <> Item.SentOnBehalfOfName Then
      Set objMsg = Application.ActiveInspector.CurrentItem
      On Error Resume Next
      For Each Recipient In objMsg.Recipients
        If InStr(1, Recipient, "@") > 0 Then
          Store4 = Right(Item.To, Len(Item.To) - InStr(1, Item.To, "@"))
          Store5 = Left(Recipient, InStr(1, Recipient, "@"))
          msgResult = MsgBox("This is an external email contact:" & vbNewLine & vbNewLine & _
          Recipient & vbNewLine & vbNewLine & "Please confirm do you still want to send this email?" & vbNewLine & vbNewLine, vbYesNo + vbDefaultButton2 + vbQuestion, "EXTERNAL EMAIL CONTACT")
          If msgResult = vbNo Then
            Cancel = True
            Exit Sub
            End If
Line5:
          Myinput = InputBox("Please enter the domain name for" & vbNewLine & vbNewLine & Store5, "Enter Domain Name")
          Store6 = Store5 & Myinput
          If UCase(Store6) <> UCase(Recipient) Then
            MsgBox "Domain name did not matched for:" & vbNewLine & vbNewLine & Recipient
            Cancel = True
            Exit Sub
            End If
          End If
        Next Recipient
Line2:
      If InStr(1, Item.To, "@") > 0 Then
        Myinput = InputBox("Enter Plan Number", "Plan Number")
        If Len(Myinput) <> 6 Then
          MsgBox "Enter Six digit plan number"
          GoTo Line2
          End If
        Store = Myinput
        If msgResult = vbNo Then
          Cancel = True
          Exit Sub
          End If
        Store2 = Item.Subject
        If InStr(1, Store2, Store) = 0 Then
          msgResult = MsgBox("Plan number is not matching with subject line:" & vbNewLine & vbNewLine _
            & Item.Subject & vbNewLine & vbNewLine & "Please confirm do you still want to send this email?" _
            & vbNewLine & vbNewLine, vbYesNo + vbDefaultButton2 + vbInformation, "Subject Line")
          If msgResult = vbNo Then
            Cancel = True
            Exit Sub
            End If
          End If
        If Item.Class = olMail Then
          Set objMsg = Item
          If objMsg.Attachments.Count > 0 Then
            i = "image00"
            j = 1
            On Error Resume Next
            Set objMsg = Outlook.ActiveInspector.CurrentItem
            If objMsg.Attachments.Count = 0 Then
              Exit Sub
              End If
            xFileName = ""
            For Each xAttachment In objMsg.Attachments
              If xFileName = "" Then
                xFileName = " <" & xAttachment.FileName & "> "
              Else
                xFileName = xFileName & vbCrLf & " <" & xAttachment.FileName & "> "
                End If
              Store = Myinput
              If InStr(1, xAttachment.FileName, Store) = 0 Then
                If xAttachment.FileName = "image00" & j & ".png" Then
                  GoTo Line3
                Else
                  msgResult = MsgBox("Plan number is not matching with the attachment name:" & vbNewLine & vbNewLine _
                    & xAttachment.FileName & vbNewLine & vbNewLine & "Please confirm do you still want to send this" _
                    & "email?" & vbNewLine & vbNewLine, vbYesNo + vbDefaultButton2 + vbCritical, "Incorrect Attachment")
                  If msgResult = vbNo Then
                    Cancel = True
                    Exit Sub
                    End If
                  End If
                End If
Line3:
              j = j + 1
              Next xAttachment
            End If
          End If
        If Item.SentOnBehalfOfName = "SHR-US-Corporate TPA Plan Consultants" Then
          If Left$(Store, 1) = "5" Then
            MsgBox ("This is a BUNDLED Plan" & vbNewLine & vbNewLine & "Please send the email from BUNDLED shared mailbox")
            Cancel = True
            Exit Sub
          ElseIf Left$(Store, 1) = "7" Then
            MsgBox (" This is a BUNDLED Plan" & vbNewLine & vbNewLine & "Please send the email from BUNDLED shared mailbox")
            Cancel = True
            Exit Sub
          Else
            GoTo Line4:
            End If
          End If
        If Item.SentOnBehalfOfName = "SHR-US-Corporate Bundled Plan Consultants" Then
          If Left$(Store, 1) = "5" Then
            GoTo Line4:
          ElseIf Left$(Store, 1) = "7" Then
            GoTo Line4:
          ElseIf Left$(Store, 1) = "6" Then
            GoTo Line4:
          Else
            MsgBox ("This is a TPA Plan" & vbNewLine & vbNewLine & "Please send the email from TPA shared mailbox")
            Cancel = True
            Exit Sub
            End If
          End If
        End If
Line4:
      strMsg = strMsg & vbNewLine & vbNewLine & "    To Address:  " & Item.To
      msgResult = MsgBox(strMsg, vbOKCancel + vbDefaultButton2 + vbCritical, _
      "Account Check")
      If msgResult = vbCancel Then
        Cancel = True
        Exit Sub
        End If
      End If
    End If
  End Sub
There, I can at least start to read it now. I don't care whether you indent 4 spaces, or 2 like me, or something else, but sheesh, how do you read that? :)
 
Hm, the indentation is still wrong; I can't tell whether it's my error or yours. Meanwhile I've been looking over your code, and I see that although I described your need simply above, there are some complications in it. Before I give any more (possibly wrong) advice, maybe I should ask: What is it you need, at this point? Does your program work, and you're just looking for ways to simplify it, or does it not work at all, or is there some specific part that you'd like to improve, or what?
 
Hm, someone moved this "how do I...?" question to a forum where the first rule seems to be "don't post 'how do I...?' questions here". Not sure why. Not your fault, though, Abhishek, and I guess I don't care either way.
 
BobBridges said:
Marc, is this really only for VBA/Excel discussions? The name of the forum is just "VBA Macros", and I've always supposed it's for VBA in general, not specifically Excel. Although most of the questions are about Excel, of course.
Click to expand...
Should I remind what every one can read at the top of the Forums list :​

Chandoo.org Excel Forums​

 
You must log in or register to reply here.
Back
Top