SendMail_Include.pbi (windows / linux / macos)

[ts-soft]

Aufgrund der Diskussion in diesem Thread: http://www.purebasic.fr/german/viewtopi ... 75#p272975
habe ich den dort geposteten Code etwas überarbeitet. Leider konnte ich bisher keine Unicode-Unterstützung
implementieren, dafür müsste man wohl eine andere Protokoll-Version nutzen, da fehlen mir aber die Infos.

// edit: Unicode wird jetzt Unterstützt, sowie Umlaute in Texten!

Hier der Code:

Code: Alles auswählen

;- _____________________________________________________________________________
;- |                                                                           |
;- |                              SendEmail (New)                              |
;- |                              _______________                              |
;- |                                                                           |
;- |___________________________________________________________________________|
;{ SendEmail (New) (Start)                                       
; Author : clipper
; PureBasic 3.93
; Changed to Purebasic 4.61 x86 from Falko
; Sending Mail with SMTP-AUTH + add multiple attachments
; Don´t fill the Username if you don't want authentification

; changed by ts-soft:
; + variabledeclaration (for EnableExplicit)
; + Prefix SendMail_ for Functions and global Vars, __SendMail_ for private Functions
; + compatibility to linux
; + option to set the port in SendMail_SendEmail()
; + Unicode-Support
; ^ fixed many bugs
; + added Structure for SendMail_SendEMail() Parameter
; + added Callback for AttachedFile
; + added Protocol option
; + added timeout
; + cancel on more errors, thx to IdeasVacuum
; + mime-support for MacOS
; + supports multiple recipients
;}
EnableExplicit

Enumeration
  #eHlo
  #RequestAuthentication
  #Username
  #Password
  #MailFrom
  #RcptTo
  #Data
  #Quit
  #Complete
EndEnumeration

Structure SendMail_Parameter
  Name.s
  Sender.s
  Recipient.s
  UserName.s
  Password.s
  SMTPServer.s
  Subject.s
  Body.s
  Port.w
  ProgressAttachedFile.i
  EnableProtocol.b
EndStructure

Prototype SendMail_Callback(percent.i)

Global NewList SendMail_Attachments.s()
Global SendMail_ConnectionID

Procedure SendMail_AddAttachment(File.s)
  AddElement(SendMail_Attachments())
  SendMail_Attachments() =  File
EndProcedure

Procedure SendMail_NoAttachment()
  ClearList(SendMail_Attachments())
EndProcedure

