DESCARGAR TODOS LOS CORREOS POR IMAP4

Dim host As String = "imap.gmail.com"
Dim puerto As Double = 993
Dim usuario As String = "masm2000"
Dim pwd As String = "xxx"
Dim ssl As Boolean = True

Dim ruta As String = "x:lista"

Private Shared Function ValidarCertificado() As Boolean
Return True
End Function

Private Function formato_utf7(ByVal texto As String)
texto = Replace(texto, "&ACE-", "!")
texto = Replace(texto, "&ACI-", Chr(34))
texto = Replace(texto, "&ACM-", "#")
texto = Replace(texto, "&ACQ-", "$")
texto = Replace(texto, "&ACU-", "%")
texto = Replace(texto, "&ACY-", "&")
texto = Replace(texto, "&ACo-", "*")
texto = Replace(texto, "+--", "+")
texto = Replace(texto, "&ADs-", ";")
texto = Replace(texto, "&ADw-", "")
texto = Replace(texto, "&AD0-", "=")
texto = Replace(texto, "&AD4-", ">")
texto = Replace(texto, "&AEA-", "@")
texto = Replace(texto, "&AFs-", "[")
texto = Replace(texto, "&AFw-", "")
texto = Replace(texto, "&AF0-", "]")
texto = Replace(texto, "&AF4-", "^")
texto = Replace(texto, "&AF8-", "_")
texto = Replace(texto, "&AGA-", "`")
texto = Replace(texto, "&AHs-", "{")
texto = Replace(texto, "&AHw-", "|")
texto = Replace(texto, "&AH0-", "}")
texto = Replace(texto, "&AH4-", "~")
texto = Replace(texto, "&AH8-", "")
texto = Replace(texto, "&IKw-", "€")
texto = Replace(texto, "&AIE-", "�")
texto = Replace(texto, "&IBo-", "‚")
texto = Replace(texto, "&AZI-", "ƒ")
texto = Replace(texto, "&IB4-", "„")
texto = Replace(texto, "&ICY-", "…")
texto = Replace(texto, "&ICA-", "†")
texto = Replace(texto, "&ICE-", "‡")
texto = Replace(texto, "&AsY-", "ˆ")
texto = Replace(texto, "&IDA-", "‰")
texto = Replace(texto, "&AWA-", "Š")
texto = Replace(texto, "&IDk-", "‹")
texto = Replace(texto, "&AVI-", "Œ")
texto = Replace(texto, "&AI0-", "�")
texto = Replace(texto, "&AX0-", "Ž")
texto = Replace(texto, "&AI8-", "�")
texto = Replace(texto, "&AJA-", "�")
texto = Replace(texto, "&IBg-", "‘")
texto = Replace(texto, "&IBk-", "’")
texto = Replace(texto, "&IBw-", Chr(147))
texto = Replace(texto, "&IB0-", Chr(148))
texto = Replace(texto, "&ICI-", "•")
texto = Replace(texto, "&IBM-", "–")
texto = Replace(texto, "&IBQ-", "—")
texto = Replace(texto, "&Atw-", "˜")
texto = Replace(texto, "&ISI-", "™")
texto = Replace(texto, "&AWE-", "š")
texto = Replace(texto, "&IDo-", "›")
texto = Replace(texto, "&AVM-", "œ")
texto = Replace(texto, "&AJ0-", "�")
texto = Replace(texto, "&AX4-", "ž")
texto = Replace(texto, "&AXg-", "Ÿ")
texto = Replace(texto, "&AKA-", " ")
texto = Replace(texto, "&AKE-", "¡")
texto = Replace(texto, "&AKI-", "¢")
texto = Replace(texto, "&AKM-", "£")
texto = Replace(texto, "&AKQ-", "¤")
texto = Replace(texto, "&AKU-", "¥")
texto = Replace(texto, "&AKY-", "¦")
texto = Replace(texto, "&AKc-", "§")
texto = Replace(texto, "&AKg-", "¨")
texto = Replace(texto, "&AKk-", "©")
texto = Replace(texto, "&AKo-", "ª")
texto = Replace(texto, "&AKs-", "«")
texto = Replace(texto, "&AKw-", "¬")
texto = Replace(texto, "&AK0-", "­")
texto = Replace(texto, "&AK4-", "®")
texto = Replace(texto, "&AK8-", "¯")
texto = Replace(texto, "&ALA-", "°")
texto = Replace(texto, "&ALE-", "±")
texto = Replace(texto, "&ALI-", "²")
texto = Replace(texto, "&ALM-", "³")
texto = Replace(texto, "&ALQ-", "´")
texto = Replace(texto, "&ALU-", "µ")
texto = Replace(texto, "&ALY-", "¶")
texto = Replace(texto, "&ALc-", "·")
texto = Replace(texto, "&ALg-", "¸")
texto = Replace(texto, "&ALk-", "¹")
texto = Replace(texto, "&ALo-", "º")
texto = Replace(texto, "&ALs-", "»")
texto = Replace(texto, "&ALw-", "¼")
texto = Replace(texto, "&AL0-", "½")
texto = Replace(texto, "&AL4-", "¾")
texto = Replace(texto, "&AL8-", "¿")
texto = Replace(texto, "&AMA-", "À")
texto = Replace(texto, "&AME-", "Á")
texto = Replace(texto, "&AMI-", "Â")
texto = Replace(texto, "&AMM-", "Ã")
texto = Replace(texto, "&AMQ-", "Ä")
texto = Replace(texto, "&AMU-", "Å")
texto = Replace(texto, "&AMY-", "Æ")
texto = Replace(texto, "&AMc-", "Ç")
texto = Replace(texto, "&AMg-", "È")
texto = Replace(texto, "&AMk-", "É")
texto = Replace(texto, "&AMo-", "Ê")
texto = Replace(texto, "&AMs-", "Ë")
texto = Replace(texto, "&AMw-", "Ì")
texto = Replace(texto, "&AM0-", "Í")
texto = Replace(texto, "&AM4-", "Î")
texto = Replace(texto, "&AM8-", "Ï")
texto = Replace(texto, "&ANA-", "Ð")
texto = Replace(texto, "&ANE-", "Ñ")
texto = Replace(texto, "&ANI-", "Ò")
texto = Replace(texto, "&ANM-", "Ó")
texto = Replace(texto, "&ANQ-", "Ô")
texto = Replace(texto, "&ANU-", "Õ")
texto = Replace(texto, "&ANY-", "Ö")
texto = Replace(texto, "&ANc-", "×")
texto = Replace(texto, "&ANg-", "Ø")
texto = Replace(texto, "&ANk-", "Ù")
texto = Replace(texto, "&ANo-", "Ú")
texto = Replace(texto, "&ANs-", "Û")
texto = Replace(texto, "&ANw-", "Ü")
texto = Replace(texto, "&AN0-", "Ý")
texto = Replace(texto, "&AN4-", "Þ")
texto = Replace(texto, "&AN8-", "ß")
texto = Replace(texto, "&AOA-", "à")
texto = Replace(texto, "&AOE-", "á")
texto = Replace(texto, "&AOI-", "â")
texto = Replace(texto, "&AOM-", "ã")
texto = Replace(texto, "&AOQ-", "ä")
texto = Replace(texto, "&AOU-", "å")
texto = Replace(texto, "&AOY-", "æ")
texto = Replace(texto, "&AOc-", "ç")
texto = Replace(texto, "&AOg-", "è")
texto = Replace(texto, "&AOk-", "é")
texto = Replace(texto, "&AOo-", "ê")
texto = Replace(texto, "&AOs-", "ë")
texto = Replace(texto, "&AOw-", "ì")
texto = Replace(texto, "&AO0-", "í")
texto = Replace(texto, "&AO4-", "î")
texto = Replace(texto, "&AO8-", "ï")
texto = Replace(texto, "&APA-", "ð")
texto = Replace(texto, "&APE-", "ñ")
texto = Replace(texto, "&API-", "ò")
texto = Replace(texto, "&APM-", "ó")
texto = Replace(texto, "&APQ-", "ô")
texto = Replace(texto, "&APU-", "õ")
texto = Replace(texto, "&APY-", "ö")
texto = Replace(texto, "&APc-", "÷")
texto = Replace(texto, "&APg-", "ø")
texto = Replace(texto, "&APk-", "ù")
texto = Replace(texto, "&APo-", "ú")
texto = Replace(texto, "&APs-", "û")
texto = Replace(texto, "&APw-", "ü")
texto = Replace(texto, "&AP0-", "ý")
texto = Replace(texto, "&AP4-", "þ")
texto = Replace(texto, "&AP8-", "ÿ")
Return texto
End Function

