by Pablo Cuadrado (1 Submission)
Category: Internet/HTML
Compatability: VB Script
Difficulty: Intermediate
Date Added: Wed 3rd February 2021
Rating: 
(3 Votes)
It's a function that allows you to send an e-mail with both HTML and Plain Text formats, using the Winsock control. It's an enhancement to Brian Anderson's code.
Inputs
SourceForm, DestAddress, Server, Optional BodyHTML, Optional BodyTXT, Optional SenderName, Optional SenderAddress, Optional DestName, Optional Subject.
Assumes
You gotta have a Winsock control or create an instance of it.
Code Returns
SMTP Errors, status codes.
Side Effects
None.
API Declarations' A global variable.
Public Response As String
VBcoders' Did you declare the global variable:
' Public Response As String ?
Dim Start As Single, Tmr As Single
Public Sub HTMLMail(Server As String, SourceForm As Form, DestAddress As String, BodyHTML As String, Optional BodyTXT As String = "", Optional SenderName As String = "", Optional SenderAddress As String = "", Optional DestName As String = "", Optional Subject As String = "")
' HTMLMail
' by Pablo Cuadrado - Argentina
' Estudio Quadra - Innovating the Internet
'
' Created on Friday, October 15th, 2004.
'
' Uses Winsock object to connect to a SMTP server.
'
' I have seen a lot of answers on how to do more
' than sending a plain text mail on a code posted
' by Brian Anderson. Well, this is is a Multipart
' mail, so you can send even more things.
'
' I've made a class which allows you to create
' multipart mails, contact me if you wish to have
' it. This is just a simple FUNCTION, that allows
' a "Bi-part" mail, with both a plain text and a
' HTML message embedded.
'
' By getting the right MIME types, you can embed
' anything (pics, files, etc.) on an e-mail.
'
' There is a SourceForm parameter:
' you can call the function in a form with a Winsock
' control, just by adding, for instance:
' ...Command1_Click ()
' HTMLMail "smtp.myserver.com", Me, ... and so on.
'
' The keyword "Me" is the form object itself.
' I did this in a project with more than one Winsock control.
' You may delete that parameter, and then in the line:
' With SourceForm.Winsock
' Just specify wich control will you use.
Dim Header(40) As String
Dim i As Integer
Dim StatusOutput As String
Dim Headers As String
Dim MIMEDate As String, MIMEHeaders As String
With SourceForm.SCWinsock
If .State = sckClosed Then
MIMEDate = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600"
Header(1) = "mail from: " & Chr(32) & SenderAddress & vbCrlf
Header(2) = "rcpt to: " & DestAddress & vbCrlf
Header(3) = "Date: " & MIMEDate & vbCrlf
Header(4) = "From: """ & SenderName & """ <" & SenderAddress & ">" + vbCrlf
Header(5) = "To: " & DestName & vbCrlf
Header(6) = "Subject: " & Subject & vbCrlf
Header(7) = "MIME-Version: 1.0" & vbCrlf
Header(8) = "Content-Type: multipart/alternative;" & vbCrlf
' Here is the trick: you make a string (boundary) that divides the parts.
Header(9) = " boundary = " & Chr(34) & "----=Division" & Chr(34) & ";" & vbCrlf
Header(10) = "X-Mailer: YourApp" & vbCrlf
' The order for the headers:
' From - Date - MimeHeaders - X-Headers - To - Subject
MIMEHeaders = Header(7) & Header(8) & Header(9)
Headers = Header(4) & Header(3) & MIMEHeaders & Header(10) & Header(5) & Header(6)
' Plain Text Part
' ===============
'
' The division goes with the prefix "--"
' Many programs uses strings starting with "-" to make a visible line.
' M$ Outlook does.
Header(11) = "------=Division"
Header(12) = "Content-Type: text/plain;"
Header(13) = " charset = " & Chr(34) & "iso-8859-1" & Chr(34) & ";"
Header(14) = vbCrlf & vbCrlf
Header(15) = BodyTXT & vbCrlf ' Cuerpo
' HTML Text Part
' ==============
Header(16) = "------=Division"
Header(17) = "Content-Type: text/html;"
Header(18) = " charset = " & Chr(34) & "iso-8859-1" & Chr(34)
Header(19) = "Content-Transfer-Encoding: quoted-printable" & vbCrlf
' Remove the header to ensure HTML compatibility.
'Header(19) = vbCrlf
Header(20) = BodyHTML & vbCrlf ' Cuerpo
' The last division hast both an "--" prefix, and a "--" suffix.
Header(21) = "------=Division--" & vbCrlf
.LocalPort = 0
.Protocol = sckTCPProtocol
.RemoteHost = Server
.RemotePort = 25
.Connect
WaitFor ("220")
StatusOutput = "Connecting..."
' Whenever there's an StatusOutput, you could
' point it to a text or label on your app to
' create a visible status.
.SendData ("HELO " & Server & vbCrlf)
WaitFor ("250")
StatusOutput = "Connected..."
' First command (mail from)
.SendData (Header(1))
StatusOutput = "Sending..."
WaitFor ("250")
' Second (rcpt to)
.SendData (Header(2))
WaitFor ("250")
.SendData ("data" & vbCrlf)
WaitFor ("354")
' The rest
.SendData Headers & vbCrlf
' This line is often found on MIME messages.
.SendData "This is a multi-part message in MIME format." & vbCrlf
.SendData vbCrlf
For i = 11 To 20
.SendData (Header(i) & vbCrlf)
Next i
.SendData (Header(21) & vbCrlf)
' Terminate
.SendData ("." & vbCrlf)
WaitFor ("250")
' Quit
.SendData ("quit" & vbCrlf)
StatusOutput = "Unconnected..."
WaitFor ("221")
.Close
StatusOutput = ""
Else
Select Case .State
Case 1
StatusOutput = "Socket Opened."
Case 2
StatusOutput = "Listening..."
Case 3
StatusOutput = "Connection pending"
Case 4
StatusOutput = "Resolving host"
Case 5
StatusOutput = "Host resolved"
Case 6
StatusOutput = "Connecting"
Case 7
StatusOutput = "Connected"
Case 8
StatusOutput = "The point is closing the connection."
Case 9
StatusOutput = "Error."
Case Else
StatusOutput = "Undefined."
End Select
' Just a box in case anything happens.
MsgBox (StatusOutput)
End If
End With
End Sub
Sub WaitFor(ResponseCode As String)
Start = Timer
While Len(Response) = 0
Tmr = Start - Timer
DoEvents
If Tmr > 50 Then
MsgBox "SMTP service error, timed out while waiting for response", 64, "Error!"
Exit Sub
End If
Wend
While Left(Response, 3) <> ResponseCode
DoEvents
If Tmr > 50 Then
MsgBox "SMTP service error, impromper response code. Code should have been: " + ResponseCode + " Code recieved: " + Response, 64, "Error"
Exit Sub
End If
Wend
Response = ""
End Sub
'
' The following code goes wherever the Winsock
' control is placed.
'
Private Sub SCWinsock_DataArrival(ByVal bytesTotal As Long)
SCWinsock.GetData Response
End Sub
