GDPR issues - stopping Outlook users from using CC - Idea and thoughts to resolve

Hi

As GDPR starts to bite, and my patience with having to apologise to people who have been sent (or copied in!), information that wasn't meant for them, I'm looking at how I can reduce the number of times I have to declare a data protection breach.

My initial thoughts were to use a macro that warned users when an email was being sent outside of the company's email server. This works fine;

Code:

---

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim recips As Outlook.Recipients
    Dim recip As Outlook.Recipient
    Dim pa As Outlook.PropertyAccessor
    Dim prompt As String
    Dim strMsg As String
    Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set recips = Item.Recipients
    For Each recip In recips
        Set pa = recip.PropertyAccessor
        If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@XXXXXXXX.com") = 0 Then
            strMsg = strMsg & "  " & pa.GetProperty(PR_SMTP_ADDRESS) & vbNewLine
       
        End If
    Next
    If strMsg <> "" Then
        prompt = "This email will be sent outside of XXXXXXXXXXX to:" & vbNewLine & strMsg & "Do you want to proceed?"
        If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "GDPR Alert!! Please Check Email Addresses") = vbNo Then
            Cancel = True
        End If
    End If
End Sub

---

However, users can exacerbate the problem by copying lots of people to maximise the GDPR breach for me.

So, how can I stop them?:banghead:

Is there any way to simply remove the CC option (Probably impractical as we do need to send emails to more than one person!)

or

Can a macro take all the CC recipients and simply convert these to BCC recipients?

or

Is there another way to achieve this goal?

You can certainly change the recipients from CC to BCC but I don't see how it addresses the issue of unwanted messages being sent out. CC or BCC, they still get sent.

Code:

---

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
    Set recips = Item.Recipients
    For Each recip In recips
        If recip.Type = olCC Then recip.Type = olBCC
    Next
End Sub

---

Hi Graham

Thanks for this. I agree that the problem is between the ears of the members of staff who send emails without thinking, but the majority of events are just simply mistakes and oversights (as opposed to deliberate and intentional). I suspect there isn't a perfect solution, rather one that limits the opportunities to get it wrong.

The programmers' job would be wonderful if it wasn't for the users.:banghead:

However on further reflection, you could check if the message was being sent by CC or BCC and check with the user to confirm. You could also check whether there were multiple recipients in the TO line, which I have added here. If there is only one recipient in the TO line there is no prompt.

Code:

---

Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'Graham Mayor - https://www.gmayor.com - Last updated - 29 Jul 2019
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim strList As String, strTo As String
Dim oColl_To As Collection, oColl_Copy As Collection
Dim lngAsk As Long, i As Long
    Set recips = Item.Recipients
    Set oColl_To = New Collection
    Set oColl_Copy = New Collection
    For i = 1 To recips.Count
        Set recip = recips(i)
        If recip.Type = olCC Or recip.Type = olBCC Then
            oColl_Copy.Add recip.Address
        Else
            oColl_To.Add recip.Address
        End If
    Next i
    If oColl_Copy.Count > 0 Or oColl_To.Count > 1 Then
        strTo = ""
        For i = 2 To oColl_To.Count
            strTo = strTo & oColl_To(i) & vbCr
        Next i
        strList = ""
        For i = 1 To oColl_Copy.Count
            strList = strList & oColl_Copy(i) & vbCr
        Next i
        lngAsk = MsgBox("You are copying the current message to:" & vbCr & vbCr & strTo & strList & vbCr & _
                        "Are you sure you intended to do that?", vbYesNo)
        If lngAsk = vbNo Then Cancel = True
    End If
lbl_Exit:
    Set recip = Nothing
    Set recips = Nothing
    Set oColl_To = Nothing
    Set oColl_Copy = Nothing
    Exit Sub
End Sub

---

Hi Graham

Thanks for the macro, I've had a quick play around with it but from first testing, the cc to bcc conversion seems to have stopped working. I'll have a look further tomorrow to see if I can figure out why it's not playing nicely.