Private Function ver() As String
Dim enc As New System.Text.ASCIIEncoding
Dim serverbuff() As Byte = New [Byte](1023) {}
Dim count As Integer = 0
While True
Dim buff() As Byte = New [Byte](1) {}
Dim bytes As Integer = Streamer.Read(buff, 0, 1)
If bytes = 1 Then
serverbuff(count) = buff(0)
count += 1
If buff(0) = Asc(vbLf) Then
Exit While
End If
Else
Exit While
End If
End While
Dim retval As String = enc.GetString(serverbuff, 0, count)
'Debug.WriteLine("READ:" + retval)
Return retval
End Function

Private Sub Write(ByVal message As String)
Dim en As New System.Text.ASCIIEncoding
Dim WriteBuffer(1023) As Byte
WriteBuffer = en.GetBytes(message)
Streamer.Write(WriteBuffer, 0, WriteBuffer.Length)
'Debug.WriteLine("WRITE:" + message)
End Sub

Public Sub Desconectar()
Dim mensaje As String = ""
Write("a logout" & vbNewLine)
mensaje = ver()
If UCase(Mid(mensaje, 2, 4)) > " BYE" And Mid(mensaje, Len(mensaje), 1) = vbLf Then
MsgBox(mensaje)
Exit Sub
End If
imap4.Close()
End Sub

Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Dim mensaje As String = ""