Procedure.s __SendMail_GetMimeType(pExt.s)
  ; Cross-Platform
  ; Windows code originally by Kale
  ; Linux code by Straker
  ;
  ; returns as default "application/octet-stream" if Mime Type is not found.
  
  Protected lRetVal.s, lMimeFile.s, lContinue
  Protected hKey, lKeyValue.s, lDataSize.l, lLoop
  Protected lLof.q, *lMemoryID, lBytesRead, lFileContents.s
  Protected lPos1, lPos2, lMimeLen, lMyChar.s, lDefault.s
  Protected MimeFile
  
  Protected Dim lExt.s(7)
  
  lContinue = 1
  lDefault = "application/octet-stream"
  
  CompilerSelect #PB_Compiler_OS

    CompilerCase #PB_OS_MacOS
      Select LCase(pExt)
        Case "pdf" : lRetVal = "application/pdf"
        Case "ai", "eps", "ps" : lRetVal = "application/postscript"
        Case "rtf" : lRetVal = "application/rtf"
        Case "tar" : lRetVal = "application/x-tar"
        Case "zip" : lRetVal = "application/zip"
        Case "au", "snd" : lRetVal = "audio/basic"
        Case "aif", "aiff", "aifc" : lRetVal = "audio/x-aiff"
        Case "wav" : lRetVal = "audio/x-wav"
        Case "gif" : lRetVal = "image/gif"
        Case "jpg", "jpeg", "jpe" : lRetVal = "image/jpeg"
        Case "png" : lRetVal = "image/png"
        Case "tiff", "tif" : lRetVal = "image/tiff"
        Case "zip" : lRetVal = "multipart/x-zip"
        Case "gz", "gzip" : lRetVal = "multipart/x-gzip"
        Case "htm", "html" : lRetVal = "text/html"
        Case "txt", "g", "h", "c", "cc", "hh", "m", "f90" : lRetVal = "text/plain"
        Case "mpeg", "mpg", "mpe" : lRetVal = "video/mpeg"
        Case "qt", "mov" : lRetVal = "video/quicktime"
        Case "avi" : lRetVal = "video/msvideo "
        Case "movie" : lRetVal = "video/x-sgi-movie"
        Default
          lRetVal = lDefault
      EndSelect    

    CompilerCase #PB_OS_Windows
      pExt = ("." + pExt)
      lKeyValue = Space(255)
      lDataSize = 255
      If (RegOpenKeyEx_(#HKEY_CLASSES_ROOT, pExt, 0, #KEY_READ, @hKey))
        lKeyValue = lDefault
      Else
        If RegQueryValueEx_(hKey, "Content Type", 0, 0, @lKeyValue, @lDataSize)
          lKeyValue = lDefault
        Else
          lKeyValue = Left(lKeyValue, (lDataSize - 1))
        EndIf
        RegCloseKey_(hKey)
      EndIf
      lRetVal = lKeyValue
      
    CompilerCase #PB_OS_Linux
      
      pExt = LCase(pExt)
      lRetVal = lDefault
      lMimeFile = "/etc/mime.types"
      
      MimeFile = ReadFile(#PB_Any, lMimeFile)
      If MimeFile
        lLof = Lof(MimeFile)
        *lMemoryID = AllocateMemory(lLof)
        If (*lMemoryID)
          lBytesRead = ReadData(MimeFile, *lMemoryID, lLof)
          lFileContents = PeekS(*lMemoryID, lLof, #PB_UTF8)
        Else
          lContinue = 0
        EndIf
        CloseFile(MimeFile)
      Else
        lContinue = 0
      EndIf
      
      If (lContinue = 1)
        ; find the extension in the /etc/mime.types file
        
        lExt.s(0) = (Space(1) + pExt + Space(1))
        lExt.s(1) = (Chr(9) + pExt + Chr(10))
        lExt.s(2) = (Chr(9) + pExt + Space(1))
        lExt.s(3) = (Chr(9) + pExt + Chr(9))
        lExt.s(4) = (Chr(9) + pExt)
        lExt.s(5) = (Space(1) + pExt + Chr(10))
        lExt.s(6) = (Space(1) + pExt + Chr(9))
        lExt.s(7) = (Space(1) + pExt)
        
        lContinue = 0
        
        For lLoop = 0 To 7 Step 1
          lPos1 = FindString(lFileContents, lExt.s(lLoop), 1)
          If (lPos1 > 0)
            lContinue = 1
            Break
          EndIf
        Next
        
      EndIf
      
      If (lContinue = 1)
        ; found the line - parse the mime type...
        For lLoop = 1 To 80 Step 1
          If (Mid(lFileContents, (lPos1 - lLoop), 1) = Chr(10))
            lPos2 = (lPos1 - lLoop + 1)
            Break
          EndIf
        Next
      EndIf
      
      If (lPos2 > 0)
        For lLoop = 1 To 80 Step 1
          lMyChar = Mid(lFileContents, (lPos2 + lLoop), 1)
          If ((lMyChar = Chr(9)) Or (lMyChar = " "))
            lMimeLen = lLoop
            Break
          EndIf
        Next
      EndIf
      
      If (lMimeLen > 0)
        lRetVal = Trim(Mid(lFileContents, lPos2, lMimeLen))
        If (Left(lRetVal, 1) = "#")
          lRetVal = lDefault
        EndIf
      EndIf
      
      FreeMemory(*lMemoryID)
      
  CompilerEndSelect
  
  ProcedureReturn lRetVal
EndProcedure

Procedure.s __SendMail_Base64Encode(strText.s)
  Protected Result.s
  Protected *B64EncodeBufferA = AllocateMemory(Len(strText) + 1)
  Protected *B64EncodeBufferB = AllocateMemory((Len(strText) * 3) + 1)
  PokeS(*B64EncodeBufferA, strText, -1, #PB_Ascii)
  Base64Encoder(*B64EncodeBufferA, Len(strText), *B64EncodeBufferB, Len(strText) * 3)
  Result = PeekS(*B64EncodeBufferB, -1, #PB_Ascii)
  FreeMemory(*B64EncodeBufferA)
  FreeMemory(*B64EncodeBufferB)
  ProcedureReturn Result
EndProcedure

Procedure __SendMail_Send(msg.s)
  Protected *mem, length
  msg + #CRLF$
  length = StringByteLength(msg, #PB_UTF8)
  *mem = AllocateMemory(length + 1)
  If *mem
    PokeS(*mem, msg, -1, #PB_UTF8)
    SendNetworkData(SendMail_ConnectionID, *mem, length)
    FreeMemory(*mem)
  EndIf
EndProcedure

Procedure __SendMail_SendFiles(ProgressCB.SendMail_Callback = 0)
  Protected file.s, FF, InputBufferLength.i, OutputBufferLength.i
  Protected *memin, *memout, Boundry.s, temp.s, i
  
  ResetList(SendMail_Attachments())
  While(NextElement(SendMail_Attachments()))
    file = SendMail_Attachments()
    __SendMail_Send("")
    FF = ReadFile(#PB_Any, file)
    InputBufferLength = Lof(FF)
    OutputBufferLength = InputBufferLength * 1.4
    *memin = AllocateMemory(InputBufferLength)
    If *memin
      *memout = AllocateMemory(OutputBufferLength)
      If *memout
        Boundry = "--MyBoundary"
        __SendMail_Send(Boundry)
        __SendMail_Send("Content-Type: " + __SendMail_GetMIMEType(GetExtensionPart(file)) + "; name=" + Chr(34) + GetFilePart(file.s) + Chr(34))
        __SendMail_Send("Content-Transfer-Encoding: base64")
        __SendMail_Send("Content-Disposition: Attachment; filename=" + Chr(34) + GetFilePart(file) + Chr(34))
        __SendMail_Send("")
        ReadData(FF, *memin, InputBufferLength)
        Base64Encoder(*memin, 60, *memout, OutputBufferLength)
        __SendMail_Send(PeekS(*memout, 60, #PB_Ascii)) ; this must be done because For i=0 To OutputBufferLength/60 doesn't work
        If ProgressCB
          ProgressCB(60 / (OutputBufferLength / 100))
        EndIf
        Base64Encoder(*memin, InputBufferLength, *memout, OutputBufferLength)               
        For i = 1 To OutputBufferLength / 60
          temp = Trim(PeekS(*memout + i * 60, 60, #PB_Ascii))
          If Len(temp) > 0
            __SendMail_Send(temp)
            If ProgressCB
              ProgressCB((60 * i) / (OutputBufferLength / 100))
            EndIf
          EndIf
        Next
        FreeMemory(*memout)
      EndIf
      FreeMemory(*memin)
    EndIf
    CloseFile(FF)
  Wend
  ProcedureReturn
EndProcedure

Procedure.s __SendMail_SendEmail(*para.SendMail_Parameter, TimeOut.l, Number = 0)
  Protected loop250, ReceivedData.s, ct, cmdID.s, cmdText.s
  Protected State, quit, ProtocolTxt.s, Time.l = ElapsedMilliseconds()

  If *para\Port = 0 : *para\Port = 25 : EndIf
  
  SendMail_ConnectionID = OpenNetworkConnection(*para\SMTPServer, *para\Port)
  With *para
    If SendMail_ConnectionID
      Repeat   
        If NetworkClientEvent(SendMail_ConnectionID)
          ReceivedData = Space(9999)
          ct = ReceiveNetworkData(SendMail_ConnectionID, @ReceivedData, 9999)
          ReceivedData = PeekS(@ReceivedData, -1, #PB_Ascii)
          If ct
            cmdID = Left(ReceivedData, 3)
            cmdText = Mid(ReceivedData, 5, ct - 6)
            If \EnableProtocol = #True
              ProtocolTxt + "[" + FormatDate("%hh:%ii:%ss", Date()) + "] " + cmdText + #CRLF$
            EndIf
            Select cmdID
              Case "220"
                If Len(\Username) > 0
                  __SendMail_Send("Ehlo " + Hostname())
                  State = #eHlo
                Else
                  __SendMail_Send("HELO " + Hostname())
                  State = #MailFrom
                EndIf   
              Case "221"
                __SendMail_Send("[connection closed]")
                State = #Complete
                quit = 1     
              Case "235"
                __SendMail_Send("MAIL FROM: <" + \Sender + ">")
                State = #RcptTo
                
              Case "334"
                If State=#RequestAuthentication
                  __SendMail_Send(__SendMail_Base64Encode(\UserName))
                  State = #Username
                EndIf
                If State = #Username
                  __SendMail_Send(__SendMail_Base64Encode(\Password))
                  state = #Password
                EndIf
                
              Case "250"
                Select state
                  Case #eHlo
                    __SendMail_Send("AUTH LOGIN")
                    state = #RequestAuthentication     
                  Case #MailFrom   
                    __SendMail_Send("MAIL FROM: <" + \Sender + ">")
                    state = #RcptTo
                  Case #RcptTo
                    __SendMail_Send("RCPT TO: <" + StringField(\Recipient, Number + 1, ";") + ">")
                    state = #Data
                  Case #Data
                    __SendMail_Send("DATA")
                    state = #Quit
                  Case #Quit
                    __SendMail_Send("QUIT")
                EndSelect
                
              Case "251"
                __SendMail_Send("DATA")
                state = #Data
              Case "354"
                __SendMail_Send("X-Mailer: eSMTP 1.0")
                __SendMail_Send("To: " + \Recipient)
                __SendMail_Send("From: " + \Name + " <" + \Sender + ">")
                __SendMail_Send("Reply-To: " + \Sender)
                __SendMail_Send("Date:" + FormatDate("%dd/%mm/%yyyy @ %hh:%ii:%ss", Date()))
                __SendMail_Send("Subject: " + \Subject)
                __SendMail_Send("MIME-Version: 1.0")
                __SendMail_Send("Content-Type: multipart/mixed; boundary=" + Chr(34) + "MyBoundary" + Chr(34))
                __SendMail_Send("")
                __SendMail_Send("--MyBoundary")
                __SendMail_Send("Content-Type: text/plain; charset=utf-8")
                __SendMail_Send("Content-Transfer-Encoding: 8bit")
                __SendMail_Send("")                     
                __SendMail_Send(\Body)
                __SendMail_SendFiles(\ProgressAttachedFile)
                __SendMail_Send("--MyBoundary--")
                __SendMail_Send(".")
 
               Case "421", "450", "451", "452", "454", "500", "501", "502", "503", "535","550", "551", "552", "553", "554"
                ProtocolTxt + cmdID + " " + cmdText + #CRLF$
                quit = 1     
            EndSelect
          EndIf
        EndIf
        
      Until quit = 1 Or ElapsedMilliseconds() > (Time + TimeOut)
      CloseNetworkConnection(SendMail_ConnectionID)
      
    EndIf
  EndWith
  
  ProcedureReturn ProtocolTxt
EndProcedure

Procedure.s SendMail_SendEmail(*para.SendMail_Parameter, TimeOut.l = 15000)
  Protected Result.s
  Protected I, Count = CountString(*para\Recipient, ";")
  For I = 0 To Count
    Result + StringField(*para\Recipient, I + 1, ";") + ":" + #CRLF$
    Result + __SendMail_SendEmail(*para, TimeOut.l, I)
  Next
  ProcedureReturn Result
EndProcedure

InitNetwork()

Define mpara.SendMail_Parameter
With mpara
  \Name = "Mein Name bei email.de"  ; Hier ist egal was steht.
  \Sender = "******@alice.de"       ; E-Mail des Senders
  \Recipient = "******@web.de"      ; E-Mail des Empfängers
  \UserName = "******@alice.de"     ; Username
  \Password = "******"              ; hier dein Kennwort
  \SMTPServer = "smtp.alice.de"
  \Subject = "Diese Mail wurde von mir geschickt" ; Hier Betreffzeile
  \Body = "Das ist eine Mail, die ich mal testweise an mich selber über PB schicke" ; Hier der Text im Body
  \Port = 587
  \EnableProtocol = #True
EndWith

SendMail_AddAttachment("d:\Dateien\purebasic\Meine Projekte\SendMail\SendMail_Include.pbi")
Define.s ProtocolTxt.s = SendMail_SendEmail(mpara)

If ProtocolTxt
  OpenWindow(0, #PB_Ignore, #PB_Ignore, 640, 480, "SendMail - Protocol")
  EditorGadget(0, 5, 5, 630, 470, #PB_Editor_ReadOnly)
  SetGadgetText(0, ProtocolTxt)
  Repeat : Until WaitWindowEvent() = #PB_Event_CloseWindow
EndIf

Verbesserungen, Fehlermeldungen usw. sind ausdrücklich erwünscht

Gruß
Thomas

Erfolgreich getested mit: Evanzo, Alice, GMX.de, Web.de, to be continued ...
Misserfolg bei: GMail, to be continued ...

[ts-soft]

Update:
Unicode support hinzugefügt!

[Bisonte]

funktioniert tadellos (mit gmx getestet /ascii/unicode/x86/x64)

Allerdings, beim ersten Test schlug die Firewall an, ich klickte auf "durchlassen" und dann hing
sendmail irgendwo fest. (keine Ahnung wo ... Ablaufverfolgung zeigte die Letzte Zeile an, also den Hauptaufruf)

Edit: ich vergass Windows 7 x64 als Host OS zu erwähnen

[ts-soft]

Danke für das Feedback, hab jetzt mal eine Liste der SMTP-Server hinzugefügt, wo es geklappt oder eben nicht geklappt hat.

Die Reaktion auf Fehler sollte noch verbessert werden. Vielleicht kann da ja einer unser Netzwerkexperten noch was beisteuern?
Timeout fehlt auch noch, sowie die Ermittlung des MIME-Typs unter MacOS.

Auf jeden Fall lebt der alte Code aus dem BoardArchiv hier in aktualisierter Form weiter

//edit:

; + added Structure for SendMail_SendEMail() Parameter
; + added Callback for AttachedFile

[Falko]

Danke Thomas,
das du den Code soweit ausgebaut hast.

Wegen gmail.com. Vielleicht liegt es am Verschlüsselungstyp.
Bei mir wurde gmail unter Outlook automatisch auf TLS eingestellt.

Bei T-online ist der SMTP-Port 25, aber das kann man von Hand auch ändern.


Gruß,
Falko

[ts-soft]

Bei T-online ist der SMTP-Port 25, aber das kann man von Hand auch ändern.

Port 25 ist Standard, wird auch autom. genutzt, wenn in der Strukture nichts übergeben wird!

Für Google und ein paar andere benötigt man wohl zwingend SSL, aber das werde ich wohl eher nicht
hinzufügen

Gruß
Thomas

// edit:
Protokoll Option hinzugefügt, siehe Beispiel im ersten Thread.

[Falko]

Hallo Thomas,
ich weiß nicht ob das mit ssl zu tun hat, aber hier von droopy noch ein alter Code indem eine
Konstante #CALG_SSL3_SHAMD5 SSL3 client authentication vorhanden ist:

Code: Alles auswählen

ProcedureDLL.s RC4Api(string.s, Password.s) 
  *lpData=@string.s
  DataLength=Len(string)
  If CryptAcquireContext_(@hProv, #Null, #Null, #PROV_RSA_FULL, 0)=0 
    CryptAcquireContext_(@hProv, #Null, #Null, #PROV_RSA_FULL, #CRYPT_NEWKEYSET) 
  EndIf 
  If hProv 
    ; Hashing algorithms defined in the Windows API (constants commented above): 
    ; 
    ; #CALG_HMAC HMAC, a keyed hash algorithm 
    ; #CALG_MAC Message Authentication Code 
    ; #CALG_MD2 MD2 
    ; #CALG_MD5 MD5 
    ; #CALG_SHA US DSA Secure Hash Algorithm 
    ; #CALG_SHA1 Same as CALG_SHA 
    ; #CALG_SSL3_SHAMD5 SSL3 client authentication 
    ; 
    CryptCreateHash_(hProv, #CALG_MD5, 0, 0, @hHash) 
    If hHash 
      CryptHashData_(hHash, Password, Len(Password), 0) 
      ; 
      ; For a list of valid encryption algorithms, check: 
      ; 
      ; http://msdn.microsoft.com/library/en-us/seccrypto/security/alg_id.asp 
      ; 
      ; The constant values can be found in the Platform SDK include file: WinCrypt.h 
      ; 
      ; Here we're using RC4 
      ; 
      CryptDeriveKey_(hProv, #CALG_RC4, hHash, #CRYPT_EXPORTABLE, @hKey) 
      If hKey 
        If CryptEncrypt_(hKey, 0, #True, #Null, *lpData, @DataLength, DataLength) 
          Result = #True 
        Else 
          Error("CryptEncrypt_() failed") 
        EndIf 
        CryptDestroyKey_(hKey) 
      Else 
        Error("CryptDeriveKey_() failed") 
      EndIf 
      CryptDestroyHash_(hHash) 
    Else 
      Error("CryptCreateHash_() failed") 
    EndIf 
    CryptReleaseContext_(hProv, 0) 
  Else 
    Error("CryptAcquireContext_() failed") 
  EndIf 
  ProcedureReturn string 
EndProcedure 

[Edit]
oder hier speziell zu Timeout, SSL und TSL
http://www.purebasic.fr/english/viewtop ... t&start=15
[/Edit]

Gruß,
Falko

[ts-soft]

Keine Ahnung ob das genügt, aber selbst wenn, wäre es Windows-Only.
Ich denke aber das hilft nicht weiter, aber danke für Deine Hilfe.

Update:
Timeout hinzugefügt!

Bricht jetzt bei mehr Fehlermeldungen ab, danke an IdeasVacuum

Update:
Mime-Support für MacOS hinzugefügt.

[ts-soft]

Update:

Mehrere Empfänger (getrennt durch semikolon) werden jetzt unterstützt!

[Falko]

Danke Thomas