E-mail Program With Visual Basic (Require Base64 encryption)

E-mail Program With Visual Basic (Require Base64 encryption)

Dim fso As New Scripting.FileSystemObject
Dim fco As New Scripting.Encoder
Dim Sdata As String, Cptr As Integer
Dim StrArray As Variant, StrElement As Variant, MsgString As String
Dim v As Boolean
Dim o As Boolean

Private Sub Command1_Click()
    Winsock1.SendData "MAIL FROM:<yourID@YAHOO.in> " & vbCrLf
End Sub

Private Sub Timer1_Timer()
    Me.Caption = Winsock1.State
    If Winsock1.State = 9 Then Winsock1.Close
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim str As String
    Call Winsock1.GetData(str)
    If Left(str, 3) = "220" Then
        Winsock1.SendData "EHLO YAHOO.COM " & vbCrLf
    ElseIf Left(str, 4) = "250-" Then
        Winsock1.SendData "AUTH LOGIN" & vbCrLf
    ElseIf str = "334 VXNlcm5hbWU6" & vbCrLf Then
        Winsock1.SendData "Encrypted ID" & vbCrLf
    ElseIf str = "334 UGFzc3dvcmQ6" & vbCrLf Then
        Winsock1.SendData "Encrypted Password" & vbCrLf
    ElseIf Left(str, 3) = "235" Then
        MsgBox "Authentication Succesfull!"
    ElseIf Left(str, 4) = "250 " And v = False Then
        Winsock1.SendData "RCPT To:<" & txtTo.Text & "> " & vbCrLf
        v = True
    ElseIf Left(str, 4) = "250 " Then
        If o = False Then
            Winsock1.SendData "DATA " & vbCrLf
            MsgBox "Data Sending!"
        Else
            Winsock1.SendData "QUIT" & vbCrLf
            MsgBox "OK Mail Sent!"
        End If
    ElseIf Left(str, 3) = "354" Then
        Winsock1.SendData "From: ""Sender"" <yourID@yahoo.in>" & vbCrLf
        Winsock1.SendData "To: ""Receiver"" <mailID@yahoo.com>" & vbCrLf
        Winsock1.SendData "Date: Fri, 31 Dec 2010 16:02:43 -0500" & vbCrLf
        Winsock1.SendData "Subject: " & Text2.Text & vbCrLf
        Call attachment
        For Each StrElement In StrArray
            Winsock1.SendData (CStr(StrElement) & vbCrLf)
        Next StrElement
        Winsock1.SendData "." & vbCrLf
        o = True
    End If
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 Number & " " & Description
End Sub

Sub attachment()
    If Len(txtAttachment.Text) = 0 Then
        'we don't need MIME for this
        MsgString = txtEmailBodyOfMessage.Text + vbCrLf
    Else
        'build the 1st part of the MIME script
        txtMimeCode = _
          "MIME-Version: 1.0 " + vbCrLf + _
          "Content-Type: multipart/mixed;" + vbCrLf + _
          " boundary=" + VbQuote + "------------060502030501040302050009" + VbQuote + vbCrLf + _
          vbCrLf _
          + "This is a multi-part message in MIME format." + vbCrLf + _
          "--------------060502030501040302050009" + vbCrLf + _
          "Content-Type: text/plain; charset=ISO-8859-1; format=flowed" + vbCrLf + _
          "Content-Transfer-Encoding: 7bit" + vbCrLf + _
          vbCrLf + _
          txtEmailBodyOfMessage + vbCrLf + _
          vbCrLf + _
          "--------------060502030501040302050009" + vbCrLf
        Select Case UCase(Right(txtAttachment.Text, 4))
        Case ".TXT"
          txtMimeCode = txtMimeCode + _
            "Content-Type: text/plain;" + vbCrLf + _
            "name=" + VbQuote + txtAttachment.Text + VbQuote + vbCrLf + _
            "Content-Transfer-Encoding: base64" + vbCrLf + _
            "Content-Disposition: attachment; filename=" + txtAttachment.Text + vbCrLf + _
            vbCrLf + _
            Base64Encode(RichTextBox1.Text) + vbCrLf + _
            vbCrLf + _
            "--------------060502030501040302050009--" + vbCrLf
        Case ".DOC"
          txtMimeCode = txtMimeCode + _
            "Content-Type: application/msword;" + vbCrLf + _
            "name=" + VbQuote + txtAttachment.Text + VbQuote + vbCrLf + _
            "Content-Transfer-Encoding: base64" + vbCrLf + _
            "Content-Disposition: attachment; filename=" + txtAttachment.Text + vbCrLf + _
            vbCrLf + _
            Base64Encode(RichTextBox1.Text) + vbCrLf + _
            vbCrLf + _
            "--------------060502030501040302050009--" + vbCrLf
          MsgString = txtMimeCode
        Case ".PDF"
          txtMimeCode = txtMimeCode + _
            "Content-Type: application/pdf;" + vbCrLf + _
            "name=" + VbQuote + txtAttachment.Text + VbQuote + vbCrLf + _
            "Content-Transfer-Encoding: base64" + vbCrLf + _
            "Content-Disposition: attachment; filename=" + txtAttachment.Text + vbCrLf + _
            vbCrLf + _
            Base64Encode(RichTextBox1.Text) + vbCrLf + _
            vbCrLf + _
            "--------------060502030501040302050009--" + vbCrLf
          MsgString = txtMimeCode
        Case ".XLS"
          txtMimeCode = txtMimeCode + _
            "Content-Type: application/excel;" + vbCrLf + _
            "name=" + VbQuote + txtAttachment.Text + VbQuote + vbCrLf + _
            "Content-Transfer-Encoding: base64" + vbCrLf + _
            "Content-Disposition: attachment; filename=" + txtAttachment.Text + vbCrLf + _
            vbCrLf + _
            Base64Encode(RichTextBox1.Text) + vbCrLf + _
            vbCrLf + _
            "--------------060502030501040302050009--" + vbCrLf
          MsgString = txtMimeCode
        Case Else
          txtMimeCode = txtMimeCode + _
            "Content-Type: application/unknown;" + vbCrLf + _
            "name=" + VbQuote + txtAttachment.Text + VbQuote + vbCrLf + _
            "Content-Transfer-Encoding: base64" + vbCrLf + _
            "Content-Disposition: attachment; filename=" + txtAttachment.Text + vbCrLf + _
            vbCrLf + _
            Base64Encode(RichTextBox1.Text) + vbCrLf + _
            vbCrLf + _
            "--------------060502030501040302050009--" + vbCrLf
          MsgString = txtMimeCode
        End Select
      End If
      MsgString = txtMimeCode
      StrArray = Split(MsgString, vbCrLf)
End Sub