Xojo Conferences
MBSSep2018MunichDE
XDCMay2019MiamiUSA

Platforms to show: All Mac Windows Linux Cross-Platform

/CURL/Send Email/MassEmailer
Function:
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, 24th Jul 2018.
Project "MassEmailer.rbp"
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 a(-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) a.Shuffle dim count as integer dim ua as integer = UBound(a) if ua > 3 and CheckDebug.Value then MsgBox "Don't debug send with so many emails." Return end if for ia as integer = 0 to ua count = count + 1 dim aa as string = a(ia) aa=trim(aa) if len(aa)>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(aa,chr(9),1) if CheckDebug.Value then emailaddress = "zivi@mac.com" // <-- change end if dim name as string = NthField(aa,chr(9),2) dim text as string = NthField(aa,chr(9),3) dim EmailID as string = NthField(aa,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 d as string = b.Read(b.Length) email.AddAttachment d, file.Name next dim curl as new MyCURL curl.OptionBufferSize = 16*1024 if curl.SetupEmail(email) then // ok else dim ee as integer = curl.Lasterror Break // problem? end if curl.email = email curl.YieldTime = true curl.OptionVerbose = true curl.CollectOutputData = true curl.CollectDebugData = 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 = aa 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 debugData as string = curl.DebugData 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 debugData = ReplaceLineEndings(debugData, EndOfLine) dim d as new date CURLLog.WriteLine d.SQLDateTime CURLLog.WriteLine debugData 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:

Feedback, Comments & Corrections

The items on this page are in the following plugins: MBS CURL Plugin.





Links
MBS Xojo Plugins