SendMail with Attachments

Tuesday Nov 19th 2002 by Sam Huggill
Share:

Sendmail with attachments

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:\windows\autoexec.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) 

Share:
Home
Mobile Site | Full Site
Copyright 2017 © QuinStreet Inc. All Rights Reserved