"Wie lassen sich EMail-Nachrichten von einem POP3-Server abrufen?" Die wohl gängigste Methode ist das Verwenden des Winsock-Controls - und das ist gar nicht mal so kompliziert. Es gibt lediglich ein paar Grundvoraussetzungen, welche man beachten muss: Die Reihenfolge hierbei ist folgende:
Was viele jetzt vielleicht falsch machen würden, ist das Verwenden einer String-Variable, in der die Nachricht gespeichert werden soll. Das geht aber nur gut, solange es sich um kleine bis mittelgrosse Nachrichten handelt. Bei Nachrichten über 1 MByte kommt es dann schnell zu einem Laufzeitfehler (Fehler 7). Deshalb sollte man die Nachrichten am besten sofort in eine temporäre Datei speichern... Folgende Variablen werden für den Nachrichten-Abruf innerhalb der Form benötigt: ' Variablen für den Mail-Empfang Dim strMail As String Dim strResponse As String Dim strLastResponse As String ' Datei, in der die Nachricht gespeichert wird Dim popTempFile As String Dim BytesRead As Long 1. Anmelden am Mailserver
' Verbindung zum Mailserver herstellen Public Function MailConnectToServer(ByVal ServerName As _ String, ByVal UserName As String, ByVal Password As _ String) As Boolean ' Status-Fenster "leeren" frmStatus.txtStatus.Text = "" If Not frmStatus.Visible Then frmStatus.Show , Me lblStatus.Visible = True Status.Value = 0 MailConnectToServer = False popTempFile = "" With Winsock1 ' Ggf. vorher schliessen On Local Error Resume Next .Close On Local Error GoTo 0 ' Anmelden am Mailserver lblStatus.Caption = "Verbinden mit: " + _ ServerName + "..." DoEvents .Protocol = sckTCPProtocol .LocalPort = 0 .Connect ServerName, 110 ' Warten, bis die Verbindung hergestellt ist Do While .State < sckConnected DoEvents Loop ' Verbindung OK? If Not .State > sckConnected Then lblStatus.Caption = "Anmelden am Server..." DoEvents ' Auf Antwort warten... strResponse = "" If WaitForResponse() Then ' Benutzernamen prüfen lblStatus.Caption = "Prüfe Benutzernamen..." DoEvents strResponse = "" .SendData "USER " & UserName & vbNewLine If WaitForResponse() Then ' Kennwort prüfen lblStatus.Caption = "Prüfe Kennwort..." DoEvents strResponse = "" .SendData "PASS " & Password & vbNewLine If WaitForResponse() Then MailConnectToServer = True Else MsgBox "Falsches oder ungültiges Kennwort!", _ 16, "Nachrichten abrufen" End If Else MsgBox "Falscher oder ungültiger Benutzername!", _ 16, "Nachrichten abrufen" End If Else MsgBox "Verbindung zum Mailserver fehlgeschlagen!", _ 16, "Nachrichten abrufen" End If End If End With End Function 2. Prüfen, ob Nachrichten vorhanden sind ' Prüft auf neue Nachrichten Public Function MailGetListe() As Boolean Dim strMails() As String Dim mData() As String Dim i As Integer Dim itemX As ListItem ' ListView löschen ListView1.ListItems.Clear ' Liste aller Nacchrichten With Winsock1 strResponse = "" .SendData "LIST" & vbNewLine frmStatus.txtStatus = frmStatus.txtStatus & _ "LIST" & vbNewLine If WaitForResponse() Then ' Nachrichten-Auflistung strMails = Split(strResponse, vbNewLine) For i = 1 To UBound(strMails) - 2 mData = Split(strMails(i), " ") ' MsgID und Größe in Liste speichern Set itemX = ListView1.ListItems.Add(, , mData(0)) itemX.SubItems(1) = mData(1) itemX.SubItems(2) = "" Next i End If End With MailGetListe = (ListView1.ListItems.Count > 0) End Function 3. Nachricht abrufen ' Nachricht abrufen Public Function MailRecieve(ByVal MsgId As String, _ Optional ByVal MsgDelete As Boolean = False) As String Screen.MousePointer = 11 BytesRead = 0 With Winsock1 strResponse = "" ' Datei, in welcher die aktuelle Nachricht ' gespeichert werden soll popTempFile = App.Path & "\MAIL_" & MsgId & " " & _ Format$(Now, "yymmdd_hhnnss") & ".txt" DoEvents .SendData "RETR " & MsgId & vbNewLine frmStatus.txtStatus = frmStatus.txtStatus & _ "RETR " & MsgId & vbNewLine ' Solange empfangen, bis mit . abgeschlossen ist Do While InStr(strResponse, _ vbNewLine & "." & vbNewLine) = 0 DoEvents Loop MailRecieve = popTempFile popTempFile = "" ' GGf. Nachricht vom Server löschen If MsgDelete Then strResponse = "" .SendData "DELE " & MsgId & vbNewLine WaitForResponse End If End With Screen.MousePointer = 0 End Function Jetzt fehlt eigentlich nur noch die Funktion, welche die einzelnen Datenpakete vom Mailserver empfängt... ' Daten werden empfangen Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long) Dim F As Integer Dim strData As String Winsock1.GetData strData, vbString If Not Left$(strData, 3) Like "+OK" Then ' Daten-Block in Datei schreiben If popTempFile <> "" Then F = FreeFile Open popTempFile For Append As #F Print #F, Replace(strData, vbNewLine & ".", vbNewLine); Close #F ' Fortschritt BytesRead = BytesRead + Len(strData) If BytesRead > Status.Max Then BytesRead = Status.Max Status.Value = BytesRead End If strMail = strMail & strData End If If popTempFile <> "" Then strResponse = strLastResponse & strData strLastResponse = strData Else strResponse = strResponse & strData frmStatus.txtStatus = frmStatus.txtStatus + strData End If End Sub ' Auf Antwort warten! Public Function WaitForResponse() As Boolean ' spätestens nach 45 Sekunden abbrechen Const TimeOut = 45 Dim iStart As Long iStart = Timer WaitForResponse = False With Winsock1 While strResponse = "" ' Bei unvorhergesehenem Verbindungsabbruch If .State > sckConnected Then MsgBox "Verbindungsabbruch!", 16, "Error" Exit Function End If ' Wenn TimeOut überschritten, Meldung und abbrechen If Timer - iStart > TimeOut Then MsgBox "TimeOut!" & vbCrLf & _ "Der Server antwortet nicht...", 16, "TimerOut" Exit Function End If DoEvents Wend End With If Left(strResponse, 3) Like "+OK" Then WaitForResponse = True End If End Function Beispiel: Das Beispielsprojekt wurde so gehalten, daß vor dem Abrufen neuer Nachrichten geprüft wird, ob eine Internet-Verbindung besteht - und falls nicht, erscheint der Standard-Verbinden-Dialog... Tipp: sevMail ActiveX mit ZIP-Funktionalität Mails senden, abrufen und decodieren - ganz easy Weiter Infos im Downloadbereich... |