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. :banghead:

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