TENHO A ROTINA ABAIXO MAS QUANDO ENVIO NÃO APARECE NEM O REMETENTE E NEM O DESTINATARIO, ALGUEM PODE ME AJUDAR ?
ROTINA :
Option Explicit
Private Sub chkAuth_Click()
If chkAuth = 1 Then
Habilita txtLogin
Habilita txtSenha
Else
Desabilita txtLogin
Desabilita txtSenha
End If
End Sub
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 Msg As String
Dim Status As String
Dim Erro As Boolean
If Trim(Winsock1.Tag) <> "" Then
Winsock1.GetData strData
Status = Left(strData, 3)
'Verifica de o servidor retornou alguma msg de erro
Select Case Status
Case "250", "220", "354", "221", "334", "235": Erro = False
Case Else:
Erro = True
Winsock1.Tag = "fechar"
Status = Mid(strData, 4)
End Select
Select Case Winsock1.Tag
Case "conectado":
If chkAuth Then
Msg = "ehlo " & Winsock1.LocalIP & vbCrLf
Winsock1.Tag = "autenticar"
Else
Msg = "helo " & Winsock1.LocalIP & vbCrLf
Winsock1.Tag = "conectou"
End If
Winsock1.SendData Msg
stbConexao.Panels(1).Text = "Conectado."
Case "autenticar":
Msg = "auth login" & vbCrLf
Winsock1.SendData Msg
Winsock1.Tag = "autenticar_usuario"
Case "autenticar_usuario":
Msg = sBase64Encode(txtLogin.Text) & vbCrLf
Winsock1.SendData Msg
Winsock1.Tag = "autenticar_senha"
Case "autenticar_senha":
Msg = sBase64Encode(txtSenha.Text) & vbCrLf
Winsock1.SendData Msg
Winsock1.Tag = "conectou"
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
Msg = "subject: " & txtSubject & vbCrLf
If chkHTML = vbChecked Then
Msg = Msg & "MIME-Version: 1.0" & vbCrLf & "Content-type: text/html; charset=iso-8859-1" & vbCrLf
End If
Msg = Msg & MsgTexto & vbCrLf & "." & vbCrLf
Winsock1.SendData Msg
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
Private Sub Desabilita(ByRef Controle As TextBox)
Controle.Enabled = False
Controle.BackColor = &H80000004
End Sub
Private Sub Habilita(ByRef Controle As TextBox)
Controle.Enabled = True
Controle.BackColor = &H80000005
End Sub
.BAS :
Option Explicit
Public Function sBase64Decode(BASE64TEXT_IN As String) As String
'return the original data in a string, from a given Base64 encoded text
Dim i As Long, sText As String, rc As Integer
Dim sFour As String, sThree As String
Dim sOut As String
sText = sRemoveWhitespace(BASE64TEXT_IN) 'get working copy of base64 text
For i = 1 To Len(sText) Step 4 'for the entire base64 text line
sFour = Mid$(sText, i, 4) ' get the next group of four bytes
While Len(sFour) < 4: sFour = sFour & "=": Wend 'pad to four bytes if necessary
sThree = sDecode4(sFour) 'convert the group of four bytes
If Len(sThree) = 3 Then
sOut = sOut & sThree
Else
rc = MsgBox("Illegal Characters <" & sFour & "> found", vbOKCancel, "PROGRAM ERROR")
If rc = vbCancel Then Exit For 'if user cancels, quit
'keep trying, maybe some data can be decoded
sOut = sOut & "???"
End If
Next i
sBase64Decode = sOut 'return the text
End Function
Public Function sBase64Encode(TEXT_IN As String) As String
'returns a base64 coded string of the given text
Dim i As Long, sText As String, sThree As String, sFour As String
Dim sOut As String, nLineLength As Integer
Dim nNulls As Integer 'number of equal sign suffixes needed (0,1,2)
sText = TEXT_IN 'get working copy of input text
For i = 1 To Len(sText) Step 3 'for the entire text line
sThree = Mid$(sText, i, 3) ' get the next group of three bytes
nNulls = Len(sThree) Mod 3 'get the number of base64 "=" needed
If nNulls > 0 Then nNulls = 3 - nNulls
sThree = sThree & Left$(Chr$(0) & Chr$(0), nNulls) 'pad nulls to 3 bytes
sFour = sEncode3(sThree) 'convert 3 text bytes to 4 base64 bytes
If nNulls > 0 Then 'if overlaying with "="
sFour = Left$(sFour, 4 - nNulls) 'overlay with "="
sFour = sFour & Left$("==", nNulls) 'pad nulls to 4 bytes
End If
sOut = sOut & sFour 'save the four bytes
nLineLength = nLineLength + 4 'increment length of current line
If nLineLength >= 64 Then 'if long, insert line break
sOut = sOut & vbNewLine ' insert line break
nLineLength = 0 ' reset line length counter
End If
Next i
sBase64Encode = sOut 'return the encoded base64 string
End Function
Private Function nBase64Digit(VALUE_IN As Integer) As Byte
'returns a base64 value (A-Z,a-z,0-9,+,/) for a value 0-63
Dim Digit64 As Byte, n As Integer
Debug.Assert VALUE_IN >= 0 And VALUE_IN <= 63 'check the input
n = VALUE_IN 'get working copy of digit value
Select Case n
Case Is <= 25: Digit64 = Asc("A") + n ' A-Z
Case Is <= 51: Digit64 = Asc("a") + (n - 26) ' a-z
Case Is <= 61: Digit64 = Asc("0") + (n - 52) ' 0-9
Case 62: Digit64 = Asc("+") ' +
Case 63: Digit64 = Asc("/") ' /
Case Else
Digit64 = "?" 'illegal input, return error code
Debug.Assert False 'what happened?
End Select
nBase64Digit = Digit64
End Function
Private Function nBase64Value(ONEBYTE_IN As String) As Integer
'return base64 char value for the only or leftmost byte
' of the given string, 0-63 (or 255 for an error)
Dim n As Integer
Select Case ONEBYTE_IN
Case "A" To "Z": n = Asc(ONEBYTE_IN) - Asc("A")
Case "a" To "z": n = 26 + Asc(ONEBYTE_IN) - Asc("a")
Case "0" To "9": n = 52 + Asc(ONEBYTE_IN) - Asc("0")
Case "+": n = 62
Case "/": n = 63
Case "=": n = 0
Case Else 'if not in the list
n = 255 'return error code
End Select
nBase64Value = n 'return the value of the byte
End Function
Private Function sDecode4(BASE64TEXT_IN As String) As String
'convert four base64 bytes to three text bytes
'this is a bit manipulation and never 'fails' unless input is bad
Dim nBits As Long '32 bits, using 24 of them for bit work
Dim s1 As String, s2 As String, s3 As String, s4 As String 'each byte
Dim t1 As String, t2 As String, t3 As String
Dim n1 As Byte, n2 As Byte, n3 As Byte, n4 As Byte 'each byte's value
'check the input string:
If Len(BASE64TEXT_IN) <> 4 Or Not IsBase64(BASE64TEXT_IN) Then
Debug.Assert False 'hunh?
sDecode4 = "" 'return error code
Exit Function 'quit
End If
s1 = Mid$(BASE64TEXT_IN, 1, 1) 'get all four bytes
s2 = Mid$(BASE64TEXT_IN, 2, 1)
s3 = Mid$(BASE64TEXT_IN, 3, 1)
s4 = Mid$(BASE64TEXT_IN, 4, 1)
n1 = nBase64Value(s1) 'get all four byte's values
n2 = nBase64Value(s2)
n3 = nBase64Value(s3)
n4 = nBase64Value(s4)
If n1 = 255 Or n2 = 255 Or n3 = 255 Or n4 = 255 Then 'if any bad characters given
sDecode4 = "" 'return error code
Exit Function 'quit
End If
nBits = nBits Or n4 'merge the values into 24 bits
nBits = nBits Or (n3 * 64&)
nBits = nBits Or (n2 * 64& * 64&)
nBits = nBits Or (n1 * 64& * 64& * 64&)
t3 = Chr$(nBits And 255) 'get the three output bytes
t2 = Chr$((nBits 256) And 255)
t1 = Chr$((nBits 256 256))
sDecode4 = t1 & t2 & t3 'return the decoded bytes
End Function
Private Function sEncode3(THREEBYTES_IN As String) As String
'convert the group of three bytes to four base64 digits
'Function nBase64Digit(VALUE_IN As Integer) As String
Dim s1 As String, s2 As String, s3 As String
Dim n1 As Byte, n2 As Byte, n3 As Byte
Dim nBits As Long
Dim t1 As Byte, t2 As Byte, t3 As Byte, t4 As Byte
Debug.Assert Len(THREEBYTES_IN) = 3 'note: ANY bytes are okay, we just need 24 bits
s1 = Mid$(THREEBYTES_IN, 1, 1) 'get the three characters
s2 = Mid$(THREEBYTES_IN, 2, 1)
s3 = Mid$(THREEBYTES_IN, 3, 1)
n1 = Asc(s1) 'get the three byte values
n2 = Asc(s2)
n3 = Asc(s3)
nBits = nBits Or n3 'merge the values into 24 bits
nBits = nBits Or (n2 * 256&)
nBits = nBits Or (n1 * 256& * 256&)
t4 = nBase64Digit(nBits And 63) 'get the four output bytes
t3 = nBase64Digit((nBits 64) And 63)
t2 = nBase64Digit((nBits 64 64) And 63)
t1 = nBase64Digit((nBits 64 64 64) And 63)
'return the (4) base64 encoded digits
sEncode3 = Chr$(t1) & Chr$(t2) & Chr$(t3) & Chr$(t4)
End Function
Public Function IsBase64(TEXT_IN As String, Optional MSGBOX_IN As Boolean = False) As Boolean
'decide if a string is legal base64 code ready for decoding
'Base64, CR, and LF characters (only) are allowed
Dim i As Long, sText As String
If TEXT_IN = "" Then 'if no input
IsBase64 = False ' return bad return code
Exit Function ' quit
End If
sText = sRemoveWhitespace(TEXT_IN) 'get working copy of text
For i = 1 To Len(sText) 'for each byte of the input text
Select Case Mid$(sText, i, 1) 'get next byte
Case "A" To "Z", "a" To "z", "0" To "9", "+", "/", vbCr, vbLf 'if good
'do nothing
Case "="
If i = Len(sText) - 1 Then 'if next to Max byte
If Mid$(sText, i + 1, 1) = "=" Then 'if Max byte is "=" too
'do nothing
End If
ElseIf i = Len(sText) Then 'if Max byte
'do nothing
Else 'then the "=" is not at the end, so reject it
If MSGBOX_IN Then MsgBox "Text Error: Equal Sign not at end of text", , "TRIM END OF TEXT"
IsBase64 = False ' fails base64 character content test
Exit Function ' quit
End If
Case Else 'if not in the character list
If MSGBOX_IN Then MsgBox "Non-base64 character <" _
& Mid$(TEXT_IN, i, 1) & "> found in base64" _
& " text", , "ILLEGAL BASE64 BYTE"
IsBase64 = False ' fails base64 character content test
Exit Function ' quit
End Select
Next i
IsBase64 = True 'if it passed all the tests return YES
End Function
Private Function sRemoveWhitespace(TEXT_IN As String) As String
Dim sText As String
sText = TEXT_IN
sText = Replace(sText, vbCr, "") 'remove all line break characters
sText = Replace(sText, vbLf, "")
sText = Replace(sText, vbTab, "")
sText = Replace(sText, " ", "")
sRemoveWhitespace = sText
End Function
POR FAVOR
OBRIGADO
