Adding a BCC depending on sender address

[Gasman]

Hi everyone,
I have some code that allows me to amend Good day, to whatever it should be, depending on the time of day.

I now have the need to add a BCC as I use 3 different computers, and whilst the IMAP syncs all incoming mail, it does not for outgoing mail.

This is the code I am trying to use, however the SenderEmailAddress is empty, so it fails all the time.

How can I implement this extra option please.

Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)
    Dim strGreeting As String
    Dim iTime As Integer
    Dim strBody As String, strDivCode As String
    strGreeting = ""
    strDivCode = "<div class=WordSection1><p class=MsoNormal>"
    iTime = Val(Format(Now(), "hh"))
    ' Quit if not a mail item
    If TypeName(item) <> "MailItem" Then
        Exit Sub
    End If
    Select Case iTime
         Case Is < 12
             strGreeting = "morning "
         Case Is < 17
             strGreeting = "afternoon "
         Case Else
             strGreeting = "evening "
    End Select
    strGreeting = "Good " & strGreeting
    ' Now add a BCC if JAG email address
    If item.SenderEmailAddress = "xxxx@yyyyy.co.uk" Then
        item.BCC = item.BCC & ";ttttttttt@gmail.com"
    End If
    If Left(item.BCC, 1) = ";" Then item.BCC = Mid(item.BCC, 2)
    strBody = item.HTMLBody
    strBody = Replace(strBody, "Good day", strGreeting)
    'strBody = Replace(strBody, strDivCode, strDivCode & strGreeting)
    item.HTMLBody = strBody
End Sub

[Aussiebear]

Welcome back to VBAX Gasman. Been a while if my memory serves me right.

[Aussiebear]

Does this give you any assistance?

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim msg As MailItem
Dim strGreeting
Dim hrs As Long
Dim mins As Long
Dim lngTime As Long
hrs = Val(Left(Format(Time, "HH:mm"), 2))
mins = Val(Right(Format(Time, "HH:mm"), 2))
lngTime = 60 * hrs + mins
Select Case lngTime
    Case Is <= 720
        strGreeting = "Good Morning"
    Case Is > 960
        strGreeting = "Good Evening"
    Case Else
        strGreeting = "Good Afternoon"
End Select
Set msg = Application.ActiveInspector.CurrentItem
msg.Body = strGreeting & vbCr & msg.Body
If InStr(1, msg.Body, "attach", vbTextCompare) > 0 Then
    If msg.Attachments.Count = 0 Then
        If MsgBox("There's no attachment, send anyway?", vbYesNo) = vbNo then
            Cancel = True
        End If
    End If
End If
End Sub

[Gasman]

Welcome back to VBAX Gasman. Been a while if my memory serves me right.

Thank you. It has been quiet on the Access front. :-)
Now I need assistance.

[Gasman]

Just tried this

    Set msg = Application.ActiveInspector.currentItem
    Debug.Print msg.SenderEmailAddress

but result is the same?

Does this give you any assistance?

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim msg As MailItem
Dim strGreeting
Dim hrs As Long
Dim mins As Long
Dim lngTime As Long
hrs = Val(Left(Format(Time, "HH:mm"), 2))
mins = Val(Right(Format(Time, "HH:mm"), 2))
lngTime = 60 * hrs + mins
Select Case lngTime
    Case Is <= 720
        strGreeting = "Good Morning"
    Case Is > 960
        strGreeting = "Good Evening"
    Case Else
        strGreeting = "Good Afternoon"
End Select
Set msg = Application.ActiveInspector.CurrentItem
msg.Body = strGreeting & vbCr & msg.Body
If InStr(1, msg.Body, "attach", vbTextCompare) > 0 Then
    If msg.Attachments.Count = 0 Then
        If MsgBox("There's no attachment, send anyway?", vbYesNo) = vbNo then
            Cancel = True
        End If
    End If
End If
End Sub

[Gasman]

Found a copy at
item.SendUsingaccount.smtpaddress

[Gasman]

