Platforms to show: All Mac Windows Linux Cross-Platform
Required plugins for this example: MBS CURL Plugin, MBS Util Plugin
You find this example project in your Plugins Download as a Xojo project file within the examples folder: /CURL/Send Email/MassEmailer
This example is the version from Wed, 3rd Jan 2023.
Project "MassEmailer.xojo_binary_project"
Class App Inherits Application
Const kEditClear = "&Löschen"
Const kFileQuit = "Beenden"
Const kFileQuitShortcut = ""
EventHandler Sub Open()
'Register MBS Plugins // <-- change
'BugReporter.init if you have MBS Bugreporter Kit
End EventHandler
EventHandler Function UnhandledException(error As RuntimeException) As Boolean
'return BugReporter.UnhandledException(error)
End EventHandler
End Class
Class MassEmailWindow Inherits Window
Control InputEmails Inherits TextArea
ControlInstance InputEmails Inherits TextArea
End Control
Control StaticText1 Inherits Label
ControlInstance StaticText1 Inherits Label
End Control
Control SubjectLine Inherits TextField
ControlInstance SubjectLine Inherits TextField
End Control
Control StaticText2 Inherits Label
ControlInstance StaticText2 Inherits Label
End Control
Control StaticText3 Inherits Label
ControlInstance StaticText3 Inherits Label
End Control
Control PushButton1 Inherits PushButton
ControlInstance PushButton1 Inherits PushButton
EventHandler Sub Action()
send
End EventHandler
End Control
Control StaticText4 Inherits Label
ControlInstance StaticText4 Inherits Label
End Control
Control InputFrom Inherits TextField
ControlInstance InputFrom Inherits TextField
End Control
Control status Inherits Listbox
ControlInstance status Inherits Listbox
EventHandler Function CellBackgroundPaint(g As Graphics, row As Integer, column As Integer) As Boolean
if row < me.ListCount and row <> me.ListIndex then
dim error as Boolean = me.CellTag(row, column)
if error then
g.ForeColor = &cFFCCCC
g.FillRect 0, 0, g.Width, g.Height
return true
end if
end if
End EventHandler
End Control
Control InputBCC Inherits TextField
ControlInstance InputBCC Inherits TextField
End Control
Control StaticText5 Inherits Label
ControlInstance StaticText5 Inherits Label
End Control
Control CheckDebug Inherits CheckBox
ControlInstance CheckDebug Inherits CheckBox
EventHandler Sub Open()
me.Value=DebugBuild
End EventHandler
End Control
Control StartTimer Inherits Timer
ControlInstance StartTimer Inherits Timer
EventHandler Sub Action()
dim r as integer = RunningCount
if r > 10 then
Return
end if
for each s as MyCURL in curls
if s.Started = false then
s.SendMail
Return
end if
next
log "All SMTP Sockets started."
me.Mode = 0
bar.Value = bar.Maximum
End EventHandler
End Control
Control CheckDelay Inherits CheckBox
ControlInstance CheckDelay Inherits CheckBox
End Control
Control AttachButton Inherits PushButton
ControlInstance AttachButton Inherits PushButton
EventHandler Sub Action()
dim f as FolderItem = GetOpenFolderItem("")
redim files(-1)
if f<>Nil then
files.Append f
Filename.text = f.name
else
Filename.text = ""
end if
End EventHandler
End Control
Control Filename Inherits Label
ControlInstance Filename Inherits Label
End Control
Control bar Inherits ProgressBar
ControlInstance bar Inherits ProgressBar
End Control
Control BarTimer Inherits Timer
ControlInstance BarTimer Inherits Timer
EventHandler Sub Action()
dim count as integer = UBound(curls)+1
dim Finished as integer = 0
for each s as MyCURL in curls
if s.Finished then
Finished = Finished + 1
end if
next
if count = 0 then
if bar.Maximum<>1 then
bar.Maximum = 1
end if
if bar.Value<>0 then
bar.Value = 0
end if
else
if bar.Maximum<>count then
bar.Maximum = count
end if
if bar.Value<>Finished then
bar.Value = Finished
end if
end if
End EventHandler
End Control
Control TabPanel1 Inherits TabPanel
ControlInstance TabPanel1 Inherits TabPanel
End Control
Control PlainTextField Inherits TextArea
ControlInstance PlainTextField Inherits TextArea
End Control
Control HTMLTextField Inherits TextArea
ControlInstance HTMLTextField Inherits TextArea
End Control
Control CURLTimer Inherits Timer
ControlInstance CURLTimer Inherits Timer
EventHandler Sub Action()
CurlMulti.Perform
End EventHandler
End Control
Control PushButton2 Inherits PushButton
ControlInstance PushButton2 Inherits PushButton
EventHandler Sub Action()
StartTimer.mode = 0
CURLTimer.Mode = 0
if CurlMulti <> nil then
redim CurlMulti.queue(-1)
end if
End EventHandler
End Control
Control PasteButton Inherits PushButton
ControlInstance PasteButton Inherits PushButton
EventHandler Sub Action()
dim c as new Clipboard
dim s as string = c.Text
s = ReplaceLineEndings(s, EndOfLine)
dim lines() as string = split(s, EndOfLine)
if lines.Ubound > 2 and lines(1).trim <> "" then
// nothing
PlainTextField.Text = s
else
SubjectLine.Text = lines(0)
lines.Remove 0
lines.Remove 0
PlainTextField.Text = Join(lines, EndOfLine)
end if
End EventHandler
End Control
EventHandler Function CancelClose(appQuitting as Boolean) As Boolean
for each s as MyCURL in curls
if s.Started = false then
MsgBox "Da wird noch gesendet."
Return true
end if
next
End EventHandler
EventHandler Sub Close()
if t<>nil then
t.Close
end if
End EventHandler
EventHandler Sub Open()
dim d as new date
dim s as string = d.SQLDateTime.ReplaceAll(":", "-")
dim f as new FolderItem("MassEmail log "+s+".txt")
if f.Exists then
t=f.AppendToTextFile
else
t=f.CreateTextFile
end if
CurlMulti = new MyCURLMulti
End EventHandler
Function ConvertToASCII(s as string) As string
Return ConvertEncoding(s,encodings.ASCII)
End Function
Function ConvertToISO(s as string) As string
s=ConvertEncoding(s,encodings.ISOLatin1)
Return s
End Function
Function ConvertToQuotedPrintable(s as string) As string
Return EncodeQuotedPrintable(s)
End Function
Sub Finished()
for each c as MyCURL in curls
if not c.started then
Return
end if
next
log "All finished"
CURLTimer.Mode = 0
dim Emails() as string
dim FEmails() as string
for each c as MyCURL in curls
emails.Append c.EmailLine
if c.Failed then
FEmails.Append c.EmailLine
end if
next
InputEmails.Text = Join(femails, EndOfLine)
redim curls(-1)
End Sub
Function RunningCount() As Integer
dim n as integer = 0
for each c as MyCURL in curls
if c.Finished then
Continue
end if
if c.started then
n = n + 1
end if
next
Return n
End Function
Sub log(s as string, error as Boolean = false)
try
if t <> nil then
t.WriteLine s
t.Flush
end if
catch io as IOException
status.AddRow "IOException in writing log!"
t = nil
end try
status.AddRow s
status.CellTag(status.LastIndex, 0) = error
End Sub
Sub send()
dim InputText as string = InputEmails.Text.trim
if InputText = "" then
// email recipient for testing
dim tab as string = encodings.utf8.chr(9)
InputText = "zivi@me.com"+tab+"Your Name" // <-- change
end if
dim EmailAddresses(-1) as string = split(ReplaceLineEndings(InputText, EndOfLine),EndOfLine)
dim r as new random
if t=nil then
MsgBox "no log file?"
Return
end if
redim curls(-1)
EmailAddresses.Shuffle
dim count as integer
dim EmailAddressesUbound as integer = UBound(EmailAddresses)
if EmailAddressesUbound > 3 and CheckDebug.Value then
MsgBox "Don't debug send with so many emails."
Return
end if
for ia as integer = 0 to EmailAddressesUbound
count = count + 1
dim CurrentEmailAddress as string = EmailAddresses(ia)
CurrentEmailAddress = trim(CurrentEmailAddress)
if len(CurrentEmailAddress)>0 then
dim BodyPlainText as string = PlainTextField.text
dim HTMLText as string = HTMLTextField.text
if len(HTMLText)>3 then
HTMLText = EncodingToHTMLMBS(HTMLText, 1)
end if
dim emailaddress as string = NthField(CurrentEmailAddress,chr(9),1)
if CheckDebug.Value then
emailaddress = "zivi@mac.com" // <-- change
end if
dim name as string = NthField(CurrentEmailAddress,chr(9),2)
dim text as string = NthField(CurrentEmailAddress,chr(9),3)
dim EmailID as string = NthField(CurrentEmailAddress,chr(9),4)
if name = "" and instr(BodyPlainText, "%name")>0 then
MsgBox "%name found, but no Names!"
Return
end if
if text = "" and instr(BodyPlainText, "%text")>0 then
MsgBox "%text found, but not texts!"
Return
end if
if name = "" and instr(HTMLText, "%name")>0 then
MsgBox "%name found, but no names!"
Return
end if
if text = "" and instr(HTMLText, "%text")>0 then
MsgBox "%text found, but no texts!"
Return
end if
if len(EmailID)>0 then
BodyPlainText = ReplaceAll(BodyPlainText, "**EmailID**", EmailID)
HTMLText = ReplaceAll(HTMLText, "**EmailID**", EncodingToHTMLMBS(EmailID))
end if
if len(text)>0 then
BodyPlainText = ReplaceAll(BodyPlainText, "%text%", text)
HTMLText = ReplaceAll(HTMLText, "%text%", EncodingToHTMLMBS(text))
end if
if len(name)>0 then
BodyPlainText=ReplaceAll(BodyPlainText, "%name%", name)
HTMLText = ReplaceAll(HTMLText, "%name%", EncodingToHTMLMBS(name))
end if
dim Subject as string = SubjectLine.text
if len(text)>0 then
Subject=ReplaceAll(Subject, "%text%", text)
end if
if len(name)>0 then
Subject=ReplaceAll(Subject, "%name%", name)
end if
dim from as string = InputFrom.text
BodyPlainText = ReplaceLineEndings(BodyPlainText, EndOfLine.windows)
HTMLText = ReplaceLineEndings(HTMLText, EndOfLine.windows)
dim email as new CURLEmailMBS
if BodyPlainText.len > 3 then
email.PlainText = BodyPlainText
end if
if HTMLText.len > 3 then
email.HTMLText = HTMLText
end if
email.SMTPUsername = "xxx" // <-- change
email.SMTPServer = "sslout.df.eu" // <-- change
email.SMTPPassword = "xxx" // <-- change
email.Subject = subject
email.SetFrom from, "Your Name" // <-- change
email.AddHeader "X-Mailer: MBS Emailer"
email.AddTo emailaddress, name
dim BCC as string = InputBCC.text.trim
if BCC.len>0 then
email.AddBCC BCC, "Your Name" // <-- change
end if
for each file as FolderItem in files
dim b as BinaryStream = BinaryStream.Open(file)
dim data as string = b.Read(b.Length)
email.AddAttachment data, file.Name
next
dim curl as new MyCURL
curl.OptionBufferSize = 16*1024
if curl.SetupEmail(email) then
// ok
else
dim curlLasterror as integer = curl.Lasterror
Break // problem?
end if
curl.email = email
curl.YieldTime = true
curl.OptionVerbose = true
curl.CollectOutputData = true
curl.CollectDebugMessages = true
curl.OptionPort = 587 // <-- change
curl.OptionSSLVerifyHost = 2
curl.OptionSSLVerifyPeer = 1
#if RBVersion >= 2013 then
curl.OptionCAInfo = SpecialFolder.Preferences.Child("sslout.df.eu.cer").NativePath // <-- change
#else
curl.OptionCAInfo = SpecialFolder.Preferences.Child("sslout.df.eu.cer").UnixpathMBS // <-- change
#endif
curl.OptionUseSSL = curl.kFTPSSL_ALL
curl.OptionSSLVersion = curl.kSSLVersionTLSv12
curl.destEmail = emailaddress
curl.EmailLine = CurrentEmailAddress
curl.CurlMulti = CurlMulti
curl.Started = false
curl.failed = false
curls.append curl
if not CheckDelay.Value then
curl.sendMail
end if
end if
next
log str(count)+" sockets..."
StartTimer.Mode = 2
CURLTimer.Mode = 2
End Sub
Property CurlMulti As MyCURLMulti
Property curls() As MyCURL
Property failed As Boolean
Property files() As FolderItem
Property t As TextOutputStream
End Class
MenuBar MenuBar1
MenuItem FileMenu = "&Ablage"
MenuItem FileQuit = "#App.kFileQuit"
MenuItem EditMenu = "&Bearbeiten"
MenuItem EditUndo = "&Rückgängig"
MenuItem UntitledMenu1 = "-"
MenuItem EditCut = "&Ausschneiden"
MenuItem EditCopy = "&Kopieren"
MenuItem EditPaste = "&Einfügen"
MenuItem EditClear = "#App.kEditClear"
MenuItem UntitledMenu0 = "-"
MenuItem EditSelectAll = "&Alles auswählen"
End MenuBar
SetRetina
End SetRetina
Class MyCURL Inherits CURLSMBS
Sub sendMail()
MassEmailWindow.CURLTimer.Mode = 2
started = true
CurlMulti.add(me)
End Sub
Property CurlMulti As MyCURLMulti
Property EmailLine As string
Property Failed As Boolean
Property Finished As Boolean
Property SecondTry As Boolean
Property TriedAgain As Boolean
Property destEmail As string
Property email As CURLEmailMBS
Property started As Boolean
End Class
Class MyCURLMulti Inherits CURLSMultiMBS
EventHandler Sub TransferFinished(curl as CURLSMBS, result as Integer, RemainingFinishedTransfers as Integer)
dim mycurl as MyCURL = MyCURL(curl)
mycurl.Finished = true
if result = 0 then
WriteEmailSent mycurl.destEmail
MassEmailWindow.log mycurl.destEmail+" sent."
else
MassEmailWindow.log "Error "+str(result)+" for "+mycurl.destEmail, true
mycurl.failed = true
end if
try
dim DebugMessages as string = curl.DebugMessages
if CURLLog = nil then
dim d as new date
dim s as string = d.SQLDateTime.ReplaceAll(":", "-")
dim f as FolderItem = GetFolderItem("curl " + s + ".log")
CURLLog = TextOutputStream.Append(f)
end if
if CURLLog <> nil then
DebugMessages = ReplaceLineEndings(DebugMessages, EndOfLine)
dim d as new date
CURLLog.WriteLine d.SQLDateTime
CURLLog.WriteLine DebugMessages
CURLLog.WriteLine
CURLLog.Flush
end if
catch io as IOException
// ignore
Break
end try
counter = counter - 1
if UBound(queue) >= 0 then
dim c as MyCURL = queue.Pop
if not me.AddCURL(C) then
Break
end if
me.counter = me.counter + 1
end if
End EventHandler
EventHandler Sub TransfersFinished()
MassEmailWindow.Finished
End EventHandler
Sub Add(c as MyCURL)
if me.Counter < 4 then
if not me.AddCURL(C) then
Break
end if
me.counter = me.counter + 1
else
queue.Append c
end if
End Sub
Sub WriteEmailSent(email as string)
if EmailsSentLogFile = nil then
dim d as new date
dim s as string = d.SQLDateTime.ReplaceAll(":", "-")
dim f as FolderItem = GetFolderItem("EmailsSent " + s + ".txt")
EmailsSentLogFile = TextOutputStream.Append(f)
end if
if EmailsSentLogFile <> nil then
EmailsSentLogFile.WriteLine email
EmailsSentLogFile.Flush
end if
End Sub
Property CURLLog As TextOutputStream
Property Counter As Integer
Property EmailsSentLogFile As TextOutputStream
Property queue() As MyCURL
End Class
Class EmailToSend
End Class
End Project
See also:
- /CURL/Send Email/IMAP Upload
- /CURL/Send Email/older examples/CURLS send email
- /CURL/Send Email/older examples/CURLS send email with images
- /CURL/Send Email/older examples/CURLS send email with SSL
- /CURL/Send Email/Send email
- /CURL/Send Email/Send Email in Background async
- /CURL/Send Email/Send email in web
The items on this page are in the following plugins: MBS CURL Plugin.
