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

    On Error GoTo vbErrHand

    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

    Exit Function

vbErrHand:

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 Function Base64EncodeFile(strFile As String, rtfTemp As RichTextBox, txtOutput As TextBox) As Boolean

    Dim intCount As Integer
    Dim strTemp As String
    Dim lngMax As Long

    On Error GoTo vbErrHand

    Base64EncodeFile = True

    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

    Exit Function

vbErrHand:
    If Err.Number = 6 Then ' Overflow
        MsgBox "The file you tried to add was too large. Try not exporting with colouring or export a smaller amount of code items."
        Base64EncodeFile = False
    Else
        MsgBox "Error Number: " & Err.Number & vbCrLf & "Error Description: " & Err.Description, vbOKOnly + vbCritical
    End If
End Function

' 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

' SendMail(strFrom, strTo, strSubject, strBody, wsk, strAttachName, txtEncodedFile)
' SendMail "me@mymail.com", "you@yourmail.com", "Test Message", "Body", Winsock1, "myfile.ext", txtEncodedFile
' If you omit the last two arguements then no file is attached
' Before attaching a file, you must first encode it using the Base64EncodeFile 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