Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Send email class

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • PBWin Send email class

    Here is some code that I wrote for sending emails, cc, bcc, attachments, authentication, plain/html emails. Basically, I wrote it to help myself learn how to create the new PB Classes.

    Sample code to call the Class
    Code:
    #Compile Exe
    
    #Include "win32api.inc"
    
    #Include "clsEmail.inc"
    
    
    Function PBMain() As Long
    
       ' NOTES:
       ' The 'SendTo', 'CC', 'BCC' fields can be a one address or a
       ' semicolon(;) or comma(,) deliminated list of multiple addresses.
       ' SMTP only allows 100 recipients max at a time (per rfc821), therefore
       ' for large mailings you should break it into multiple emails.
       
       ' Multiple attachments can be sent by simply separating the file
       ' names with a semicolon or comma.
    
       ' You can use 'Plain' text emails or 'HTML' emails, or 'Both'. 
       ' When sending "Both", the email client application will use whichever 
       ' one it can render based on the user's settings.
    
       ' Default values for the following that are already set by the 
       ' class (constructor). Change them here if you want a different value.
       ' e.g.
       ' cMail.ServerTimeOut = 60000  ' milliseconds  ' default is 60000
       ' cMail.LocalHost     = "MySuperComputer"      ' default is localhost
       ' cMail.CharSet       = "us-ascii"             ' default is iso-8859-1
       ' cMail.MessageStyle  = "both"                 ' default is Plain
    
    
       Dim cMail As EMailInterface
       cMail = Class "clsEmail"
    
       cMail.SMTPServer   = "mysmtpxxxx.com"
       cMail.SendFrom     = "[email protected]"
       cMail.SendTo       = "[email protected]"
       cMail.CC           = "[email protected]"
       cMail.BCC          = "[email protected]"
       cMail.ReplyTo      = "[email protected]"
       cMail.Subject      = "test subject"
       
       cMail.EnableAuth   = %TRUE
       cMail.AuthType     = "AUTH LOGIN" 
       cMail.AuthUsername = "[email protected]"
       cMail.AuthPassword = "mypassword"
    
       cMail.MessageStyle = "both"
       cMail.Attachments  = ""       ' eg. "myfilename.zip"
    
       ' Plain text email
       cMail.PlainMessage = "This is my test message." & $CrLf & _
                            "Line #2" & $CrLf & _
                            "Last line."
    
       ' HTML text email
       cMail.HTMLMessage  = "<html>" & $CrLf  & _
                            "<body>" & $CrLf  & _
                            "<center><b>This Is a test!</b></center>" & $CrLf & _
                            "</body>" & $CrLf & _
                            "</html>" & $CrLf 
               
       ' Send the actual email and deal with any error/message response.
       If cMail.SendMail Then
          MsgBox "Error sending E-mail! " & cMail.Response
       Else
          MsgBox "Email(s) sent okay."
       End If   
    
       
    End Function
    clsEmail.inc
    Code:
    Class clsEmail
       Instance m_Server       As String
       Instance m_From         As String
       Instance m_ReplyTo      As String
       Instance m_TO           As String                                  
       Instance m_CC           As String                                  
       Instance m_BCC          As String                                  
       Instance m_Subject      As String
       Instance m_PlainMessage As String  
       Instance m_HTMLMessage  As String  
       Instance m_Response     As String
       Instance m_EnableAuth   As Long
       Instance m_AuthType     As String
       Instance m_AuthUsername As String
       Instance m_AuthPassword As String
       Instance m_Style        As String
       Instance m_Timeout      As Long
       Instance m_Attachments  As String
       Instance m_LocalHost    As String
       Instance m_CharSet      As String
       
       
       '------------------------------------------------------------
       '  Private Class methods
       '------------------------------------------------------------
       
       '//
       '//
       Class Method Create()   ' Constructor
          ' Initialize default properties
          m_Timeout     = 60000   '(60 seconds)
          m_CharSet     = "iso-8859-1"
          m_Style       = "plain"
          Host Name To m_LocalHost
       End Method
       
    
       '//
       '//
       Class Method MimeEncode( ByVal sFileData As String ) As String
           Local lBlock, lcBlocks, lByte1, lByte2, lByte3, lIndex1, lIndex2, lIndex3, lIndex4 As Long
           Local pInput, pOutput, pTable As Byte Ptr
           Local sBase64, sResult, Pad As String
        
           sBase64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"   'Base64 table
           Pad = String$(2 - (Len(sFileData) - 1) Mod 3, "=")          'Calculate padding on Base64 stream
        
           lcBlocks = (Len(sFileData) + 2) \ 3                         'Round up the length of the input
           If lcBlocks * 3 > Len(sFileData) Then                       'data to a multiple of three
             sFileData = LSet$(sFileData, lcBlocks * 3 Using $Nul)
           End If
        
           sResult = Space$(lcBlocks * 4)                              'Allocate space for output string
        
           pInput  = StrPtr(sFileData)                                 'Set up pointers so we can treat
           pOutput = StrPtr(sResult)                                   'the data as byte streams
           pTable  = StrPtr(sBase64)
        
           For lBlock = 1 To lcBlocks                                  'Loop through the input buffer
             lByte1 = @pInput : Incr pInput                            'Get the next three binary data-
             lByte2 = @pInput : Incr pInput                            'bytes to process
             lByte3 = @pInput : Incr pInput
        
             lIndex1 = lByte1 \ 4                                      'Translate 3 databytes to 4 Base64
             lIndex2 = (lByte1 And 3) * 16 + lByte2 \ 16               'table indices
             lIndex3 = (lByte2 And 15) * 4 + lByte3 \ 64
             lIndex4 = lByte3 And 63
        
             @pOutput = @pTable[lIndex1] : Incr pOutput                'Use Base64 table to encode the
             @pOutput = @pTable[lIndex2] : Incr pOutput                'output string
             @pOutput = @pTable[lIndex3] : Incr pOutput
             @pOutput = @pTable[lIndex4] : Incr pOutput
           Next
           RSet Abs sResult = Pad                                        'Merge in the padding bytes
           Method = sResult
       End Method
       
    
       '//
       '//
       Class Method GetMailDateTime() As String
           ' Retrieve the current time and date to put in E-mail header format
           Local szFormat   As Asciiz * 40
           Local szTemp     As Asciiz * 40
           Local sResult    As String
           Local t          As SYSTEMTIME
           Local sUCTOffset As String
           Local tzi        As TIME_ZONE_INFORMATION
       
           GetLocalTime t
       
           szFormat = "ddd',' dd MMM yyyy"
           GetDateFormat %LOCALE_USER_DEFAULT, 0, t, szFormat, szTemp, SizeOf(szTemp)
           sResult = szTemp
       
           szFormat = "HH':'mm':'ss"
           GetTimeFormat %LOCALE_USER_DEFAULT, 0, t, szFormat, szTemp, SizeOf(szTemp)
       
           Select Case GetTimeZoneInformation(tzi)
           Case %TIME_ZONE_ID_DAYLIGHT
               sUCTOffset = IIf$((tzi.bias + tzi.DaylightBias) <= 0, "+", "-") _
                          + Format$(Abs(tzi.bias + tzi.DaylightBias) \ 60, "00") _
                          + Format$(Abs(tzi.bias + tzi.DaylightBias) Mod 60, "00")
           Case %TIME_ZONE_ID_STANDARD
               sUCTOffset = IIf$((tzi.bias + tzi.StandardBias) <= 0, "+", "-") _
                          + Format$(Abs(tzi.bias + tzi.StandardBias) \ 60, "00") _
                          + Format$(Abs(tzi.bias + tzi.StandardBias) Mod 60, "00")
           Case Else
               sUCTOffset = "-0000"
           End Select
       
           Method = sResult & " " & szTemp & " " & sUCTOffset
       
       End Method
    
       '------------------------------------------------------------
       '  End of Private Class methods
       '------------------------------------------------------------
    
    
       '------------------------------------------------------------
       '  Public Interface
       '------------------------------------------------------------
    
       '//
       '//
       Interface EMailInterface: Inherit IUnknown     
    
          Property Get SMTPServer() As String
             Property = m_Server
          End Property
          Property Set SMTPServer( ByVal sServerName As String )
             m_Server = RTrim$(sServername)
          End Property
          
          Property Get SendFrom() As String
             Property = m_From
          End Property
          Property Set SendFrom( ByVal sRecipientFrom As String )
             m_From = RTrim$(sRecipientFrom)
          End Property
          
          Property Get SendTo() As String
             Property = m_TO
          End Property
          Property Set SendTo( ByVal sRecipientTo As String )
             m_TO = RTrim$(sRecipientTo)
          End Property
    
          Property Get CC() As String
             Property = m_CC
          End Property
          Property Set CC( ByVal sRecipientCC As String )
             m_CC = RTrim$(sRecipientCC)
          End Property
    
          Property Get BCC() As String
             Property = m_BCC
          End Property
          Property Set BCC( ByVal sRecipientBCC As String )
             m_BCC = RTrim$(sRecipientBCC)
          End Property
    
          Property Get ReplyTo() As String
             Property = m_ReplyTo
          End Property
          Property Set ReplyTo( ByVal sReplyTo As String )
             m_ReplyTo = RTrim$(sReplyTo)
          End Property
    
          Property Get Subject() As String
             Property = m_Subject
          End Property
          Property Set Subject( ByVal sSubject As String )
             m_Subject = sSubject
          End Property
    
          Property Get PlainMessage() As String
             Property = m_PlainMessage
          End Property
          Property Set PlainMessage( ByVal sPlainMessage As String )
             m_PlainMessage = sPlainMessage
          End Property
    
          Property Get HTMLMessage() As String
             Property = m_HTMLMessage
          End Property
          Property Set HTMLMessage( ByVal sHTMLMessage As String )
             m_HTMLMessage = sHTMLMessage
          End Property
    
          Property Get Response() As String
             Property = m_Response
          End Property
    
          Property Get EnableAuth() As Long
             Property = m_EnableAuth
          End Property
          Property Set EnableAuth( ByVal nEnableAuth As Long )
             m_EnableAuth = nEnableAuth
          End Property
    
          Property Get AuthType() As String
             Property = m_AuthType
          End Property
          Property Set AuthType( ByVal sAuthType As String )
             m_AuthType = RTrim$(sAuthType)
          End Property
    
          Property Get AuthUserName() As String
             Property = m_AuthUserName
          End Property
          Property Set AuthUserName( ByVal sAuthUserName As String )
             m_AuthUserName = RTrim$(sAuthUserName)
          End Property
    
          Property Get AuthPassword() As String
             Property = m_AuthPassword
          End Property
          Property Set AuthPassword( ByVal sAuthPassword As String )
             m_AuthPassword = RTrim$(sAuthPassword)
          End Property
    
          Property Get MessageStyle() As String
             Property = m_Style
          End Property
          Property Set MessageStyle( ByVal sMessageStyle As String )
             m_Style = UCase$(RTrim$(sMessageStyle))
          End Property
    
          Property Get ServerTimeout() As Long
             Property = m_Timeout
          End Property
          Property Set ServerTimeout( ByVal nServerTimeout As Long )
             m_Timeout = nServerTimeout
          End Property
    
          Property Get Attachments() As String
             Property = m_Attachments
          End Property
          Property Set Attachments( ByVal sAttachments As String )
             m_Attachments = RTrim$(sAttachments)
          End Property
    
          Property Get LocalHost() As String
             Property = m_LocalHost
          End Property
          Property Set LocalHost( ByVal sLocalHost As String )
             m_LocalHost = RTrim$(sLocalHost)
          End Property
    
          Property Get CharSet() As String
             Property = m_CharSet
          End Property
          Property Set CharSet( ByVal sCharSet As String )
             m_CharSet = RTrim$(sCharSet)
          End Property
    
          
          '//
          '//
          Method SendMail() As Long
             Local hTCP           As Long
             Local y              As Long
             Local f              As Long
             Local z              As Long
             Local NumLines       As Long
             Local errcode        As Long
             Local sTmp           As String
             Local sBuffer        As String  
             Local sBoundary      As String
             Local sAllRecipients As String
             Local NumAttachments As Long
             
             
             ' Make a unique file data boundary marker
             sBoundary = "Boundary." & Remove$(GuidTxt$(Guid$), Any "{-}") 
    
             ' Connect to E-mail server (mailhost)
             hTCP = FreeFile
             Tcp Open "smtp" At m_Server As hTCP TimeOut m_Timeout
             m_Response = "Cannot connect to E-mail server: " & m_Server
             If Err Then GoTo SendError
        
             Tcp Line hTCP, m_Response
             If Left$(m_Response, 3) <> "220" Then GoTo SendError
        
             ' Get the local host name
             If RTrim$(m_LocalHost) = "" Then m_LocalHost = "localhost"
        
             ' Greet the mailhost
             Tcp Print hTCP, "HELO " & m_LocalHost
             Tcp Line hTCP, m_Response
             If Left$(m_Response, 3) <> "250" Then GoTo SendError
        
             ' Send authentication if required
             If m_EnableAuth Then
                 
                 Do While Not Eof(hTCP)
                     Tcp Line hTCP, sBuffer
                     errcode = Val(Left$(sBuffer, 3))
                 Loop
                 Tcp Print hTCP, m_AuthType
                 
                 Do While Not Eof(hTCP)
                     Tcp Line hTCP, sBuffer
                     errcode = Val(Left$(sBuffer, 3))
                 Loop
                 
                 If errcode = 334 Then
                     sTmp = Me.MimeEncode(m_AuthUsername)     ' UserId (might be the same as the POP3 UserId)
                     Tcp Print hTCP, sTmp
                     Do While Not Eof(hTCP)
                         Tcp Line hTCP, sBuffer
                         errcode = Val(Left$(sBuffer, 3))
                     Loop
                     If errcode = 334 Then
                         sTmp = Me.MimeEncode(m_AuthPassword) ' Password (might be the same as the POP3 password)
                         Tcp Print hTCP, sTmp
                         Do While Not Eof(hTCP)
                             Tcp Line hTCP, sBuffer
                             errcode = Val(Left$(sBuffer, 3))
                         Loop
                     End If
                 End If
          
             End If
             
             
             ' Tell the mailhost who we are
             Tcp Print hTCP, "MAIL FROM:<" & m_From & ">"
             Tcp Line hTCP, m_Response
             If Left$(m_Response, 3) <> "250" Then GoTo SendError
            
             ' Tell the mailhost who the message is for 
             ' There could be multiple recipients so iterate through
             ' the semicolon or comma deliminated list. The total RCPT
             ' list is the combination of the TO, CC, BCC lists.
             sAllRecipients = m_TO & ";" & m_CC & ";" & m_BCC
             
             NumLines = ParseCount(sAllRecipients, Any ";,")
             ReDim sArray(1 To NumLines) As String
             Parse sAllRecipients, sArray(), Any ";,"
             
             For y = 1 To NumLines
                sTmp = RTrim$(sArray(y))
                If Len(sTmp) Then
                   Tcp Print hTCP, "RCPT TO:<" & sTmp & ">"
                   Tcp Line hTCP, m_Response
                   If Left$(m_Response, 3) <> "250" Then GoTo SendError
                End If
             Next
             
             
             ' Send the message
             Tcp Print hTCP, "DATA"
             Tcp Line hTCP, m_Response
             If Left$(m_Response, 3) <> "354" Then GoTo SendError
        
             ' The E-mail header
             Tcp Print hTCP, "Date: " & Me.GetMailDateTime
             Tcp Print hTCP, "From: " & m_From
             
             Tcp Print hTCP, "To: " & m_To
    
             If Len(m_ReplyTo) Then
                Tcp Print hTCP, "Reply-To: " & m_ReplyTo
             End If
    
             If Len(m_CC) Then
                Tcp Print hTCP, "Cc: "  & m_CC
             End If
             
             ' Obviously we won't output the BCC list to the email
    
             
             Tcp Print hTCP, "Subject: " & m_Subject
    
             Tcp Print hTCP, "X-Mailer: pMailer Mail"
             Tcp Print hTCP, "MIME-Version: 1.0"
    
             Tcp Print hTCP, "Content-Type: multipart/mixed; boundary=" & $Dq & sBoundary & $Dq
             Tcp Print hTCP, ""
             
             
             ' Create a main E-mail body section for the Plain message. 
             ' Break the message down into lines
             
             If (m_Style = "PLAIN") Or (m_Style = "BOTH") Then
                Tcp Print hTCP, "--" & sBoundary
                Tcp Print hTCP, "Content-Type: text/plain; charset=" & $Dq & m_CharSet & $Dq
                Tcp Print hTCP, "Content-Transfer-Encoding: 7bit"
                Tcp Print hTCP, ""
    
               ' Any crlf pairs or plain lf's will be replaced with cr's for easy parsing
                Replace $CrLf With $Cr In m_PlainMessage
                Replace $Lf   With $Cr In m_PlainMessage
                
                NumLines = ParseCount( m_PlainMessage, $Cr )
                ReDim sArray(1 To NumLines) As String
                Parse m_PlainMessage, sArray(), $Cr
               
                For y = 1 To NumLines
                   Tcp Print hTCP, sArray(y)
                Next
             End If
             
             If (m_Style = "HTML") Or (m_Style = "BOTH") Then
                Tcp Print hTCP, "--" & sBoundary
                Tcp Print hTCP, "Content-Type: text/html; charset=" & $Dq & m_CharSet & $Dq
                Tcp Print hTCP, "Content-Transfer-Encoding: 7bit"
                Tcp Print hTCP, ""
    
               ' Any crlf pairs or plain lf's will be replaced with cr's for easy parsing
                Replace $CrLf With $Cr In m_HTMLMessage
                Replace $Lf   With $Cr In m_HTMLMessage
                
                NumLines = ParseCount( m_HTMLMessage, $Cr )
                ReDim sArray(1 To NumLines) As String
                Parse m_HTMLMessage, sArray(), $Cr
               
                For y = 1 To NumLines
                   Tcp Print hTCP, sArray(y)
                Next
             End If
    
    
             ' Create the attachment body section
             If Len(m_Attachments) > 0 Then
                NumAttachments = ParseCount( m_Attachments, ";," )
                ReDim sArray(1 To NumAttachments) As String
                Parse m_Attachments, sArray(), ";,"
                
                For y = 1 To NumAttachments
                   If Dir$(sArray(y)) = "" Then Iterate For
                   
                   f = FreeFile
                   Open sArray(y) For Binary As #f
                   Get$ #f, Lof(f), sBuffer
                   Close #f
                   
                   ' Encode the file
                   sBuffer = Me.MimeEncode( sBuffer )
                   
                   Tcp Print hTCP, "--" & sBoundary
                   Tcp Print hTCP, "Content-Type: application/octet-stream; name=" & $Dq & PathName$(NameX, sArray(y)) & $Dq
                   Tcp Print hTCP, "Content-Transfer-Encoding: base64"
                   Tcp Print hTCP, ""
           
                   ' Write the encoded data in lines of 76 characters.  Add an equality
                   ' character if the last line is less than 76 bytes long
                   For z = 1 To Len(sBuffer) Step 76
                      If Len(sBuffer) - z >= 76 Then
                         Tcp Print hTCP, Mid$(sBuffer, z, 76)
                      Else
                         Tcp Print hTCP, Mid$(sBuffer, z) & "="
                      End If
                   Next
    
                Next
             End If
    
             ' Send the terminating boundary marker
             Tcp Print hTCP, "--" & sBoundary & "--"
        
             ' Now finish the E-mail off as we're done sending the message
             Tcp Print hTCP, "."
             Tcp Line hTCP, m_Response
             If Left$(m_Response, 3) <> "250" Then GoTo SendError
        
             ' Say goodbye
             Tcp Print hTCP, "QUIT"
             Tcp Line hTCP, m_Response
             If Left$(m_Response, 3) <> "221" Then GoTo SendError
        
             Tcp Close hTCP
             
             Exit Method
             
    SendError:
            Method = %TRUE    ' error occurred
            
          End Method
          
       End Interface
    
       '------------------------------------------------------------
       '  End of Public Interface
       '------------------------------------------------------------
    
    End Class
    Paul Squires
    FireFly Visual Designer (for PowerBASIC Windows 10+)
    Version 3 now available.
    http://www.planetsquires.com

  • #2
    What if the SMTP Server doesn't use default ports?

    More and More servers and not users the default SMTP ports to help prevent pirates from spamming from them. You need one more property, smtp server port.
    Thanks,

    Doug Gamble
    [email protected]

    Comment


    • #3
      I like Pauls Programming style, because its so clear and still very optimized.
      Besides that it looks to me like a "SendMail Class", not an E-Mail Class.
      Because e-mail needs to be received too. While this one looks like it can send mails only.

      Comment


      • #4
        > More and More servers and not users the default SMTP ports

        I don't understand.
        "Not my circus, not my monkeys."

        Comment


        • #5
          Eric,

          I think that should be "are not using", meaning that it is becoming common to use the Message Submission Port 587 for client submission to an SMTP relay server rather than Port 25.

          We tell all of our hosted mail customers to use that port so that they can use any internet connection without worrying about their connection provider blocking port 25.

          GMail also uses it.

          Comment


          • #6
            Paul,

            I have been experimenting with your eMail class. It work great with PBCC 5 but in PB CC 6 I'm getting the following

            Missing declaration: GETDATEFORMAT
            Line 94: GetDateFormat %LOCALE_USER_DEFAULT, 0, t, szFormat, szTemp, SIZEOF(szTemp)

            This is within the SendeMail.inc.

            Do I need to include some other module?

            Ken

            Comment


            • #7
              Someone asked for alternative port handling...
              Hope you don't mind Paul , I've added it below, it worked for me. (just a few small additions to your well structured code)

              Code:
              #compile exe
              
              #include "win32api.inc"
              
              #include "clsEmail.inc"
              
              
              function pbmain() as long
              
                 ' NOTES:
                 ' The 'SendTo', 'CC', 'BCC' fields can be a one address or a
                 ' semicolon(;) or comma(,) deliminated list of multiple addresses.
                 ' SMTP only allows 100 recipients max at a time (per rfc821), therefore
                 ' for large mailings you should break it into multiple emails.
              
                 ' Multiple attachments can be sent by simply separating the file
                 ' names with a semicolon or comma.
              
                 ' You can use 'Plain' text emails or 'HTML' emails, or 'Both'.
                 ' When sending "Both", the email client application will use whichever
                 ' one it can render based on the user's settings.
              
                 ' Default values for the following that are already set by the
                 ' class (constructor). Change them here if you want a different value.
                 ' e.g.
                 ' cMail.ServerTimeOut = 60000  ' milliseconds  ' default is 60000
                 ' cMail.LocalHost     = "MySuperComputer"      ' default is localhost
                 ' cMail.CharSet       = "us-ascii"             ' default is iso-8859-1
                 ' cMail.MessageStyle  = "both"                 ' default is Plain
              
              
                 dim cMail as EMailInterface
                 cMail = class "clsEmail"
              
                 cMail.SMTPServer   = "mysmtpxxxx.com"
                 cMail.SMTPPort     = 25   ' 587 is commonly used as an alternative
                 cMail.SendFrom     = "[email protected]"
                 cMail.SendTo       = "[email protected]"
                 cMail.CC           = "[email protected]"
                 cMail.BCC          = "[email protected]"
                 cMail.ReplyTo      = "[email protected]"
                 cMail.Subject      = "test subject"
              
                 cMail.EnableAuth   = %TRUE
                 cMail.AuthType     = "AUTH LOGIN"
                 cMail.AuthUsername = "[email protected]"
                 cMail.AuthPassword = "mypassword"
              
                 cMail.MessageStyle = "both"
                 cMail.Attachments  = ""       ' eg. "myfilename.zip"
              
                 ' Plain text email
                 cMail.PlainMessage = "This is my test message." & $crlf & _
                                      "Line #2" & $crlf & _
                                      "Last line."
              
                 ' HTML text email
                 cMail.HTMLMessage  = "<html>" & $crlf  & _
                                      "<body>" & $crlf  & _
                                      "<center><b>This Is a test!</b></center>" & $crlf & _
                                      "</body>" & $crlf & _
                                      "</html>" & $crlf
              
                 ' Send the actual email and deal with any error/message response.
                 if cMail.SendMail then
                    msgbox "Error sending E-mail! " & cMail.Response
                 else
                    msgbox "Email(s) sent okay."
                 end if
              
              end function
              clsEmail.inc
              Code:
              class clsEmail
                 instance m_Server       as string
                 instance m_SMTPPort     as long    ' RBoyd: added for port configuration
                 instance m_From         as string
                 instance m_ReplyTo      as string
                 instance m_TO           as string
                 instance m_CC           as string
                 instance m_BCC          as string
                 instance m_Subject      as string
                 instance m_PlainMessage as string
                 instance m_HTMLMessage  as string
                 instance m_Response     as string
                 instance m_EnableAuth   as long
                 instance m_AuthType     as string
                 instance m_AuthUsername as string
                 instance m_AuthPassword as string
                 instance m_Style        as string
                 instance m_Timeout      as long
                 instance m_Attachments  as string
                 instance m_LocalHost    as string
                 instance m_CharSet      as string
              
              
                 '------------------------------------------------------------
                 '  Private Class methods
                 '------------------------------------------------------------
              
                 '//
                 '//
                 class method create()   ' Constructor
                    ' Initialize default properties
                    m_Timeout     = 60000   '(60 seconds)
                    m_CharSet     = "iso-8859-1"
                    m_Style       = "plain"
                    host name to m_LocalHost
                 end method
              
              
                 '//
                 '//
                 class method MimeEncode( byval sFileData as string ) as string
                     local lBlock, lcBlocks, lByte1, lByte2, lByte3, lIndex1, lIndex2, lIndex3, lIndex4 as long
                     local pInput, pOutput, pTable as byte ptr
                     local sBase64, sResult, Pad as string
              
                     sBase64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"   'Base64 table
                     Pad = string$(2 - (len(sFileData) - 1) mod 3, "=")          'Calculate padding on Base64 stream
              
                     lcBlocks = (len(sFileData) + 2) \ 3                         'Round up the length of the input
                     if lcBlocks * 3 > len(sFileData) then                       'data to a multiple of three
                       sFileData = lset$(sFileData, lcBlocks * 3 using $nul)
                     end if
              
                     sResult = space$(lcBlocks * 4)                              'Allocate space for output string
              
                     pInput  = strptr(sFileData)                                 'Set up pointers so we can treat
                     pOutput = strptr(sResult)                                   'the data as byte streams
                     pTable  = strptr(sBase64)
              
                     for lBlock = 1 to lcBlocks                                  'Loop through the input buffer
                       lByte1 = @pInput : incr pInput                            'Get the next three binary data-
                       lByte2 = @pInput : incr pInput                            'bytes to process
                       lByte3 = @pInput : incr pInput
              
                       lIndex1 = lByte1 \ 4                                      'Translate 3 databytes to 4 Base64
                       lIndex2 = (lByte1 and 3) * 16 + lByte2 \ 16               'table indices
                       lIndex3 = (lByte2 and 15) * 4 + lByte3 \ 64
                       lIndex4 = lByte3 and 63
              
                       @pOutput = @pTable[lIndex1] : incr pOutput                'Use Base64 table to encode the
                       @pOutput = @pTable[lIndex2] : incr pOutput                'output string
                       @pOutput = @pTable[lIndex3] : incr pOutput
                       @pOutput = @pTable[lIndex4] : incr pOutput
                     next
                     rset abs sResult = Pad                                        'Merge in the padding bytes
                     method = sResult
                 end method
              
              
                 '//
                 '//
                 class method GetMailDateTime() as string
                     ' Retrieve the current time and date to put in E-mail header format
                     local szFormat   as asciiz * 40
                     local szTemp     as asciiz * 40
                     local sResult    as string
                     local t          as SYSTEMTIME
                     local sUCTOffset as string
                     local tzi        as TIME_ZONE_INFORMATION
              
                     GetLocalTime t
              
                     szFormat = "ddd',' dd MMM yyyy"
                     GetDateFormat %LOCALE_USER_DEFAULT, 0, t, szFormat, szTemp, sizeof(szTemp)
                     sResult = szTemp
              
                     szFormat = "HH':'mm':'ss"
                     GetTimeFormat %LOCALE_USER_DEFAULT, 0, t, szFormat, szTemp, sizeof(szTemp)
              
                     select case GetTimeZoneInformation(tzi)
                     case %TIME_ZONE_ID_DAYLIGHT
                         sUCTOffset = iif$((tzi.bias + tzi.DaylightBias) <= 0, "+", "-") _
                                    + format$(abs(tzi.bias + tzi.DaylightBias) \ 60, "00") _
                                    + format$(abs(tzi.bias + tzi.DaylightBias) mod 60, "00")
                     case %TIME_ZONE_ID_STANDARD
                         sUCTOffset = iif$((tzi.bias + tzi.StandardBias) <= 0, "+", "-") _
                                    + format$(abs(tzi.bias + tzi.StandardBias) \ 60, "00") _
                                    + format$(abs(tzi.bias + tzi.StandardBias) mod 60, "00")
                     case else
                         sUCTOffset = "-0000"
                     end select
              
                     method = sResult & " " & szTemp & " " & sUCTOffset
              
                 end method
              
                 '------------------------------------------------------------
                 '  End of Private Class methods
                 '------------------------------------------------------------
              
              
                 '------------------------------------------------------------
                 '  Public Interface
                 '------------------------------------------------------------
              
                 '//
                 '//
                 interface EMailInterface: inherit iunknown
              
                    property get SMTPServer() as string
                       property = m_Server
                    end property
                    property set SMTPServer( byval sServerName as string )
                       m_Server = rtrim$(sServername)
                    end property
              
                    ' RBoyd: Added this get/set block for port configuration
                    property get SMTPPort() as long
                       property = m_SMTPPort
                    end property
                    property set SMTPPort( byval nSMTPPort as long )
                       m_SMTPPort = nSMTPPort
                    end property
              
                    property get SendFrom() as string
                       property = m_From
                    end property
                    property set SendFrom( byval sRecipientFrom as string )
                       m_From = rtrim$(sRecipientFrom)
                    end property
              
                    property get SendTo() as string
                       property = m_TO
                    end property
                    property set SendTo( byval sRecipientTo as string )
                       m_TO = rtrim$(sRecipientTo)
                    end property
              
                    property get CC() as string
                       property = m_CC
                    end property
                    property set CC( byval sRecipientCC as string )
                       m_CC = rtrim$(sRecipientCC)
                    end property
              
                    property get BCC() as string
                       property = m_BCC
                    end property
                    property set BCC( byval sRecipientBCC as string )
                       m_BCC = rtrim$(sRecipientBCC)
                    end property
              
                    property get ReplyTo() as string
                       property = m_ReplyTo
                    end property
                    property set ReplyTo( byval sReplyTo as string )
                       m_ReplyTo = rtrim$(sReplyTo)
                    end property
              
                    property get Subject() as string
                       property = m_Subject
                    end property
                    property set Subject( byval sSubject as string )
                       m_Subject = sSubject
                    end property
              
                    property get PlainMessage() as string
                       property = m_PlainMessage
                    end property
                    property set PlainMessage( byval sPlainMessage as string )
                       m_PlainMessage = sPlainMessage
                    end property
              
                    property get HTMLMessage() as string
                       property = m_HTMLMessage
                    end property
                    property set HTMLMessage( byval sHTMLMessage as string )
                       m_HTMLMessage = sHTMLMessage
                    end property
              
                    property get Response() as string
                       property = m_Response
                    end property
              
                    property get EnableAuth() as long
                       property = m_EnableAuth
                    end property
                    property set EnableAuth( byval nEnableAuth as long )
                       m_EnableAuth = nEnableAuth
                    end property
              
                    property get AuthType() as string
                       property = m_AuthType
                    end property
                    property set AuthType( byval sAuthType as string )
                       m_AuthType = rtrim$(sAuthType)
                    end property
              
                    property get AuthUserName() as string
                       property = m_AuthUserName
                    end property
                    property set AuthUserName( byval sAuthUserName as string )
                       m_AuthUserName = rtrim$(sAuthUserName)
                    end property
              
                    property get AuthPassword() as string
                       property = m_AuthPassword
                    end property
                    property set AuthPassword( byval sAuthPassword as string )
                       m_AuthPassword = rtrim$(sAuthPassword)
                    end property
              
                    property get MessageStyle() as string
                       property = m_Style
                    end property
                    property set MessageStyle( byval sMessageStyle as string )
                       m_Style = ucase$(rtrim$(sMessageStyle))
                    end property
              
                    property get ServerTimeout() as long
                       property = m_Timeout
                    end property
                    property set ServerTimeout( byval nServerTimeout as long )
                       m_Timeout = nServerTimeout
                    end property
              
                    property get Attachments() as string
                       property = m_Attachments
                    end property
                    property set Attachments( byval sAttachments as string )
                       m_Attachments = rtrim$(sAttachments)
                    end property
              
                    property get LocalHost() as string
                       property = m_LocalHost
                    end property
                    property set LocalHost( byval sLocalHost as string )
                       m_LocalHost = rtrim$(sLocalHost)
                    end property
              
                    property get CharSet() as string
                       property = m_CharSet
                    end property
                    property set CharSet( byval sCharSet as string )
                       m_CharSet = rtrim$(sCharSet)
                    end property
              
              
                    '//
                    '//
                    method SendMail() as long
                       local hTCP           as long
                       local y              as long
                       local f              as long
                       local z              as long
                       local NumLines       as long
                       local errcode        as long
                       local sTmp           as string
                       local sBuffer        as string
                       local sBoundary      as string
                       local sAllRecipients as string
                       local NumAttachments as long
              
              
                       ' Make a unique file data boundary marker
                       sBoundary = "Boundary." & remove$(guidtxt$(guid$), any "{-}")
              
                       ' Connect to E-mail server (mailhost)
                       hTCP = freefile
                       ' RBoyd: Configurable port change
              '         Tcp Open "smtp" At m_Server As hTCP TimeOut m_Timeout
                       tcp open port m_SMTPPort at m_Server as hTCP timeout m_Timeout
              
                       m_Response = "Cannot connect to E-mail server: " & m_Server
                       if err then goto SendError
              
                       tcp line hTCP, m_Response
                       if left$(m_Response, 3) <> "220" then goto SendError
              
                       ' Get the local host name
                       if rtrim$(m_LocalHost) = "" then m_LocalHost = "localhost"
              
                       ' Greet the mailhost
                       tcp print hTCP, "HELO " & m_LocalHost
                       tcp line hTCP, m_Response
                       if left$(m_Response, 3) <> "250" then goto SendError
              
                       ' Send authentication if required
                       if m_EnableAuth then
              
                           do while not eof(hTCP)
                               tcp line hTCP, sBuffer
                               errcode = val(left$(sBuffer, 3))
                           loop
                           tcp print hTCP, m_AuthType
              
                           do while not eof(hTCP)
                               tcp line hTCP, sBuffer
                               errcode = val(left$(sBuffer, 3))
                           loop
              
                           if errcode = 334 then
                               sTmp = Me.MimeEncode(m_AuthUsername)     ' UserId (might be the same as the POP3 UserId)
                               tcp print hTCP, sTmp
                               do while not eof(hTCP)
                                   tcp line hTCP, sBuffer
                                   errcode = val(left$(sBuffer, 3))
                               loop
                               if errcode = 334 then
                                   sTmp = Me.MimeEncode(m_AuthPassword) ' Password (might be the same as the POP3 password)
                                   tcp print hTCP, sTmp
                                   do while not eof(hTCP)
                                       tcp line hTCP, sBuffer
                                       errcode = val(left$(sBuffer, 3))
                                   loop
                               end if
                           end if
              
                       end if
              
              
                       ' Tell the mailhost who we are
                       tcp print hTCP, "MAIL FROM:<" & m_From & ">"
                       tcp line hTCP, m_Response
                       if left$(m_Response, 3) <> "250" then goto SendError
              
                       ' Tell the mailhost who the message is for
                       ' There could be multiple recipients so iterate through
                       ' the semicolon or comma deliminated list. The total RCPT
                       ' list is the combination of the TO, CC, BCC lists.
                       sAllRecipients = m_TO & ";" & m_CC & ";" & m_BCC
              
                       NumLines = parsecount(sAllRecipients, any ";,")
                       redim sArray(1 to NumLines) as string
                       parse sAllRecipients, sArray(), any ";,"
              
                       for y = 1 to NumLines
                          sTmp = rtrim$(sArray(y))
                          if len(sTmp) then
                             tcp print hTCP, "RCPT TO:<" & sTmp & ">"
                             tcp line hTCP, m_Response
                             if left$(m_Response, 3) <> "250" then goto SendError
                          end if
                       next
              
              
                       ' Send the message
                       tcp print hTCP, "DATA"
                       tcp line hTCP, m_Response
                       if left$(m_Response, 3) <> "354" then goto SendError
              
                       ' The E-mail header
                       tcp print hTCP, "Date: " & Me.GetMailDateTime
                       tcp print hTCP, "From: " & m_From
              
                       tcp print hTCP, "To: " & m_To
              
                       if len(m_ReplyTo) then
                          tcp print hTCP, "Reply-To: " & m_ReplyTo
                       end if
              
                       if len(m_CC) then
                          tcp print hTCP, "Cc: "  & m_CC
                       end if
              
                       ' Obviously we won't output the BCC list to the email
              
              
                       tcp print hTCP, "Subject: " & m_Subject
              
                       tcp print hTCP, "X-Mailer: pMailer Mail"
                       tcp print hTCP, "MIME-Version: 1.0"
              
                       tcp print hTCP, "Content-Type: multipart/mixed; boundary=" & $dq & sBoundary & $dq
                       tcp print hTCP, ""
              
              
                       ' Create a main E-mail body section for the Plain message.
                       ' Break the message down into lines
              
                       if (m_Style = "PLAIN") or (m_Style = "BOTH") then
                          tcp print hTCP, "--" & sBoundary
                          tcp print hTCP, "Content-Type: text/plain; charset=" & $dq & m_CharSet & $dq
                          tcp print hTCP, "Content-Transfer-Encoding: 7bit"
                          tcp print hTCP, ""
              
                         ' Any crlf pairs or plain lf's will be replaced with cr's for easy parsing
                          replace $crlf with $cr in m_PlainMessage
                          replace $lf   with $cr in m_PlainMessage
              
                          NumLines = parsecount( m_PlainMessage, $cr )
                          redim sArray(1 to NumLines) as string
                          parse m_PlainMessage, sArray(), $cr
              
                          for y = 1 to NumLines
                             tcp print hTCP, sArray(y)
                          next
                       end if
              
                       if (m_Style = "HTML") or (m_Style = "BOTH") then
                          tcp print hTCP, "--" & sBoundary
                          tcp print hTCP, "Content-Type: text/html; charset=" & $dq & m_CharSet & $dq
                          tcp print hTCP, "Content-Transfer-Encoding: 7bit"
                          tcp print hTCP, ""
              
                         ' Any crlf pairs or plain lf's will be replaced with cr's for easy parsing
                          replace $crlf with $cr in m_HTMLMessage
                          replace $lf   with $cr in m_HTMLMessage
              
                          NumLines = parsecount( m_HTMLMessage, $cr )
                          redim sArray(1 to NumLines) as string
                          parse m_HTMLMessage, sArray(), $cr
              
                          for y = 1 to NumLines
                             tcp print hTCP, sArray(y)
                          next
                       end if
              
              
                       ' Create the attachment body section
                       if len(m_Attachments) > 0 then
                          NumAttachments = parsecount( m_Attachments, ";," )
                          redim sArray(1 to NumAttachments) as string
                          parse m_Attachments, sArray(), ";,"
              
                          for y = 1 to NumAttachments
                             if dir$(sArray(y)) = "" then iterate for
              
                             f = freefile
                             open sArray(y) for binary as #f
                             get$ #f, lof(f), sBuffer
                             close #f
              
                             ' Encode the file
                             sBuffer = Me.MimeEncode( sBuffer )
              
                             tcp print hTCP, "--" & sBoundary
                             tcp print hTCP, "Content-Type: application/octet-stream; name=" & $dq & pathname$(namex, sArray(y)) & $dq
                             tcp print hTCP, "Content-Transfer-Encoding: base64"
                             tcp print hTCP, ""
              
                             ' Write the encoded data in lines of 76 characters.  Add an equality
                             ' character if the last line is less than 76 bytes long
                             for z = 1 to len(sBuffer) step 76
                                if len(sBuffer) - z >= 76 then
                                   tcp print hTCP, mid$(sBuffer, z, 76)
                                else
                                   tcp print hTCP, mid$(sBuffer, z) & "="
                                end if
                             next
              
                          next
                       end if
              
                       ' Send the terminating boundary marker
                       tcp print hTCP, "--" & sBoundary & "--"
              
                       ' Now finish the E-mail off as we're done sending the message
                       tcp print hTCP, "."
                       tcp line hTCP, m_Response
                       if left$(m_Response, 3) <> "250" then goto SendError
              
                       ' Say goodbye
                       tcp print hTCP, "QUIT"
                       tcp line hTCP, m_Response
                       if left$(m_Response, 3) <> "221" then goto SendError
              
                       tcp close hTCP
              
                       exit method
              
              SendError:
                      method = %TRUE    ' error occurred
              
                    end method
              
                 end interface
              
                 '------------------------------------------------------------
                 '  End of Public Interface
                 '------------------------------------------------------------
              
              end class
              Last edited by Ross Boyd; 13 Jun 2012, 02:16 AM. Reason: Created thread in discussion forum

              Comment


              • #8
                Spent a little time this evening and added following includes and the class is now working in PBCC 6.

                #INCLUDE "C:\PBCC60\WinAPI\WinNLS.inc"
                #INCLUDE "C:\PBCC60\WinAPI\WinNT.inc"
                #INCLUDE "C:\PBCC60\WinAPI\WinBase.inc"
                Last edited by Ken Pugsley; 12 Jun 2012, 10:16 PM.

                Comment


                • #9
                  Originally posted by Ross Boyd View Post
                  Someone asked for alternative port handling...
                  This is absolutely great, Paul and Ross. Your code is really neat, and the alternate SMTP_AUTH indeed is useful. My provider suggests to use only port 587, and to completely block port 25 SMTP completely.

                  Just one small caveat: As Roger Weissberg has pointed out here, the SMTP date format (RFC5322 Para 3.3) needs US english format. As long as GetDateFormat with %LOCALE_USER_DEFAULT is called inside the US english area everthing is fine. So I have replaced %LOCALE_USER_DEFAULT by 1033, as Roger suggested, and all is fine.

                  Cheers
                  Albert
                  „Let the machine do the dirty work.“
                  The Elements of Programming Style, Brian W. Kernighan, P. J. Plauger 1978

                  Comment


                  • #10
                    Gmail

                    Is there a simple example how to send email with GMAIL.com?
                    I saw in another thread, that PB does not support SSL/TSL which is required by Gmail.
                    Any suggestion?
                    Thanks

                    Comment


                    • #11
                      Using my headers...

                      Code:
                      #COMPILE EXE
                      #DIM ALL
                      #INCLUDE ONCE "windows.inc"
                      #INCLUDE ONCE "cdosys.inc"
                      #INCLUDE ONCE "ado.inc"
                      #INCLUDE ONCE "ole2utils.inc"
                      
                      FUNCTION PBMAIN () AS LONG
                      
                         DIM iMsg AS CDO_IMessage
                         DIM iConf AS CDO_IConfiguration
                         DIM Flds AS ADOFields
                      
                         iMsg = NEWCOM "CDO.Message"
                         iConf = NEWCOM "CDO.Configuration"
                      
                         TRY
                      
                            Flds = iConf.Fields
                            DIM schema AS STRING
                            schema = "http://schemas.microsoft.com/cdo/configuration/"
                            Flds.Item(schema & "sendusing").Value = 2
                            Flds.Item(schema & "smtpserver").Value = "smtp.gmail.com"
                            Flds.Item(schema & "smtpserverport").Value = 465
                            Flds.Item(schema & "smtpauthenticate").Value = 1
                            Flds.Item(schema & "sendusername").Value = "[email protected]"
                            Flds.Item(schema & "sendpassword").Value =  "mypassword"
                            Flds.Item(schema & "smtpusessl").Value = 1
                            Flds.Update
                      
                            iMsg.To = "your first email address"
                            iMsg.From = "your 2nd email address"
                            iMsg.Subject = "Test send with gmail account"
                            iMsg.HTMLBody = "Test send with gmail account"
                            iMsg.Sender = "your name"
                            iMsg.Organization = "your name"
                            iMsg.ReplyTo = "your 2nd email address"
                            iMsg.Configuration = iConf
                            iMsg.Send
                            ? "Message sent successfully"
                         CATCH
                            ? OleGetErrorInfo(OBJRESULT)
                         END TRY
                      
                      END FUNCTION
                      Alternatively, make your own headers for CDOSys and ADO with a COM browser.
                      Forum: http://www.jose.it-berater.org/smfforum/index.php

                      Comment


                      • #12
                        José, can you post headers where CDO_IMessage and CDO_IConfiguration is defined?
                        I know, INC files are here, http://www.jose.it-berater.org/smffo...hp?board=344.0, but they are available only for registered users. Can you post them here?
                        Thanks.

                        Comment


                        • #13
                          Sorry. They aren't isolated files, but part of my Windows API headers. They have many dependencies.
                          Last edited by José Roca; 24 Mar 2013, 12:26 PM.
                          Forum: http://www.jose.it-berater.org/smfforum/index.php

                          Comment


                          • #14
                            COM browser fixed CDOSYS and ADO dependencies.
                            But still is "OleGetErrorInfo" which I need to fix. Which library in COM broser is containing OleGetErrorInfo? Or, how can I get "ole2utils.inc"?
                            Thanks.

                            P.S. Email was not sent, I dont know why - Error is created by *iMsg.Send*. Value of OBJRESULT=-2147220977, HEX 8004020F. Please some suggestions.

                            P.S.2 I get this from Win32API.inc:
                            ' MessageId: EVENT_E_INVALID_EVENT_CLASS_PARTITION
                            ' MessageText:
                            ' The event class for this subscription is in an invalid partition
                            %EVENT_E_INVALID_EVENT_CLASS_PARTITION = &H8004020F
                            What is wrong?
                            Last edited by Vlado Padysak; 24 Mar 2013, 02:32 PM.

                            Comment


                            • #15
                              > But still is "OleGetErrorInfo" which I need to fix. Which library in COM broser is containing OleGetErrorInfo? Or, how can I get "ole2utils.inc"?

                              This is not an API function but a function that I wrote, available with my headers. It returns a description of the error instead of just an error code.

                              With CDO, the error code 8004020F is CDO_E_RECIPIENTS_REJECTED. It means that the server rejected one or more recipient addresses.
                              Forum: http://www.jose.it-berater.org/smfforum/index.php

                              Comment


                              • #16
                                No success.
                                Email address is written correctly in format m[email protected].
                                José, can you test if it works correctly from your computer?

                                Google writes this:
                                The Possible Causes are:
                                1) General access denied, sender access denied ? the sender of the message
                                does not have the privileges necessary to complete delivery.
                                2) You are trying to relay your mail via another SMTP server and it does
                                not permit you to relay.
                                3) The recipient might have mailbox delivery restrictions enabled. For
                                example, a recipient¡¯s mailbox delivery restriction was sent to receive
                                from a Distribution List only and non-member¡¯s email will be rejected with
                                this error

                                Thanks for patience

                                Comment


                                • #17
                                  It works in my computer. I have just changed the email addresses and password in the code posted for an explanatory text.
                                  Last edited by José Roca; 26 Aug 2017, 06:51 AM.
                                  Forum: http://www.jose.it-berater.org/smfforum/index.php

                                  Comment


                                  • #18
                                    José thanks.
                                    It works on my netbook (WinXP) but not on my desktop computer which has also WinXP but probably needs re-installation of Windows and clean-up.
                                    P.S. why do we bother with Windows if we have Linux?
                                    P.S.2 Three days celebration starts when PowerBasic will be released for Linux

                                    Comment


                                    • #19
                                      Is there a simple way how to add attachment to prepared email message?
                                      Thanks.

                                      Comment


                                      • #20
                                        iMsg.AddAttacchment = "<path of the file>".
                                        Forum: http://www.jose.it-berater.org/smfforum/index.php

                                        Comment

                                        Working...
                                        X