Private Sub cmdEmail_Click() '20190410
Dim FileName As String
Dim emailText As String
Dim SaDatumom As String
Dim MyRs2 As Recordset
Dim varReturn As Variant
Dim OutlookCDO As String 'Saving the answer of the user, which method is he going to use, Outlook or CDO 20190531
'Variables for CDO
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant
Dim Pw As String
Dim objImage As Object
'Variables for Outlook, LateBinding. 20190531
Dim outMail As Object
Dim myInspector As Object
Dim OutApp As Object
Dim SendTo As String
Dim MailSubject As String
Dim PrikazatiEmail As Boolean 'Saving the answer of the user if he wants to preview the email before sending (manual sending)
Dim oAccount As String 'Email account for sending the mails
On Error GoTo Err_cmdEmail_Click
varReturn = SysCmd(acSysCmdSetStatus, "Sending Emails!")
DoCmd.Hourglass True
'''''''''''''' 20190531 '''''''''''''
Set MyDb = CurrentDb
Set MyRs = MyDb.OpenRecordset("SELECT * FROM Korisnik") 'table where Im storing the email address for sending mails
oAccount = MyRs!EmailAdr
If IsNull(oAccount) Then
MsgBox "Cant send Emails, your email address is missing!", vbCritical, "Title 1.0"
End If
If Not IsEmailAddress(oAccount) Then 'Checking if email address is valid with a function
DoCmd.Hourglass False
varReturn = SysCmd(acSysCmdSetStatus, " ")
MsgBox "Email address is not valid, you cant send the emails!", vbCritical, "Title 1.0"
Exit Sub
End If
'Now here Im checking if the sending method for email (CDO or Outlook) is set already in the table, if not then ask the user which one to use
'For now its O in the table, so Outlook as default without asking the user anything
Select Case MyRs!EmailVrs
Case "O"
OutlookCDO = "O"
Case "A"
OutlookCDO = "A"
Case Else
Again1:
'You can ignore this part its the inputbox but we are skipping it because Outlook is already set as default (I wont bother translating the msgbox)
OutlookCDO = InputBox("Unesite kako želite da pošaljete E-mailove." & Chr(13) & "Ako želite poslati putem Outlook-a (brža opcija) unesite slovo ""O"", a za slanje putem aplikacije unesite ""A"" (bez navodnika)" & Chr(13) & "Ako zelite odustati kliknite na Cancel", "Title 1.0")
Select Case OutlookCDO
Case "O", "A"
Case ""
DoCmd.Hourglass False
varReturn = SysCmd(acSysCmdSetStatus, " ")
Exit Sub
Case Else
MsgBox "Možete unijeti samo jednu od dvije ponuđene opcije!", vbCritical, "Title 1.0"
GoTo Again1
End Select
End Select
If OutlookCDO = "A" Then ' This is for CDO so ignore it aslo
''''''''''' Kraj '''''''''''''
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "anemailaddress@email.com"
Pw = InputBox("Unesite pasvord za anemailaddress@email.com" & Chr(13) & "Ako zelite odustati kliknite na Cancel", "Title 1.0")
If Pw = "" Then
DoCmd.Hourglass False
varReturn = SysCmd(acSysCmdSetStatus, " ")
Exit Sub
End If
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Pw
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Update
End With
End If
Again0:
'Now here Im asking the user to enter the date so I can filter which PDF files (emails) are going to be sent
SaDatumom = InputBox("Enter the date of reading (last day of the month) like 'dd.mm.gggg' npr. 31.03.2019 if you are sending emails for mart!" & Chr(13) & "If you want to stop, click Cancel", "Title 1.0")
If SaDatumom = "" Then '20190531
DoCmd.Hourglass False
varReturn = SysCmd(acSysCmdSetStatus, " ")
Exit Sub
ElseIf Not IsDate(SaDatumom) Or Len(SaDatumom) <> 10 Then
DoCmd.Hourglass False
varReturn = SysCmd(acSysCmdSetStatus, " ")
MsgBox "Your input is not a date", vbCritical, "Title 1.0"
Exit Sub
GoTo Again0:
End If
'Here Im writing a SQL code to see who of the customers needs to receive the email 20190419
SQL = "SELECT Potrosac.IdPotrosaca, RacUpl.IdRacUpl, First(IIf(IsNull([NazFirme]),[ImeNaziv],[NazFirme] & ' ' & [ImeNaziv])) AS Potr, First(Potrosac.Email) AS FirstOfEmail, First(Mid([RacUpl.DatumDo],4,2) & '/' & Right([RacUpl.DatumDo],4)) AS TekuciMje"
SQL = SQL & " FROM Potrosac INNER JOIN RacUpl ON Potrosac.IdPotrosaca = RacUpl.IdPotrosaca"
SQL = SQL & " WHERE RacUpl.DatumDo = cvdate('" & SaDatumom & "') AND Potrosac.ElektronskiRac = True AND RacUpl.DatumVriEma Is Null AND RacUpl.Vazeci = True"
'Give me only the customers Potrosac.ElektronskiRac = True (means the customer is selected for receiving the emails), RacUpl.DatumVriEma Is Null (this field is empty, once we send the email we write the current date and time in it) and RacUpl.Vazeci = True" (is a valid PDF file)
SQL = SQL & " GROUP BY Potrosac.IdPotrosaca, RacUpl.IdRacUpl"
SQL = SQL & " ORDER BY Potrosac.IdPotrosaca;"
Set MyRs = MyDb.OpenRecordset(SQL, dbOpenDynaset, dbSeeChanges) 'This Rs I use to send the email
Set MyRs1 = MyDb.OpenRecordset(SQL, dbOpenDynaset, dbSeeChanges) 'This Rs1 I use to check if all the Email addresses of the customers are valid and if all of the PDF files are existing
If Not MyRs1.EOF Then
MyRs1.MoveFirst
While Not MyRs1.EOF
FileName = Format(MyRs1!IdPotrosaca, "000000") & "_" & Left(MyRs1!TekuciMje, 2) & "_" & Right(MyRs1!TekuciMje, 2)
FilePath = "D:\PDFs\" & Right(MyRs1!TekuciMje, 4) & "god\" & FileName & ".pdf"
If Not FileExists(FilePath) Then
DoCmd.Hourglass False
varReturn = SysCmd(acSysCmdSetStatus, " ")
MsgBox "Cant send the emails because a PDF file for the customer " & MyRs1!Potr & ", ID Potrošača: '" & MyRs1!IdPotrosaca & "' is missing!", vbCritical, "Title 1.0"
Exit Sub
End If
If IsNull(MyRs!FirstOfEmail) Then '20190513
DoCmd.Hourglass False
varReturn = SysCmd(acSysCmdSetStatus, " ")
MsgBox "Cant send the email because the email address for the customer: " & MyRs1!Potr & ", ID Potrošača: '" & MyRs1!IdPotrosaca & "' is not valid", vbCritical, "Title 1.0"
Exit Sub
End If
MyRs1.MoveNext
Wend
Else
DoCmd.Hourglass False
varReturn = SysCmd(acSysCmdSetStatus, " ")
MsgBox "There is nothing to send", vbInformation, "Title 1.0"
Exit Sub
End If
If OutlookCDO = "O" Then 'Starting Outlook and checking if the user wants to see the email before sending 20190531
Set OutApp = OutlookApp()
If MsgBox("Do you want to preview the emails before sending?", vbYesNo, "Title 1.0") = vbYes Then
PrikazatiEmail = True
Else
PrikazatiEmail = False
End If
End If
If Not MyRs.EOF Then 'Starting to send the emails
MyRs.MoveFirst
While Not MyRs.EOF
Set iMsg = CreateObject("CDO.Message")
FileName = Format(MyRs!IdPotrosaca, "000000") & "_" & Left(MyRs!TekuciMje, 2) & "_" & Right(MyRs!TekuciMje, 2)
FilePath = "D:\PDFs\" & Right(MyRs!TekuciMje, 4) & "god\" & FileName & ".pdf"
emailText = emailText & _
"<style>.my_text {font-family: Calibri;}" & _
".my_sign {font-family: Calibri;}</style>" & _
"<div class=""my_text""><p style= 'margin:0;'>Poštovani,</p>" & _
"<p class=""my_text"">Here is the PDF name " & MyRs!TekuciMje & ".<br> " & _
"<br>" & _
"Ukoliko trebate bilo kakve dodatne informacije, kontaktirati nas možete na:<br>" & _
"Tel/fax: +000 000 000;<br>" & _
"Company name<br>" & _
"-----------------------------------------------------------------<br>" & _
"Ova poruka je automatski generisana, te Vas molimo da ne odgovarate na nju.</p></div>"
If OutlookCDO = "A" Then 'Its CDO, so skipping (ignore it)
With iMsg
Set .Configuration = iConf
.To = MyRs!FirstOfEmail
.CC = ""
.BCC = ""
.From = """The Hello"" <emailaddress@email.com>"
.Subject = "Some firm name, račun za " & MyRs!TekuciMje & ""
.HTMLBody = emailText & GetTextFileContents("D:\XXX\potpis.html") & "<html><br><div align=""center""><img src=""cid:XXXX.gif""></div></html>"
'20190419 logo za email
Set objImage = iMsg.AddRelatedBodyPart("D:\XXX\XXXX.gif", "XXXX.gif", cdoRefTypeId)
objImage.Fields.Item("urn:schemas:mailheader:Content-ID") = "<XXXX.gif>"
objImage.Fields.Update
.HTMLBodyPart.Charset = "utf-8"
.AddRelatedBodyPart "D:\XXX\XXXX.gif", "XXXX.gif", cdoRefTypeId
.AddAttachment FilePath
.Send
End With
Set iMsg = Nothing
Else
'Sending the emails finaly
Set outMail = OutApp.CreateItem(0)
With outMail
SendTo = MyRs!FirstOfEmail
MailSubject = "Firm name, račun za " & MyRs!TekuciMje & ""
.To = SendTo
.Subject = MailSubject
'Set myInspector = .GetInspector
.Display
.HTMLBody = emailText & outMail.HTMLBody & GetTextFileContents("D:\XXX\XXXX.html") & "<div align=""center""><p><img src=""D:\XXX\XXXX.gif"" align=""middle""></p></div>" 'Besides the text Im inserting a signature
.Attachments.Add FilePath
Set .SendUsingAccount = OutApp.Session.Accounts.Item(oAccount)
If Not PrikazatiEmail Then
.Send
Else
.Display
If MsgBox("Did you send the Email successfuly?", vbYesNo) = vbNo Then
DoCmd.Hourglass False
varReturn = SysCmd(acSysCmdSetStatus, " ")
MsgBox "Check the customer and the PDF file!", vbCritical, "Title 1.0"
Exit Sub
End If
End If
End With
End If
Set MyRs2 = MyDb.OpenRecordset("SELECT * FROM RacUpl WHERE IdRacUpl = " & MyRs!IdRacUpl & "") 'Writing the current date and time in the filed to know that the email has been sent
With MyRs2
.Edit
!DatumVriEma = (Now)
.Update
End With
emailText = ""
MyRs.MoveNext
Wend
DoCmd.Hourglass False
varReturn = SysCmd(acSysCmdSetStatus, " ")
MsgBox "Emails sent successfuly.", vbInformation, "Title 1.0"
End If
Exit_cmdEmail_Click:
Exit Sub
Err_cmdEmail_Click:
DoCmd.Hourglass False
varReturn = SysCmd(acSysCmdSetStatus, " ")
Select Case Err.Number
Case -2147220973 'Could be because of Internet Connection
MsgBox " Provjerite da li imate internet vezu !! -- " & Err.Description, vbCritical, "Title 1.0"
Case -2147220975 'Incorrect credentials User ID or password
MsgBox "Pogrešan pasvord !! -- " & Err.Description, vbCritical, "Title 1.0"
Case -2147220977 'That is, there’s an incorrect email address into the recipients line. 20190513
MsgBox "Email-ove nije moguće poslati jer za potrošača: " & MyRs1!Potr & ", ID Potrošača: '" & MyRs1!IdPotrosaca & "' je neispravna e-mail adresa ili nije unešena. Unesite ispravnu e-mail adresu na formi Potrošači pa pokrenite ponovno ovu akciju", vbCritical, "Title 1.0"
Case Else 'Rest other errors
MsgBox "Greška pri slanju email-a !! -- " & Err.Description, vbCritical, "Title 1.0"
End Select
Set iConf = Nothing
Set Flds = Nothing
Resume Exit_cmdEmail_Click
End Sub
