Code:
Dim subject As String, Body As String, a As String, b As String, c As String, lne As String, wkr As String, UserName As StringDim OutApp As Outlook.Application, OutAccount As Outlook.Account
Dim OutMail As Outlook.MailItem
Dim intListB As Integer, intListC As Integer, intListA As Integer
Dim eDisc As String, eDisc2 As String, SigFile As String, myMonth As String
myMonth = Format(Now(), "mm")
If myMonth <> "12" Then
SigFile = "DMT dave@ Email Signature.jpg"
Else
SigFile = "DMT Xmas Signature.jpg"
End If
eDisc = "COMPANY REMOVED is a limited company registered in England and Wales, Registered number: REG REMOVED." & vbNewLine & _
"Registered office: ADDRESS REMOVED"
eDisc2 = "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." & vbNewLine & _
"If you are not the name recipient(s) you are hereby notified that any copying or distribution of this message, or files associated with this message, is strictly prohibited." & vbNewLine & _
"If you have received this message in error, please notify us immediately by replying to this email and deleting from your computer." & vbNewLine & _
"Any files attached to this email will have been checked with anti virus detection software prior to sending, but you should carry out your own virus check before opening any attachment." & vbNewLine & _
"COMPANY REMOVED do not accept liability for any loss or damage which may be caused by software viruses."
lne = ".........................................................................................................."
wkr = "With Kind Regards"
UserName = Forms!frmMainMenu!txtLogin
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then
Set OutApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
For intListA = 0 To Me.lstAdded.ListCount - 1
For intListB = 0 To Me.lstDeliveries.ListCount - 1
For intListC = 0 To Me.lstCollections.ListCount - 1
a = Me.lstAdded.Column(0) & ", " & Me.lstAdded.Column(1) & ", " & Me.lstAdded.Column(2) & ", " & Me.lstAdded.Column(3) & ", " & Me.lstAdded.Column(4) _
& ", " & Me.lstAdded.Column(5) & ", " & Me.lstAdded.Column(6) & ", " & Me.lstAdded.Column(7) & ", " & Me.lstAdded.Column(8) & "|"
b = Me.lstDeliveries.Column(0) & ", " & Me.lstDeliveries.Column(1) & ", " & Me.lstDeliveries.Column(2) & ", " & Me.lstDeliveries.Column(3) & ", " & Me.lstDeliveries.Column(4) _
& ", " & Me.lstDeliveries.Column(5) & ", " & Me.lstDeliveries.Column(6) & ", " & Me.lstDeliveries.Column(7) & ", " & Me.lstDeliveries.Column(8) & "|"
c = Me.lstCollections.Column(0) & ", " & Me.lstCollections.Column(1) & ", " & Me.lstCollections.Column(2) & ", " & Me.lstCollections.Column(3) & ", " & Me.lstCollections.Column(4) _
& ", " & Me.lstCollections.Column(5) & ", " & Me.lstCollections.Column(6) & ", " & Me.lstCollections.Column(7) & ", " & Me.lstCollections.Column(8) & "|"
Me.lstAdded.Selected(intListA) = True
Me.lstDeliveries.Selected(intListB) = True
Me.lstCollections.Selected(intListC) = True
Set OutMail = OutApp.CreateItem(olMailItem)
Set OutAccount = OutMail.Session.Accounts.Item(1)
With OutMail
.To = Me.cboEmailTo.Column(3)
.subject = SubStart & Forms!frmSearch!txtFind & " " & "DMT Results Found"
.HTMLBody = lne & "<br>" & "ITEMS ADDED TO THE SYSTEM" & "<br> " & _
Replace(a, "|", "<br>") & "<br>" & lne & _
"ITEMS IN DELIVERIES " & _
Replace(b, "|", "<br>") & "<br>" & lne & _
"ITEMS IN COLLECTIONS " & _
Replace(c, "|", "<br>") & "<br>" & lne & _
wkr & "<br>" & "<br>" & _
UserName & "<br>" & "<br>" & _
"<P><IMG border=0 hspace=0 alt='' src='file://T:/DMT Ltd/Logo Media/" & SigFile & "' align=baseline></P>" & "<br>" & "<br>" & _
"<FONT color=#00008B>" & eDisc & "<br>" & "<FONT color =#00008B>" & eDisc2
.SendUsingAccount = OutAccount
.Display
End With
Next intListA
Next intListB
Next intListC
Set OutMail = Nothing
Set OutApp = Nothing
Windows 10 
Access 2016
Reply With Quote
Originally Posted by DMT Dave