imap4.Connect(host, puerto)
If ssl = True Then
Streamer = New Net.Security.SslStream(imap4.GetStream, False)
DirectCast(Streamer, Net.Security.SslStream).AuthenticateAsClient(host)
Net.ServicePointManager.ServerCertificateValidationCallback = New Net.Security.RemoteCertificateValidationCallback(AddressOf ValidarCertificado)
Else
Streamer = imap4.GetStream()
End If

mensaje = ver()
If UCase(Mid(mensaje, 2, 3)) > " OK" Then
MsgBox(mensaje)
Desconectar()
Exit Sub
End If

Write("a login " & usuario & " " & pwd & vbNewLine)
While True
mensaje = ver()
If UCase(Mid(mensaje, 2, 3)) = " OK" And Mid(mensaje, Len(mensaje), 1) = vbLf Then
Exit While
End If
End While

Write("a list ""*"" ""*""" & vbNewLine)
Dim lista_carpetas As New ArrayList
While True
mensaje = ver()
If UCase(Mid(mensaje, 2, 3)) = " OK" And Mid(mensaje, Len(mensaje), 1) = vbLf Then
Exit While
Else
If UCase(Mid(mensaje, 2, 5)) > " LIST" And Mid(mensaje, Len(mensaje), 1) = vbLf Then
MsgBox(mensaje)
Desconectar()
Exit Sub
Else
lista_carpetas.Add(mensaje)
End If
End If
End While

Dim suma_bytes As Double = 0

Dim mailbox As String = ""

For Each carpetas In lista_carpetas
Dim tit_carpetas() As String
tit_carpetas = Split(carpetas, Chr(34))

Try
System.IO.Directory.CreateDirectory(ruta & "" & formato_utf7(tit_carpetas(UBound(tit_carpetas) - 1)))
Catch
End Try

