ANEXO COM WINSOCK

  
Private Sub cmdEnviar_Click()
  'Verificar se nenhuma conexão está em andamento
  If Winsock1.Tag = "" Then
    If Winsock1.State <> sckClosed Then Winsock1.Close
    Winsock1.Connect txtSMTPServer.Text, "25"
  End If
End Sub
Private Sub Winsock1_Connect()

  Winsock1.Tag = "conectado"

End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)

Dim strData As String
Dim MsgTexto As String
Dim Status As String
Dim Erro As Boolean

If Trim(Winsock1.Tag) <> "" Then
  Winsock1.GetData strData
  Status = Left(strData, 3)
  List1.AddItem Status
  List1.AddItem stbConexao.Panels(1).Text
  'Verifica de o servidor retornou alguma msg de erro
  Select Case Status
     Case "250", "220", "354", "221": Erro = False
     Case Else:
       Erro = True
       Winsock1.Tag = "fechar"
       Status = Mid(strData, 4)
  End Select
  
  Select Case Winsock1.Tag
    Case "conectado":
      Winsock1.SendData "helo " & Winsock1.LocalIP & vbCrLf
      Winsock1.Tag = "conectou"
      stbConexao.Panels(1).Text = "Conectado."
    
    Case "conectou":
      stbConexao.Panels(1).Text = "Enviando..."
      Winsock1.SendData "mail from:<" & txtFrom.Text & ">" & vbCrLf
      Winsock1.Tag = "from"
    
    Case "from":
      Winsock1.SendData "rcpt to:<" & txtTo.Text & ">" & vbCrLf
      Winsock1.Tag = "to"
    
    Case "to":
      Winsock1.SendData "data" & vbCrLf
      Winsock1.Tag = "data"
      
    Case "data":
      'A sequencia "." e quebra de linha deve ser substituida por ".." e quebra de linha
      'para evitar que o servidor entenda fim de email antes do fim do texto
      MsgTexto = txtMsg.Text & vbCrLf
      While InStr(MsgTexto, vbCrLf & "." & vbCrLf) <> 0
        MsgTexto = Replace(MsgTexto, vbCrLf & "." & vbCrLf, vbCrLf & ".." & vbCrLf)
      Wend
      
      Winsock1.SendData "subject: " & txtSubject & vbCrLf & MsgTexto & vbCrLf & "." & vbCrLf
      
      SendTextFile "C:\Teste.txt"
            
      
      Winsock1.Tag = "fim"
      
    Case "fim":
      stbConexao.Panels(1).Text = "Desconectando..."
      Winsock1.SendData "quit" & vbCrLf
      Winsock1.Tag = "fechar"
      
    Case "fechar":
      If Not Erro Then
        stbConexao.Panels(1).Text = "Enviado com sucesso!"
      Else
        stbConexao.Panels(1).Text = "Erro ao enviar email!"
        MsgBox Status, vbCritical, "Erro"
      End If
      
      Winsock1.Close
      Winsock1.Tag = ""
  
  End Select
  
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 "Erro ao conectar" & vbNewLine & "Verifique sua conexão ou o endereço do servidor", vbCritical, "Erro"
End Sub

Public Sub envia_ficheiro()
Dim texto As String
i = FreeFile

Open "C:\EX.TXT" For Binary As #i
Do While Not EOF(i)
Get #i, , texto
Enviar texto
Loop
End Sub

Sub Enviar(ByVal texto)
Winsock1.SendData texto & vbCrLf
  
End Sub


Private Sub SendTextFile(filename As String)
Dim myFile As Integer
Dim buf
Dim tmpvar As String
Dim ch As String
    
    'Tell SMTP server that this is only a textfile
    Send "Content-Type: text/plain; charset=""us-ascii"""
    Send "Content-Disposition: attachment; filename=""" & Dir(filename) & """"
    Send ""
    myFile = FreeFile
    Open filename For Binary Shared As #myFile
    Do
        buf = Input(2048, myFile)
        Winsock1.SendData buf
        
    Loop Until EOF(myFile)
    Close #myFile
End Sub

Public Sub Send(cmd As String)
    With frmMail.sckMail
        .SendData cmd
        If InStr(1, cmd, vbLf) = 0 Then .SendData vbCrLf
        Debug.Print cmd
        Sleep 10
    End With
End Sub