Spoke too soon. :-(

I get the BCC in, but I get this back

Your message did not reach some or all of the intended recipients.

Subject: test send bcc
Sent: 15/03/2024 14:22

The following recipient(s) cannot be reached:

With no email addresses mentioned. :-(

[Aussiebear]

Okay, what about this effort

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim msg As MailItem
Dim strGreeting
Dim hrs As Long
Dim mins As Long
Dim lngTime As Long
hrs = Val(Left(Format(Time, "HH:mm"), 2))
mins = Val(Right(Format(Time, "HH:mm"), 2))
lngTime = 60 * hrs + mins
Select Case lngTime
    Case Is <= 720
        strGreeting = "Good Morning"
    Case Is > 960
        strGreeting = "Good Evening"
    Case Else
        strGreeting = "Good Afternoon"
End Select
Set msg = Application.ActiveInspector.CurrentItem
Set objRecip = Item.Recipients.Add("XXX@example.com")
objRecip.Type = olBCC
objRecip.Resolve
End With
msg.Body = strGreeting & vbCr & msg.Body
If InStr(1, msg.Body, "attach", vbTextCompare) > 0 Then
    If msg.Attachments.Count = 0 Then
        If MsgBox("There's no attachment, send anyway?", vbYesNo) = vbNo then
            Cancel = True
        End If
    End If
End If
End Sub

[jdelano]

Maybe because I am using a personal (and not a business) email this worked for me.

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


    Dim bccEmail As String
    
    If Item.SenderEmailAddress = "xxxxxxxxxxx@hotmail.com" Then
        bccEmail = "yyyyyyyyy@comcast.net"
        Item.BCC = bccEmail
    
    End If
    
End Sub

[Aussiebear]

How can we add this is the the existing code?

[jdelano]

Just swap the msg out and use the Item directly. Again, I preface this as the Item.SenderEmailAddress isn't blank for me. I'm using office 365.

Dim strGreeting
Dim hrs As Long
Dim mins As Long
Dim lngTime As Long


hrs = Val(Left(Format(Time, "HH:mm"), 2))
mins = Val(Right(Format(Time, "HH:mm"), 2))
lngTime = 60 * hrs + mins


Select Case lngTime
	Case Is <= 720
		strGreeting = "Good Morning"
	Case Is > 960
		strGreeting = "Good Evening"
	Case Else
		strGreeting = "Good Afternoon"
End Select
strGreeting = "Good " & strGreeting


If Item.SenderEmailAddress = "xxxx@yyyyy.co.uk" Then
	Item.BCC = IIf(Len(Item.BCC) = 0, "" ,";") & "ttttttttt@gmail.com"
End If


strBody = Item.HTMLBody
strBody = Replace(strBody, "Good day", strGreeting)
Item.HTMLBody = strBody

[Gasman]

Well this is embarrassing. Seems I was looking in the wrong folder.
The Sent Items folder does indeed sync with all computers.

[Gasman]

I am on 2007, and can get the BCC populated. Just that it does not seem to work. When sending the dialogue flashes a few times, and then I get the unable to send response, but with no addresses.

All moot now, as I have found out the folder does sync after all.

Just swap the msg out and use the Item directly. Again, I preface this as the Item.SenderEmailAddress isn't blank for me. I'm using office 365.

Dim strGreeting
Dim hrs As Long
Dim mins As Long
Dim lngTime As Long


hrs = Val(Left(Format(Time, "HH:mm"), 2))
mins = Val(Right(Format(Time, "HH:mm"), 2))
lngTime = 60 * hrs + mins


Select Case lngTime
    Case Is <= 720
        strGreeting = "Good Morning"
    Case Is > 960
        strGreeting = "Good Evening"
    Case Else
        strGreeting = "Good Afternoon"
End Select
strGreeting = "Good " & strGreeting


If Item.SenderEmailAddress = "xxxx@yyyyy.co.uk" Then
    Item.BCC = IIf(Len(Item.BCC) = 0, "" ,";") & "ttttttttt@gmail.com"
End If


strBody = Item.HTMLBody
strBody = Replace(strBody, "Good day", strGreeting)
Item.HTMLBody = strBody

[Aussiebear]

So it is Solved then?

[Gasman]

So it is Solved then?

Yes. Sorry, I thought I had marked it solved when I found the correct location of the email address.
Must have unmarked it when it was not sending.
Now marked as Solved again.

[Aussiebear]

My apologies, I had marked it unsolved after you marked it solved because the thread seemed to roll on. All good here as it was an interesting thread.