Emails Not Going Out From Account

[DMT Dave]

Hi Guy's i have changed the we are emailing via recordset based on a Date

I have used .html body instead of .body

Prior to changing to this method which is better for placing signatures on etc... when I used vb or ,body instead of changing to html, the email used to go out from account (2), now that I have changed to .html body, emails are going our from account (1) see below in red

Does setting your out account work with html body ????

Private Sub cmdEmailAll_Click()Const Q = """"
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem
Dim rs As DAO.Recordset
Dim OutAccount As Outlook.Account
Dim RemDate As Date, eDisc As String, eDisc2 As String
Dim CurrDay As Date, myDay As String, DayNo As Long, OrgDate As Date, DateChange As String, MailBody As String, TimingBody As String, TimeSlot As String, CLListName As String
Dim myClient As String, FullName() As String, dte As Date, TOD As String, FriDate As Date, ConDate As Date, myGreet As String, myETA1 As String, myETA2 As String, myEmail As String
Dim BookingLink As String, RecNo As Integer, PayLine As String, myEng As String, TimeNow As String, myUser As String, myName As String
Dim a As String, b As String, c As String, d As String
Dim e As String, f As String, g As String, h As String
Dim i As String, j As String, k As String, l As String
Dim m As String, n As String, o As String, p As String, r As String, s As String


On Error Resume Next
Err.Clear


eDisc = "This message and any associated files is intended only for the use of the named recipient(s) and may contain information which is confidential, subject to copy write or constitutes a trade secret."
eDisc2 = "Any files attached to this email are fully screened by our high end anti-virus system Sophos Endpoint, therefore your computer should be safe to open the file, if your computer recognizes a virus within this email and/or any attached files, Our Company is not responsible for virus threats from your computer due to being fully screened before sending"


Set oOutlook = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set oOutlook = New Outlook.Application
End If
myName = Me.txtLogin
myUser = Split(myUser, " ")


RemDate = Format(Me.txtTimDate, "mm/dd/yyyy")
CurrDay = DateAdd("d", -(Weekday(Me.txtDateSource) - DayNo), Me.txtDateSource)
myDay = Format(CurrDay, "dddd-dd-mmm-yyyy")
DateChange = Format(CurrDay, "dd-mm-yyyy")
FriDate = DateAdd("d", -(Weekday(Me.txtDateSource) - 6), Me.txtDateSource)
myUser = Me.txtLogin


TimeNow = Format(Now(), "hh:nn")
If TimeNow >= "00:01" Then
If TimeNow <= "11:59" Then
TOD = "Good Morning"
End If
End If
If TimeNow >= "12:01" Then
If TimeNow <= "16:59" Then
TOD = "Good Afternoon"
End If
End If
If TimeNow >= "17:01" Then
If TimeNow <= "23:59" Then
TOD = "Good Evening"
End If
End If


BookingLink = "https://www.Ourwebsite.com/client-bookings"




Set oEmailItem = oOutlook.CreateItem(olMailItem)
Set rs = CurrentDb.OpenRecordset("Select * From tblRemovals WHERE RemovalDate = #" & RemDate & "#")
If Not (rs.BOF And rs.EOF) Then
rs.MoveFirst
Do Until rs.EOF = True
RecNo = rs.Fields("RecordNo")
PayLine = Mid(rs.Fields("PayBy"), 2)
myEng = rs.Fields("Engineer")
myETA1 = rs.Fields("ETA")
myETA2 = rs.Fields("ETA2")


CLListName = rs.Fields("Client")
FullName = Split(CLListName, " ")
Select Case UBound(FullName)
Case 0
myClient = FullName(0)
Case 1
myClient = FullName(0)
Case 2
myClient = FullName(0) & " " & FullName(2)
End Select


myGreet = TOD & " " & myClient & ","
myEmail = rs.Fields("Email")


a = myGreet
b = "We have now allocated a time slot to remove your Items."
c = "Below is the day and time slots."
d = "......................................................................................................................."
e = Chr(149) & " " & "Removal Date: " & Chr(149) & " " & UCase(Format(Me.txtDate, "dddd-dd-mmm-yyyy"))
f = Chr(149) & " " & "Expected Between: " & Chr(149) & " " & myETA1 & " and " & myETA2 & " " & Chr(149) & " subject to your approval."
g = Chr(149) & " " & "Removal Arrangement: " & Chr(149) & " " & PayLine
h = Chr(149) & " " & "Engineer Allocated: " & Chr(149) & " " & myEng
i = Chr(149) & " " & "Confirmation " & Chr(149) & " You can view your times online which will be updated on " & Format(Me.txtFriConDate, "dddd-dd-mmm-yyyy") & " " & "mid afternoon onwards"
j = "Due to a very congested phone line, to prevent us missing you, your timings are now offered online also."
k = "Due to our privacy policy, there are no names and address on our website that corresponds with your booking, just your unique booking number."
l = "You can view your booking here > "
m = "your 4 digit booking number " & "( " & RecNo & " ) will be listed"
n = "If you can accommodate the timings offered, please type your reference number " & "(" & RecNo & ")" & " " & "Click 'Confirm Time Button'"
o = "We much appreciate this as it helps us whilst our telephone lines are very busy."
p = "We thank you for your understanding and we look forward to assisting you"
r = "With Our Kindest Regards"
s = myUser


Set oEmailItem = oOutlook.CreateItem(olMailItem)
With oEmailItem
Set OutAccount = myApp.Session.Accounts.Item(2) THIS IS GOING OUT FROM ACCOUNT(1) ???
.To = myEmail
.Subject = "Removal"
.HTMLBody = a & "<br>" & "<br>" & b & "<br>" & "<br>" & c & "<br>" & "<br> " & _
d & "<br>" & e & "<br>" & "<br>" & f & "<br>" & "<br>" & g & "<br>" & "<br>" & h & "<br>" & "<br>" & _
i & "<br>" & "<br>" & d & "<br>" & j & "<br>" & "<br>" & k & "<br>" & "<br>" & _
l & "<a href=" & Q & BookingLink & Q & "> https://Ourwebsite/client-bookings </a>" & m & "<br>" & "<br>" & _
n & "<br>" & "<br>" & o & "<br>" & "<br>" & p & "<br>" & "<br>" & r & "<br>" & "<br>" & s & "<br>" & _
"<P><IMG border=0 hspace=0 alt='' src='file://T:/Email Signature.jpg' align=baseline></P>" & "<br>" & "<br>" & _
"<FONT color=#0000CD>" & eDisc & "<br>" & "<FONT color =#0000CD>" & eDisc2
.SendUsingAccount = OutAccount
.Display
End With
rs.MoveNext
Loop
End If
rs.Close
Set rs = Nothing
Set oEmailItem = Nothing
Set oOutlook = Nothing

[DMT Dave]

Answer my own problem yippeee myApp doesn't exist, i have copied, pasted and tweaked and didnt realize my mistake, its oEmailItem and not myApp Durrrrrrrrrrrrrrrrrrrrrrrrrrrrrr

[Welshgasman]

Changing the body type should not change the account used?
I cannot make much of that code as there is no indentation at all

The index of that account is normally the same as the order that is shown in the list.?
Has a new account been added at all and precedes the others?

I hope you never end up sending emails at Midnight, Midday or 1700 hours as well?

[DMT Dave]

Hi welshgasman, it's ok now, i noticed i have set the object on email, i see what you mean about the time, i tried a different method but it was unreliable so used TOD (Time of day) you likely guessed, i need to set on the hour rather than 60 seconds either side

[Welshgasman]

FWIW I use this in Outlook for my emails?

    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

HTH

[DMT Dave]

thank you will adapt to that