i think you should use sockets.
here some info from vb6.
it used winsock what is event driven, different from agk.
if you connect to a pop3 server to 110 port (unsecure) (my example was for intranet)
you can sent commands to it ,see SendData function. vbcrlf is char 13 and char 10
most of the commands answer with a status.
Option Explicit
Dim WithEvents Winsock1 As Winsock
Const Base64 As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & _
"abcdefghijklmnopqrstuvwxyz" & _
"0123456789+/"
Private B64() As Byte
Private Rev64() As Byte
Private Type TEmail
Nr As Long
Von As String =From
Betreff As String =Subject
Bytes As Long
daten As String
End Type
Private Type TEMailEmpfang
Host As String
Port As Long
TimeOutZeit As Long
TimeOutAufgetreten As Boolean
Account As String
Password As String
Result As String
NachAbholenLöschen As Boolean
Übertragung As Boolean
daten As String
BackupPfad As String 'muß \ am Ende haben !
AttachmentPfad As String 'muß \ am Ende haben !
DateiFilter As String
Emails() As TEmail
End Type
Dim EmailEmpfang As TEMailEmpfang
Private Sub Class_Initialize()
B64() = StrConv(Base64, vbFromUnicode)
ReverseCode B64, Rev64
End Sub
Public Sub Init(FmWinsock As Winsock, ByVal Host$, ByVal Account$, ByVal Password$, ByVal NachAbholenLöschen As Boolean, ByVal BackupPfad$, ByVal AttachmentPfad$, ByVal DateiFilter$)
Set Winsock1 = FmWinsock
EmailEmpfang.TimeOutZeit = 60
EmailEmpfang.Port = 110
EmailEmpfang.Host = Host$
EmailEmpfang.Account = Account$
EmailEmpfang.Password = Password$
EmailEmpfang.NachAbholenLöschen = NachAbholenLöschen ' = Delete After Collect
EmailEmpfang.BackupPfad = BackupPfad$
EmailEmpfang.AttachmentPfad = AttachmentPfad$
EmailEmpfang.DateiFilter = DateiFilter$
'------------------------------------------
EmailEmpfang.Result = ""
EmailEmpfang.TimeOutAufgetreten = False
EmailEmpfang.Übertragung = False
EmailEmpfang.daten = ""
ReDim EmailEmpfang.Emails(0)
'------------------------------------------
End Sub
= Connect
Public Function Verbinden() As Boolean
Verbinden = False
Dim Nr As Long
Dim Anz As Long
Dim Bytes As Long
Dim Wert1 As Long
Dim Wert2 As Long
Dim Von$
Dim Betreff$
Dim MailIndex As Long
Dim t As Long
Dim Uebertragungsfehler As Byte
Dim RetVal As Boolean
If Winsock1.State <> sckClosed Then
On Error Resume Next
Winsock1.Close
On Error GoTo 0
End If
If Winsock1.State = sckClosed Or Winsock1.State = sckClosing Then
Mld.Meldung "Verbinden mit POP3 ...", Mld_Info, False
' Verbindung mit Server aufnehmen und einloggen
Mld.Meldung "Suche Host " & EmailEmpfang.Host, Mld_Info, False
Winsock1.LocalPort = 0
Winsock1.Connect EmailEmpfang.Host, EmailEmpfang.Port
If WaitResponse = False Then GoTo ERRSub
Mld.Meldung "Anmelden als " & EmailEmpfang.Account, Mld_Info, False
SendData "user " & EmailEmpfang.Account & vbCrLf
If WaitResponse = False Then GoTo ERRSub
Mld.Meldung "Sende Passwort ...", Mld_Info, False
SendData "pass " & EmailEmpfang.Password & vbCrLf
If WaitResponse = False Then GoTo ERRSub
' Anzahl & Größe der E-Mails abfragen
Mld.Meldung "Postfach prüfen ...", Mld_Info, False
SendData "stat" & vbCrLf
If WaitResponse = False Then GoTo ERRSub
StatData EmailEmpfang.Result, Wert1, Wert2
Anz = Wert1
If Anz > 0 Then
For Nr = 1 To Anz
Mld.Meldung "Nachricht " & Nr & " von " & Anz & " erfassen", Mld_Info, False
DoEvents
Uebertragungsfehler = 0
Do
SendData "list " & str(Nr) & vbCrLf
RetVal = WaitResponse()
If RetVal = False Then
Warten 5
Uebertragungsfehler = Uebertragungsfehler + 1
If Uebertragungsfehler > 4 Then
GoTo ERRSub
End If
End If
DoEvents
Loop Until RetVal = True
Dim MailNr As Long
StatData EmailEmpfang.Result, Wert1, Wert2
MailNr = Wert1
Bytes = Wert2
DoEvents
' Absender und Betreff abfragen und das ganze ein paar mal versuchen wenn der Server nicht antwortet
Uebertragungsfehler = 0
Do
SendData "top " & str(MailNr) & " 0" & vbCrLf
RetVal = WaitResponse()
If RetVal = False Then
Warten 5
Uebertragungsfehler = Uebertragungsfehler + 1
If Uebertragungsfehler > 4 Then
GoTo ERRSub
End If
End If
Loop Until RetVal = True
Von = ""
Betreff = ""
t = InStr(1, UCase(EmailEmpfang.Result), "FROM:")
If t > 0 Then Von = Trim(Mid(EmailEmpfang.Result, t + 6, InStr(t + 6, EmailEmpfang.Result, vbLf) - t - 7))
t = InStr(1, UCase(EmailEmpfang.Result), "SUBJECT:")
If t > 0 Then
If InStr(t, EmailEmpfang.Result, vbLf) Then
' Bei leerem Betreff fällt das Programm hin.
Betreff = Mid$(EmailEmpfang.Result, t + 9, InStr(t + 9, EmailEmpfang.Result, vbLf) - t - 9)
If Right$(Betreff, 1) = vbLf Then Betreff = Left$(Betreff, Len(Betreff) - 1)
Else
Betreff = Mid(EmailEmpfang.Result, t + 9)
End If
End If
MailIndex = UBound(EmailEmpfang.Emails) + 1
ReDim Preserve EmailEmpfang.Emails(MailIndex)
EmailEmpfang.Emails(MailIndex).Nr = MailNr
EmailEmpfang.Emails(MailIndex).Von = Von 'z.B. "John Doe" <j.doe@any.com>
EmailEmpfang.Emails(MailIndex).Betreff = Betreff
EmailEmpfang.Emails(MailIndex).Bytes = Bytes
EmailEmpfang.Emails(MailIndex).daten = ""
Next
Mld.Meldung Anz & " E-Mails erfasst.", Mld_Info, False
Verbinden = True
ElseIf Anz = 0 Then
Mld.Meldung "Keine E-Mails vorhanden", Mld_Info, False
Else
'?
Mld.Meldung "Fehler beim verbinden mit POP3 Server", Mld_Fehler, False
End If
Else
Mld.Meldung "Winsock Status closed oder closing wird nicht erreicht !", Mld_Fehler, False
End If 'Winsock Status
Exit Function
ERRSub:
Mld.Meldung "Fehler bei der Übertragung", Mld_Fehler, False
End Function
Public Sub VerbindungTrennen()
'Verbindung zum Mail Server trennen
If EmailEmpfang.NachAbholenLöschen = True Then
Mld.Meldung "Trennen und Nachrichten löschen", Mld_Info, False
Else
Mld.Meldung "Trennen (Nachrichten bleiben auf Server)", Mld_Info, False
End If
' Ausloggen und event. Löschungen durchführen
SendData "quit" & vbCrLf
If WaitResponse() = False Then GoTo ERRSub
If Winsock1.State <> sckClosed Then
Winsock1.Close
End If
Mld.Meldung "Verbindung zum Mailserver getrennt", Mld_Info, False
Exit Sub
ERRSub:
Mld.Meldung "Fehler beim Verbindung Trennen", Mld_Fehler, False
End Sub
Private Sub Winsock1_Close()
'
End Sub
Private Sub Winsock1_Connect()
'
End Sub
Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
'
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim daten$
If Winsock1.State <> sckConnected Then Exit Sub 'kann mal passieren !
If EmailEmpfang.Übertragung = True Then
Winsock1.GetData daten$, vbString
EmailEmpfang.daten = EmailEmpfang.daten & daten
Else
Winsock1.GetData EmailEmpfang.Result
End If
End Sub
Private Function WaitResponse() As Boolean
Dim Zeit As Date
EmailEmpfang.TimeOutAufgetreten = False
EmailEmpfang.Result = ""
Zeit = Now
Do
DoEvents 'für Winsock_DataArrival
If Len(EmailEmpfang.Result) > 0 Then Exit Do 'siehe DataArrival
If DateDiff("s", Zeit, Now) > EmailEmpfang.TimeOutZeit Then 'TimeOut prüfen
EmailEmpfang.TimeOutAufgetreten = True
Exit Do
End If
Loop
WaitResponse = Not EmailEmpfang.TimeOutAufgetreten
End Function
Private Sub MeldungAusgeben(ByVal Tx As String)
Debug.Print Tx
End Sub
Private Function SendData(ByVal D$) As Boolean
'wenn die Verbindung weg ist kracht es sonnst auch wenn der Status Connected ist !
SendData = False
#If NoOnError = 1 Then
#Else
On Error Resume Next
#End If
Winsock1.SendData D$
If err.Number Then
Mld.Meldung "ERR Func SendData " & err.Number & ":" & err.Description, Mld_Fehler, False
Else
SendData = True
End If
End Function
Private Sub ReverseCode(Code() As Byte, Rev() As Byte)
'für Base64
' Dreht ein Bytearray um
Dim I As Integer
ReDim Rev(255) ' Ein Byte
For I = LBound(Code) To UBound(Code)
Rev(Code(I)) = I
Next I
End Sub
Private Sub Warten(ByVal ZeitSpanne As Single)
'API sleep wäre da besser ...
Dim StartZeit As Single
StartZeit = Timer
Do
DoEvents
Loop Until Abs(Timer - StartZeit) > ZeitSpanne
End Sub
Private Sub StatData(ByVal Data As String, ByRef No As Long, ByRef Bytes As Long)
Dim Dat As String
Dim X As Long
No = -1
Bytes = 0
X = InStr(Data, "+OK")
If X >= 1 Then
Data = Mid$(Data, X, Len(Data))
Dat = Trim$(Mid$(Data, 4, Len(Data)))
X = InStr(1, Dat, " ")
If X >= 1 Then
No = Val(Left$(Dat, X))
Bytes = Val(Mid$(Dat, X + 1, Len(Dat)))
End If
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)
Mld.Meldung "Winsock_Error Nr. " & Number & ":" & Description, Mld_Fehler, False
End Sub
Private Sub Winsock1_SendComplete()
'
End Sub
Private Sub Winsock1_SendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long)
'
End Sub
Public Sub AlleAbholen()
'Alle Mails abholen ...
Dim Vollständig As Boolean
Dim Nr As Long
For Nr = 1 To UBound(EmailEmpfang.Emails)
Mld.Meldung "Nachricht " & EmailEmpfang.Emails(Nr).Nr & " abrufen", Mld_Info, False
Vollständig = False
EmailEmpfang.Übertragung = True
EmailEmpfang.daten = ""
If SendData("retr " & EmailEmpfang.Emails(Nr).Nr & vbCrLf) = False Then GoTo er
Do
DoEvents
If Len(EmailEmpfang.daten) >= EmailEmpfang.Emails(Nr).Bytes Then
EmailEmpfang.Emails(Nr).daten = EmailEmpfang.daten
Vollständig = True
Exit Do
End If
If Winsock1.State <> sckConnected Then Exit Do
Loop
If Vollständig = False Then Mld.Meldung "Nachricht " & EmailEmpfang.Emails(Nr).Nr & " wurde nicht ganz übertragen und bleibt erstmal auf dem Mailserver ... vieleicht klappt es nächstes mal *GRRR*", Mld_Info, False
EmailEmpfang.Übertragung = False
If EmailEmpfang.NachAbholenLöschen = True And Vollständig = True Then
' Mail zum Löschen markieren
SendData "dele " & EmailEmpfang.Emails(Nr).Nr & vbCrLf
Mld.Meldung "Nachricht " & EmailEmpfang.Emails(Nr).Nr & " markieren", Mld_Info, False
If WaitResponse = False Then GoTo er
End If
If Vollständig = True Then WriteMail EmailEmpfang.Emails(Nr) 'erstmal die ganze Mail so speichern wie sie gekommen ist
Next
Exit Sub
er:
Mld.Meldung "Fehler beim E-Mail abholen (evtl. kein Response)", Mld_Fehler, False
End Sub
= Save Attachments
Public Sub AnhängeSpeichern()
Dim Nr As Long
On Error GoTo AS_Error
For Nr = 1 To UBound(EmailEmpfang.Emails)
Mld.Meldung "Anhänge speichern für Mail " & EmailEmpfang.Emails(Nr).Nr, Mld_Info, False
FindBoundarys EmailEmpfang.Emails(Nr)
Next
AS_Exit:
Exit Sub
AS_Error:
Select Case err.Number
Case 3146, 91, 3155, 3157, 3669 'ODBC... Das Objekt ist ungültig..Akualisieren/Einfügen..Ausführung abgebrochen
Mld.Meldung "Fehler beim Speichern der E-Mail Anhänge: " & Erl & ":" & err.Number & " " & err.Description, Mld_EMailEDV, False
Dim Ie As Integer
For Ie = 0 To DBEngine.Errors.Count - 1
Mld.Meldung DBEngine.Errors(Ie).Number & " " & DBEngine.Errors(Ie).Description, Mld_EMailEDV, False
Next
Set DBEngine = Nothing
If Mld.getRestartNeeded Then Exit Sub
Sleep 1000: DoEvents: Resume
Case Else
Mld.Meldung "Fehler beim Speichern der E-Mail Anhänge: " & Erl & ":" & err.Number & " " & err.Description, Mld_EMailEDV, False
DoEvents: Resume AS_Exit 'Next
End Select
End Sub
= Write Raw Mail
Private Sub WriteMail(Mail As TEmail)
' Mail so speichern wie sie gekommen ist , die kann man dann mit Outlook öffnen :)
Dim Name$
Dim ff As Integer
Name$ = "Mail " & Format$(Now, "yyyymmdd hhnnss") & " " & Mail.Nr & ".eml"
Mld.Meldung "Mail speichern " & Name$, Mld_Info, False
ff = FreeFile
Open EmailEmpfang.BackupPfad & Name$ For Output As #ff
Print #ff, Mail.daten;
Close #ff
End Sub
Private Sub FindBoundarys(Mail As TEmail)
' Debug.Print Mail.Daten
' Content-Type: multipart/mixed;
' boundary="----=_NextPart_000_0007_01C7388F.2C80B620"
' zuerst die boundarys suchen
Dim UDaten As String 'zum Parsen
Dim BOUNDARY$
Dim x1 As Long
Dim x2 As Long
Dim x3 As Long
On Error GoTo FB_Error
If Len(Mail.daten) = 0 Then
Mld.Meldung "Keine Maildaten in der Struktur TEmail.Daten !? Len=0", Mld_Fehler, False
Exit Sub
End If
UDaten = UCase$(Mail.daten)
x1 = 1
While x1
x1 = InStr(x1, UDaten, "CONTENT-TYPE:")
x2 = 0
x3 = 0
If x1 >= 1 Then x1 = InStr(x1, UDaten, "BOUNDARY=")
If x1 >= 1 Then
x2 = InStr(x1 + 9, UDaten, Chr$(34))
x3 = InStr(x1 + 10, UDaten, vbCr)
If x2 < x3 Then
'x2 = x2 ' X2 wird unten als Start für die weitere Suche verwendet
'BOUNDARY = Mid$(UDaten, x1 + 10, x2 - (x1 + 10)) '----=_NEXTPART_000_0005_01C7365F.ED755070
BOUNDARY = Mid$(UDaten, x2 + 1, x3 - x2 - 2) '----=_NEXTPART_000_0005_01C7365F.ED755070
Else
x2 = x3
BOUNDARY = Mid$(UDaten, x1 + 9, x3 - (x1 + 9)) ' Dann halt ohne Gänsefüßchen
End If
SplitBoundary Mail, BOUNDARY
End If
If x2 > 0 Then
x1 = x2 + 1
'ElseIf x3 > 0 Then
' x1 = x2 + 1
Else
x1 = 0
End If
Wend
FB_Exit:
Exit Sub
FB_Error:
Select Case err.Number
Case 3146, 91, 3155, 3157, 3669 'ODBC... Das Objekt ist ungültig..Akualisieren/Einfügen..Ausführung abgebrochen
Mld.Meldung "Mail FB: " & Erl & ":" & err.Number & " " & err.Description, Mld_EMailEDV, False
Dim Ie As Integer
For Ie = 0 To DBEngine.Errors.Count - 1
Mld.Meldung DBEngine.Errors(Ie).Number & " " & DBEngine.Errors(Ie).Description, Mld_EMailEDV, False
Next
Set DBEngine = Nothing
If Mld.getRestartNeeded Then Exit Sub
Sleep 1000: DoEvents: Resume
Case Else
Mld.Meldung "Mail FB: " & Erl & ":" & err.Number & " " & err.Description, Mld_EMailEDV, False
DoEvents: Resume FB_Exit 'Next
End Select
End Sub
Private Sub SplitBoundary(Mail As TEmail, ByVal BOUNDARY$)
'Debug.Print BOUNDARY$
'Jetzt in der Mail die Abschnitte finden
'BOUNDARY$ =
'----=_NEXTPART_000_0005_01C7365F.ED755070
'Anfang --boundary
'Next --boundary
'Ende --boundary--
'Unter boundary kommt dann sowas bis 2xcrlf
'Content-Type: application/octet-stream;
' name="VSLO1026.BXT"
'Content-Transfer-Encoding: quoted-printable
'Content-Disposition: attachment;
' filename="VSLO1026.BXT"
'oder sowas
'Content-Type: text/plain;
' name="myToDo.txt"
'Content-Transfer-Encoding: quoted-printable
'Content-Disposition: attachment;
' filename="myToDo.txt"
Dim UDaten As String 'zum Parsen
Dim x1 As Long
Dim x2 As Long
Dim x3 As Long
Dim BoundaryInfo$
On Error GoTo SB_Error
UDaten = UCase$(Mail.daten)
x1 = 1
While x1
BoundaryInfo$ = ""
x1 = InStr(x1, UDaten, "--" & BOUNDARY$)
x2 = 0
If x1 >= 1 Then
x1 = x1 + 2 + Len(BOUNDARY$) + 2
x3 = InStr(x1, UDaten, vbCrLf & vbCrLf)
If x3 > 0 Then x3 = x3 + 4
If x3 > x1 Then
BoundaryInfo$ = Mid$(Mail.daten, x1, x3 - x1)
x2 = InStr(x3, UDaten, "--" & BOUNDARY$) 'nächste Grenze suchen , beim Ende ist noch -- dran , ist mir aber egal
If x2 >= 1 Then x2 = x2 - 2 'davor ist crlf
End If
If x2 > x3 Then SaveSection Mid$(Mail.daten, x3, x2 - x3), BoundaryInfo$
End If
If x2 = 0 Then
x1 = 0
Else
x1 = x2 'nächste Grenze oder Ende=0
End If
Wend
SB_Exit:
Exit Sub
SB_Error:
Select Case err.Number
Case 3146, 91, 3155, 3157, 3669 'ODBC... Das Objekt ist ungültig..Akualisieren/Einfügen..Ausführung abgebrochen
Mld.Meldung "Mail SB: " & Erl & ":" & err.Number & " " & err.Description, Mld_EMailEDV, False
Dim Ie As Integer
For Ie = 0 To DBEngine.Errors.Count - 1
Mld.Meldung DBEngine.Errors(Ie).Number & " " & DBEngine.Errors(Ie).Description, Mld_EMailEDV, False
Next
Set DBEngine = Nothing
If Mld.getRestartNeeded Then Exit Sub
Sleep 1000: DoEvents: Resume
Case Else
Mld.Meldung "Mail SB: " & Erl & ":" & err.Number & " " & err.Description, Mld_EMailEDV, False
DoEvents: Resume SB_Exit 'Next
End Select
End Sub
Private Sub SaveSection(ByVal Section$, BoundaryInfo$)
'Section sind die Daten in der Mail die evtl. umgewandelt werden müssen
'In BoundaryInfo steht der Dateiname und die Art wie die Daten vorliegen
'Debug.Print BoundaryInfo$
'Content-Type: application/octet-stream;
' name="VSLO1025.BXT"
'Content-Transfer-Encoding: quoted-printable
'Content-Disposition: attachment;
' filename="VSLO1025.BXT"
Dim Filename$
Dim Encoding$
Dim Save$
Dim ff As Integer
On Error GoTo SSect_Error
Save$ = ""
'--------------------------------------------------------------------
If GetContentAttachmentFileName(BoundaryInfo$, Filename$) = True Then
'/----- 23.10.2012 -----\Juerke------------------------------------------------
'If Filename$ Like EmailEmpfang.DateiFilter Then
If UCase$(Filename$) Like UCase$(EmailEmpfang.DateiFilter) Then
'\----- 23.10.2012 -----/Juerke------------------------------------------------
'erlaubt
Else
'nicht erlaubt !
Mld.Meldung "Attachment '" & Filename$ & "' wird nicht gespeichert weil nicht erlaubt im Filter " & EmailEmpfang.DateiFilter & " !? ", Mld_EMailVVSupport, False
Exit Sub
End If
If GetContentEncoding(BoundaryInfo, Encoding$) = True Then
Select Case Encoding$
Case "QUOTED-PRINTABLE" ' Inhalt ist in 7 Bit
Save$ = DecodeQuotedPrintable(Section$)
Case "BASE64"
Save$ = DecodeBase64(Section$)
Case "8BIT"
Save$ = Decode8Bit(Section$)
Case Else
Mld.Meldung "Attachment Encoding nicht gefunden !?", Mld_Fehler, False
End Select
End If 'Encoding
End If 'Dateianhang
'--------------------------------------------------------------------
If Len(Filename$) > 0 And Len(Save$) > 0 Then
Mld.Meldung "Mailanhang schreiben '" & Filename$ & "'", Mld_Info, False
ff = FreeFile
Open EmailEmpfang.AttachmentPfad & Filename$ For Output As #ff
Print #ff, Save$;
Close #ff
ff = 0
End If
'--------------------------------------------------------------------
SSect_Exit:
Exit Sub
SSect_Error:
Select Case err.Number
Case 3146, 91, 3155, 3157, 3669 'ODBC... Das Objekt ist ungültig..Akualisieren/Einfügen..Ausführung abgebrochen
Mld.Meldung "Mail SSect: " & Erl & ":" & err.Number & " " & err.Description, Mld_EMailEDV, False
Dim Ie As Integer
For Ie = 0 To DBEngine.Errors.Count - 1
Mld.Meldung DBEngine.Errors(Ie).Number & " " & DBEngine.Errors(Ie).Description, Mld_EMailEDV, False
Next
Set DBEngine = Nothing
If Mld.getRestartNeeded Then Exit Sub
Sleep 1000: DoEvents: Resume
Case Else
Mld.Meldung "Mail SSect: " & Erl & ":" & err.Number & " " & err.Description, Mld_EMailEDV, False
If ff Then Close #ff: ff = 0
DoEvents: Resume SSect_Exit 'Next
End Select
'Mld.Meldung "ERR Sub SaveSection " & err.Number & ":" & err.Description, Mld_EMailEDV, False
End Sub
Private Function GetContentEncoding(ByVal Info$, ByRef Encoding$) As Boolean
'Content-Transfer-Encoding: quoted-printable
'Content-Transfer-Encoding: base64
GetContentEncoding = False
Info$ = UCase$(Info$)
Encoding$ = ""
Dim x1 As Long
Dim x2 As Long
x1 = InStr(Info$, "CONTENT-TRANSFER-ENCODING:")
If x1 >= 1 Then
x1 = x1 + 27
x2 = InStr(x1, Info$, vbCr)
If x2 > x1 Then
Encoding$ = Mid$(Info$, x1, x2 - x1)
GetContentEncoding = True
End If
End If
End Function
Private Function GetContentAttachmentFileName(ByVal Info$, ByRef Filename$) As Boolean
'Content-Disposition: attachment;
' filename="VSLO1025.BXT"
Dim x1 As Long
Dim x2 As Long
Dim x3 As Long
Dim I As Integer
Dim S As String
GetContentAttachmentFileName = False
Info$ = UCase$(Info$)
Filename$ = ""
x1 = InStr(Info$, "CONTENT-DISPOSITION:")
If x1 >= 1 Then
x1 = InStr(x1 + 20, Info$, "ATTACHMENT")
If x1 >= 1 Then
For I = -1 To 10
If I = -1 Then
S = "FILENAME="
Else
S = "FILENAME*" & Trim$(I) & "*="
End If
' Hinter dem Attachment anfangen zu suchen
x1 = InStr(x1 + 9, Info$, S)
If x1 >= 1 Then
' Filename gefunden?
x1 = x1 + Len(S) ' Erstes Zeichen HINTER dem "Filename="
x2 = InStr(x1, Info$, Chr$(34))
x3 = InStr(x2 + 1, Info$, Chr$(34))
If x2 > 0 And x3 > x2 Then
S = Mid$(Info$, x2 + 1, x3 - x2 - 1)
Filename$ = Filename$ & getMailTrim(S)
End If
End If
Next
If Filename$ <> "" Then
Filename$ = ISO88591(Filename$)
Filename$ = UTF8(Filename$)
Filename$ = Replace$(Filename$, "/", "\") 'Pfade für Windows
x1 = InStrRev(Filename$, "\")
If x1 >= 1 Then Filename$ = Mid$(Filename$, x1 + 1) 'ohne Pfad !
GetContentAttachmentFileName = True
End If
End If ' Attachment
End If ' Content disposition
End Function
Private Function getMailTrim(S_In As String) As String
' Wurde nötig, weil die Strings der Dateinamen (oder generell Properties)
' Mal mit Zeilenumbruch starten, mal Gänsefüßchen haben...
Dim Fertig As Boolean
Dim S As String
S = S_In
While Not Fertig
Fertig = True
If Left$(S, 1) = Chr$(9) Or Left$(S, 1) = Chr$(34) Or Left$(S, 1) = vbCr Or Left$(S, 1) = vbLf Or Left$(S, 1) = " " Then
Fertig = False
S = Mid$(S, 2)
End If
If Left$(S, 1) = Chr$(9) Or Right$(S, 1) = Chr$(34) Or Right$(S, 1) = vbCr Or Right$(S, 1) = vbLf Or Right$(S, 1) = " " Then
Fertig = False
S = Left$(S, Len(S) - 1)
End If
Wend
getMailTrim = S
End Function
Private Function ISO88591(ByVal Tx$) As String
'FILENAME="=?ISO-8859-1?Q?DFLO1182=2EBXT?="
'DFLO1182.BXT
'... welcher Idiot denkt sich sowas aus ???
'=?ISO-8859-1?Q?DFLO1182=2EBXT?=
'http://de.wikipedia.org/wiki/ISO_8859-1
'-1 = Latin-1, Westeuropäisch
Dim h As Integer
ISO88591 = Tx$
If InStr(ISO88591, "=?ISO-8859-1?Q?") >= 1 Then
' Ach, grad auch >=1 getestet, aber dann doch Position 1 voraussetzen??
ISO88591 = Mid$(ISO88591, 16)
ISO88591 = Replace$(ISO88591, "?=", "")
For h = 32 To 255
If h <> 61 Then ISO88591 = Replace$(ISO88591, "=" & Hex$(h), Chr$(h))
Next
End If
End Function
Private Function UTF8(ByVal Tx$) As String
Dim h As Integer
UTF8 = Tx$
h = InStr(UTF8, "UTF-8''")
If h >= 1 Then
UTF8 = Mid$(UTF8, h + 7)
UTF8 = Replace$(UTF8, "%", "_")
End If
End Function
Private Function DecodeQuotedPrintable(ByVal Tx$) As String
' http://de.wikipedia.org/wiki/Quoted-printable
' im Text kann jetzt noch =XX vorkommen
' XX ist dann der Hexadizimalwert damit man es wieder in 8Bit umwandeln kann
Dim h As Integer
Tx$ = Replace$(Tx$, "=" & vbCrLf, "") 'Dieses doofe Zeichen wieder entfernen
For h = 128 To 255
Tx$ = Replace$(Tx$, "=" & Hex$(h), Chr$(h))
Next
Tx$ = Replace$(Tx$, "=3D", "=") 'das Gleichzeichen wurde vorher auch umgewandelt
DecodeQuotedPrintable = Tx$
End Function
Private Function Decode8Bit(ByVal Tx$) As String
Decode8Bit = Tx$
End Function
Private Function DecodeBase64(ByVal Tx$) As String
'! Durch den Puffer$ läßt sich eine 1 MB Datei in 15 Sek. Decoden was vorher > 1Std. gedauert hat :-)
'wenn man an lange Strings mit kleinen Strings kompiniert dauert das sehr lange :(
Dim sp() As String
Dim Zeile$
Dim I As Long
Dim t As Long
Dim Wandel As String
Dim sourceB() As Byte
Dim Result(3) As Byte
Dim w1 As Byte, w2 As Byte
Dim w3 As Byte, w4 As Byte
Dim BytesKürzen As Integer
Dim Puffer$
'320 Kilobyte dauern 3 Sek.
'1 MB ca. 15 Sek.
'Debug.Print "DecodeBase64 Start " & Now & " länge =" & Len(Tx$)
DecodeBase64 = ""
Puffer$ = ""
sp = Split(Tx$, vbCrLf) 'in Zeilen zerlegen
BytesKürzen = 0
For I = LBound(sp) To UBound(sp)
Zeile = sp(I)
For t = 1 To Len(Zeile) Step 4
Wandel = Mid$(Zeile, t, 4)
If Len(Wandel) = 4 Then
If Left(Wandel, 4) <> "----" Then
sourceB() = StrConv(Wandel, vbFromUnicode)
w1 = Rev64(sourceB(0))
w2 = Rev64(sourceB(1))
w3 = Rev64(sourceB(2)) '=
w4 = Rev64(sourceB(3)) '=
Result(0) = ((w1 * 4 + Int(w2 / 16)) And 255) '8
Result(1) = ((w2 * 16 + Int(w3 / 4)) And 255) '16
Result(2) = ((w3 * 64 + w4) And 255) '24
Puffer$ = Puffer$ & Chr$(Result(0)) & Chr$(Result(1)) & Chr$(Result(2))
If Len(Puffer$) > 2048 Then '2048 Bytes 15 Sek. , 1024 Bytes 18 Sek. , 4096 Bytes 16 Sek. , 256 Bytes 46 Sek.
DecodeBase64 = DecodeBase64 & Puffer$: Puffer$ = ""
End If
If sourceB(3) = 61 Then BytesKürzen = 1
If sourceB(2) = 61 Then BytesKürzen = 2
End If 'komplett Ende kann man sich sparen
End If 'min. 4 Bytes
Next
Next 'Alle Zeilen durch gehen
DecodeBase64 = DecodeBase64 & Puffer$: Puffer$ = ""
'= ist ASC 61
If BytesKürzen > 0 Then
DecodeBase64 = Left$(DecodeBase64, Len(DecodeBase64) - BytesKürzen)
End If
'Debug.Print "DecodeBase64 Ferig " & Now
End Function
Public Sub EMLDirekt(ByVal DateiName$)
'zum testen der Base64 encoden Geschichte
'hier kann man so tun als sei die Mail vom Mail Server gekommen
'also OHNE das eine Verbindung aufgebaut wird und OHNE das Abholen
'wenn man Mails die nicht verarbeitet werden können weiterleitet
'kann es sein das das Format/Encoding geändert wird !
Dim ff As Integer
ff = FreeFile
Dim L As Long
Dim daten$
Open DateiName$ For Binary As #ff
L = LOF(ff)
daten$ = String(L, Space(1))
Get #ff, , daten$
Close #ff
Debug.Print "Dateilänge " & L & " String im Speicher " & Len(daten$)
Dim MailIndex As Long
MailIndex = UBound(EmailEmpfang.Emails) + 1
ReDim Preserve EmailEmpfang.Emails(MailIndex)
EmailEmpfang.Emails(MailIndex).Nr = 1
EmailEmpfang.Emails(MailIndex).Von = "John Doe <j.doe@any.com>"
EmailEmpfang.Emails(MailIndex).Betreff = "EML"
EmailEmpfang.Emails(MailIndex).Bytes = L
EmailEmpfang.Emails(MailIndex).daten = daten$
End Sub
AGK (Steam) V2017.05.15 : Windows 10 Pro 64 Bit : AMD (17.4.4) Radeon R7 265 : Mac mini OS Sierra (10.12.2)