After writing the initial
SendMail tutorial, many people emailed in asking how they could send an
email but add an attachment. After performing a search on the great
Planet Source Code, I came across a similar piece of code that allows
you to send with attachments. After making some modifications to this
code and generally cleaning it up, I have posted it with this article
for you.
The first thing that we are
going to do is to create the User Interface, based around one form, that
will interact with out Sendmail module. Open VB and start a new Standard
EXE Project. Add a form (frmDemo) and add the following controls to the
form:
txtServer, txtFromAddress,
txtToAddress, txtSubject, txtAttach, txtBody, lblStatus, cmdSend,
cmdSelect, cmdClose, txtOutput, rtfAttach, Winsock1, cmdDialog
Now add the following code to
the form:
Option Explicit
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub cmdSelect_Click()
cmdDialog.ShowOpen
txtAttach = cmdDialog.filename
End Sub
Private Sub cmdSend_Click()
cmdSend.Enabled = False
If ValidateEntry = False Then
MsgBox _
"Either the server name or to address were left _
empty.", _
vbCritical + vbOKOnly, Me.Caption
cmdSend.Enabled = True
Exit Sub
End If
If txtAttach.Text <> "" Then
lblStatus = "Encoding file attachment"
Base64EncodeFile txtAttach.Text, rtfAttach, txtOutput
End If
lblStatus = "Connecting to POP Server"
ConnectToServer txtServer.Text, Winsock1
End Sub
Private Sub Form_Load()
txtAttach = ""
txtBody = ""
txtFromAddress = ""
txtServer = ""
txtSubject = ""
txtToAddress = ""
End Sub
Private Sub Winsock1_Connect()
lblStatus = "Connected to POP Server"
Wait 0.5
lblStatus = "Sending mail"
If txtAttach.Text = "" Then
SendMail txtFromAddress, txtToAddress, txtSubject, _
txtBody, Winsock1
Else
SendMail txtFromAddress, txtToAddress, txtSubject, _
txtBody, Winsock1, txtAttach, txtOutput
End If
lblStatus = "Mail sent"
cmdSend.Enabled = True
lblStatus = "Status:"
End Sub
Private Sub Winsock1_Error(ByVal Number As Integer, _
Description As String, ByVal Scode As Long, _
ByVal Source As String, ByVal HelpFile As String, _
ByVal HelpContext As Long, CancelDisplay As Boolean)
MsgBox "Error Number: " & Number & vbCrLf & _
Description & vbCrLf & Source, vbCritical + _
vbOKOnly, _
Me.Caption
End Sub
Private Function ValidateEntry() As Boolean
ValidateEntry = True
If txtServer.Text = "" Or txtToAddress = "" _
Then ValidateEntry = False
End Function
Next we need to create a module that will
actually contain all the code we need to carry out the Sendmail
procedure. Attaching files isn’t a very easy operation: First we need to
encode the file for transport. To do this we use a function called
Base64Encode. Unfortunately this function only accepts three characters
at a time so we need another function, Base64EncodeFile which loops
through the file encoding all the contents of the file.
We actually carry out the Sendmail
function in the Winsock1.Connect procedure, where a file attachment is
detected and if it is there, it is added.
Copy the following code into the
modSendMail.bas module:
Option Explicit
' Base64Encode(strOriginal)
' Base64Encode("the") would return "dGjl"
' You can only pass three letters as the arguement
Public Function Base64Encode(strOriginal As String)
Dim intCount As Integer
Dim strBinary As String
Dim intDecimal As Integer
Dim strTemp As String
intDecimal = Asc(Left$(strOriginal, 1))
For intCount = 7 To 0 Step -1
If (2 ^ intCount) <= intDecimal Then
strBinary = strBinary & "1"
intDecimal = intDecimal - (2 ^ intCount)
Else
strBinary = strBinary & "0"
End If
Next
If Len(strOriginal) < 3 Then GoTo unfpassone
intDecimal = Asc(Mid$(strOriginal, 2, 1))
For intCount = 7 To 0 Step -1
If (2 ^ intCount) <= intDecimal Then
strBinary = strBinary & "1"
intDecimal = intDecimal - (2 ^ intCount)
Else
strBinary = strBinary & "0"
End If
Next
If Len(strOriginal) < 3 Then GoTo unfpassone
intDecimal = Asc(Right$(strOriginal, 1))
For intCount = 7 To 0 Step -1
If (2 ^ intCount) <= intDecimal Then
strBinary = strBinary & "1"
intDecimal = intDecimal - (2 ^ intCount)
Else
strBinary = strBinary & "0"
End If
Next
unfpassone:
For intCount = 1 To 19 Step 6
Select Case Val(Mid$(strBinary, intCount, 6))
Case 0
strTemp = strTemp & "A"
Case 1
strTemp = strTemp & "B"
Case 10
strTemp = strTemp & "C"
Case 11
strTemp = strTemp & "D"
Case 100
strTemp = strTemp & "E"
Case 101
strTemp = strTemp & "F"
Case 110
strTemp = strTemp & "G"
Case 111
strTemp = strTemp & "H"
Case 1000
strTemp = strTemp & "I"
Case 1001
strTemp = strTemp & "J"
Case 1010
strTemp = strTemp & "K"
Case 1011
strTemp = strTemp & "L"
Case 1100
strTemp = strTemp & "M"
Case 1101
strTemp = strTemp & "N"
Case 1110
strTemp = strTemp & "O"
Case 1111
strTemp = strTemp & "P"
Case 10000
strTemp = strTemp & "Q"
Case 10001
strTemp = strTemp & "R"
Case 10010
strTemp = strTemp & "S"
Case 10011
strTemp = strTemp & "T"
Case 10100
strTemp = strTemp & "U"
Case 10101
strTemp = strTemp & "V"
Case 10110
strTemp = strTemp & "W"
Case 10111
strTemp = strTemp & "X"
Case 11000
strTemp = strTemp & "Y"
Case 11001
strTemp = strTemp & "Z"
Case 11010
strTemp = strTemp & "a"
Case 11011
strTemp = strTemp & "b"
Case 11100
strTemp = strTemp & "c"
Case 11101
strTemp = strTemp & "d"
Case 11110
strTemp = strTemp & "e"
Case 11111
strTemp = strTemp & "f"
Case 100000
strTemp = strTemp & "g"
Case 100001
strTemp = strTemp & "h"
Case 100010
strTemp = strTemp & "i"
Case 100011
strTemp = strTemp & "j"
Case 100100
strTemp = strTemp & "k"
Case 100101
strTemp = strTemp & "l"
Case 100110
strTemp = strTemp & "m"
Case 100111
strTemp = strTemp & "n"
Case 101000
strTemp = strTemp & "o"
Case 101001
strTemp = strTemp & "p"
Case 101010
strTemp = strTemp & "q"
Case 101011
strTemp = strTemp & "r"
Case 101100
strTemp = strTemp & "s"
Case 101101
strTemp = strTemp & "t"
Case 101110
strTemp = strTemp & "u"
Case 101111
strTemp = strTemp & "v"
Case 110000
strTemp = strTemp & "w"
Case 110001
strTemp = strTemp & "x"
Case 110010
strTemp = strTemp & "y"
Case 110011
strTemp = strTemp & "z"
Case 110100
strTemp = strTemp & "0"
Case 110101
strTemp = strTemp & "1"
Case 110110
strTemp = strTemp & "2"
Case 110111
strTemp = strTemp & "3"
Case 111000
strTemp = strTemp & "4"
Case 111001
strTemp = strTemp & "5"
Case 111010
strTemp = strTemp & "6"
Case 111011
strTemp = strTemp & "7"
Case 111100
strTemp = strTemp & "8"
Case 111101
strTemp = strTemp & "9"
Case 111110
strTemp = strTemp & "+"
Case 111111
strTemp = strTemp & "/"
End Select
Next
Base64Encode = strTemp
End Function
' Base64EncodeFile(strFile,rtfTemp,txtOutput)
' Base64EncodeFile "c:windowsautoexec.bat",rtfBox,txtBox
' The second parameter must be a rtf box or a control that supports the
' LoadFile command
Public Sub Base64EncodeFile(strFile As String, _
rtfTemp As RichTextBox, _
txtOutput As TextBox)
Dim intCount As Integer
Dim strTemp As String
Dim lngMax As Long
lngMax = 0
txtOutput.Text = ""
rtfTemp.LoadFile strFile
For intCount = 1 To Len(rtfTemp.Text) Step 3
strTemp = Mid(rtfTemp.Text, intCount, 3)
txtOutput.Text = txtOutput.Text & Base64Encode(strTemp)
lngMax = lngMax + 4
If lngMax = 72 Then
lngMax = 0
txtOutput.Text = txtOutput.Text & vbCrLf
End If
DoEvents
Next intCount
End Sub
' ConnectToServer(strServer, wsk, strSrvPort)
' ConnectToServer "pop.microsoft.com", Winsock1, 25
' Normally leave out the last arguement and let the Winsock control use
' the default port.
Public Sub ConnectToServer(strServer As String, _
wsk As Winsock, _
Optional strSrvPort As String)
wsk.RemoteHost = strServer
If strSrvPort = "" Then
wsk.RemotePort = 25
Else
wsk.RemotePort = Val(strSrvPort)
End If
wsk.Connect
End Sub
' ExtractArgument(ArgNum, srchstr, Delim)
' ExtractArgument(3, "No 1, No 2, No 3", ",") Would return No 3
' I did not have time to sort out the variable names in this function,
' so if you can be bothered to, please send it to me at sam@vbsquare.com
Private Function ExtractArgument( _
ArgNum As Integer, _
srchstr As String, _
Delim As String) As String
On Error GoTo Err_ExtractArgument
Dim ArgCount As Integer
Dim LastPos As Integer
Dim Pos As Integer
Dim Arg As String
Arg = ""
LastPos = 1
If ArgNum = 1 Then Arg = srchstr
Do While InStr(srchstr, Delim) > 0
Pos = InStr(LastPos, srchstr, Delim)
If Pos = 0 Then
If ArgCount = ArgNum - 1 Then Arg = Mid(srchstr, LastPos)
Exit Do
Else
ArgCount = ArgCount + 1
If ArgCount = ArgNum Then
Arg = Mid(srchstr, LastPos, Pos - LastPos)
Exit Do
End If
End If
LastPos = Pos + 1
Loop
ExtractArgument = Arg
Exit Function
Err_ExtractArgument:
MsgBox "Error " & Err & ": " & Error
Resume Next
End Function
Public Sub SendMail(strFrom As String,_
strTo As String,_
strSubject As String,_
strBody As TextBox,_
wsk As Winsock,_
Optional strAttachName As String,_
Optional txtEncodedFile As Control)
Dim intCount As Integer
Wait 0.5
wsk.SendData "EHLO " & wsk.LocalIP & vbCrLf
wsk.SendData "MAIL FROM:" & strFrom & vbCrLf
Wait 0.5
wsk.SendData "RCPT TO:" & strTo & vbCrLf
wsk.SendData "DATA" & vbCrLf
Wait 0.5
wsk.SendData "MIME-Version: 1.0" & vbCrLf
wsk.SendData "From: " & ExtractArgument(1, strFrom, "@") & " <" & strFrom & ">" & vbCrLf
wsk.SendData "To: <" & strTo & ">" & vbCrLf
wsk.SendData "Subject: " & strSubject & vbCrLf
wsk.SendData "Content-Type: multipart/mixed;" & vbCrLf
wsk.SendData " boundary=Unique-Boundary" & vbCrLf & vbCrLf
wsk.SendData " [ Random garbage here ]" & vbCrLf & vbCrLf
wsk.SendData vbCrLf & "--Unique-Boundary" & vbCrLf
wsk.SendData "Content-type: text/plain; charset=US-ASCII" & vbCrLf & vbCrLf
wsk.SendData strBody.Text & vbCrLf & vbCrLf
If LTrim(RTrim(strAttachName)) <> "" Then
For intCount = Len(strAttachName) To 1 Step -1
If Mid(strAttachName, intCount, 1) = "" Then
strAttachName = Mid(strAttachName, intCount + 1)
GoTo lala
End If
Next intCount
lala:
wsk.SendData "--Unique-Boundary" & vbCrLf
wsk.SendData "Content-Type: multipart/parallel; boundary=Unique-Boundary-2" & vbCrLf & vbCrLf
wsk.SendData "--Unique-Boundary-2" & vbCrLf
wsk.SendData "Content-Type: application/octet-stream;" & vbCrLf
wsk.SendData " name=" & strAttachName & vbCrLf
wsk.SendData "Content-Transfer-Encoding: base64" & vbCrLf
wsk.SendData "Content-Disposition: inline;" & vbCrLf
wsk.SendData " filename=" & strAttachName & vbCrLf & vbCrLf
wsk.SendData txtEncodedFile.Text & "==" & vbCrLf
wsk.SendData "--Unique-Boundary-2----Unique-Boundary--"
End If
wsk.SendData vbCrLf & "." & vbCrLf
Wait 0.5
wsk.SendData "QUIT" & vbCrLf
Wait 0.5
wsk.Close
End Sub
' Wait(WaitTime)
' Wait 0.5
Public Sub Wait(WaitTime)
Dim StartTime As Double
StartTime = Timer
Do While Timer < StartTime + WaitTime
If Timer > 86395 Or Timer = 0 Then Exit Do
DoEvents
Loop
End Sub
All that works well on a normal Dial up
connection (although you will have to test it over a LAN, because I had
problems using it on mine).
Download the Sendmail with attachments
demo project (93.3KB)