Write("a select """ & tit_carpetas(UBound(tit_carpetas) - 1) & """" & vbNewLine)
While True
mensaje = ver()
If UCase(Mid(mensaje, 2, 9)) = " OK [READ" And Mid(mensaje, Len(mensaje), 1) = vbLf Then
mailbox = tit_carpetas(UBound(tit_carpetas) - 1)
Exit While
End If
If UCase(Mid(mensaje, 2, 3)) = " NO" And Mid(mensaje, Len(mensaje), 1) = vbLf Then
Exit While
End If
End While

If mailbox = tit_carpetas(UBound(tit_carpetas) - 1) Then
Write("a FETCH 1:* UID" & vbNewLine) 'MUESTRA UN LISTADO DE LOS MENSAJES CON SU ID (VALOR UNICO PARA CADA MENSAJE)
Dim UID As New ArrayList
While True
mensaje = ver()
If UCase(Mid(mensaje, 2, 3)) = " OK" And Mid(mensaje, Len(mensaje), 1) = vbLf Then
Exit While
Else
If UCase(Mid(mensaje, 2, 4)) = " BAD" And Mid(mensaje, Len(mensaje), 1) = vbLf Then
MsgBox("No se han encontrado mensajes en el buzón: """ & formato_utf7(tit_carpetas(UBound(tit_carpetas) - 1)) & """")
Exit While
End If
Dim NUM() As String
NUM = Split(Replace(mensaje, ")", ""), " ")
Dim NUM1 As Double = CDbl(Trim(NUM(UBound(NUM))))
UID.Add(NUM1)
End If
End While

If UID.Count > 0 Then
Dim NUM_ID As Double
For NUM_ID = 0 To UID.Count - 1
Write("a UID FETCH " & UID(NUM_ID) & " FLAGS" & vbNewLine)
Dim ETIQUETAS As String = ""
While True
mensaje = ver()
If UCase(Mid(mensaje, 2, 3)) = " OK" And Mid(mensaje, Len(mensaje), 1) = vbLf Then
Exit While
Else
ETIQUETAS += mensaje
End If
End While
'MsgBox(ETIQUETAS)

Dim strm As ADODB.Stream
Dim myMail As New CDO.Message
strm = myMail.GetStream()
strm.Type = ADODB.StreamTypeEnum.adTypeText

'ALMACENA LOS CORREOS ELECTRONICOS EN UN DIRECTORIO
Dim FICHA As New System.IO.StreamWriter(ruta & "" & formato_utf7(tit_carpetas(UBound(tit_carpetas) - 1)) & "" & NUM_ID & Now.Ticks & ".eml", True, System.Text.Encoding.GetEncoding(1252))

Write("a UID FETCH " & UID(NUM_ID) & " BODY[]" & vbNewLine)
While True
mensaje = ver()
If UCase(Mid(mensaje, 2, 3)) = " OK" And Mid(mensaje, Len(mensaje), 1) = vbLf Then
Exit While
Else
If mensaje.IndexOf(" FETCH (UID " & UID(NUM_ID)) = True Then
FICHA.Write(mensaje)
strm.WriteText(mensaje, ADODB.StreamWriteEnum.adWriteChar)
Else
Dim TAMAÑO() As String
TAMAÑO = Split(mensaje, "{")
Dim TAMAÑO2() As String
TAMAÑO2 = Split(TAMAÑO(1), "}")
suma_bytes += CDbl(TAMAÑO2(0))

'tamaño de cada correo
Dim tamaño3 As String = FormatNumber(CDbl(TAMAÑO2(0)), 2) & " Bytes"
If Len(TAMAÑO2(0)) > 6 Then
tamaño3 = FormatNumber(CDbl(TAMAÑO2(0)) / (1024 * 1024), 2) & " MB"
Else
If Len(TAMAÑO2(0)) > 3 Then
tamaño3 = FormatNumber(CDbl(TAMAÑO2(0)) / 1024, 2) & " KB"
End If
End If
'fin
'MsgBox(tamaño3)
End If
End If
End While

strm.Flush()

Try
MsgBox(myMail.From & vbNewLine & myMail.To & vbNewLine & myMail.ReceivedTime & vbNewLine)
Catch
End Try

FICHA.Close()
Next
End If
End If
Next

'tamaño de todos los correo
Dim tamaño_total As String = FormatNumber(suma_bytes, 2) & " Bytes"
If Len(suma_bytes) > 6 Then
tamaño_total = FormatNumber(suma_bytes / (1024 * 1024), 2) & " MB"
Else
If Len(suma_bytes) > 3 Then
tamaño_total = FormatNumber(suma_bytes / 1024, 2) & " KB"
End If
End If
'fin
MsgBox(tamaño_total)

End Sub

Private Sub Form1_FormClosing(ByVal sender As Object, ByVal e As System.Windows.Forms.FormClosingEventArgs) Handles Me.FormClosing
Try
Desconectar()
Catch
End Try
End Sub

End Class