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
Collapse
 
  • Page of 3
  • Filter
  • Time
  • Show
Clear All
new posts
Previous 1 3 template Next
    #41
    Howdy, Paul !
    Is there a latest version which implements the various suggestions folks posted in this thread?

    If not, I'll build one from the comments.

    Comment

      #42
      Hubert,
      Did you also make a change so that SendTo could have a preceding user name, like this:

      Code:
      cMail.SendTo = "Gary Beene <[email protected]>"
      If so, would you post what you did? Thanks!

      Comment

        #43
        When it comes to parsing email addresses, there's two general formats that contain human-readable names along with the address itself:

        User Name <[email protected]>
        [email protected] (User Name)

        You may also find that the printable name is surrounded in single or double quotes, such as:

        "User Name" <[email protected]>
        '[email protected]' <[email protected]>

        If there are quotes present, you need to be careful when parsing, because something like this is permissible:

        "User Name <[email protected]>" <[email protected]>
        '[email protected] (User Name)' <[email protected]>

        Multiple addresses can be separated by a comma or semi-colon as well, so you can end up with:

        "Foo Bar; Director of Operations" <[email protected]>; "Bar Foo; Patch Panel Peon" <[email protected]>
        Mike Stefanik
        sockettools.com

        Comment

          #44
          Unicode is important! Правда
          --> Solution with ChrToUtf8$ and CHARSET = "UTF-8"

          Also:

          The types of class members (PROPERTY, METHOD) should be WSTRING.
          Otherwise, I can use the class only with PB.

          Comment

            #45
            Consolidated changes

            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 %LANG_INVARIANT, 0, t, szFormat, szTemp, SIZEOF(szTemp)   '%LANG_INVARIANT in other countries
       sResult = szTemp
        szFormat = "HH':'mm':'ss"
       GetTimeFormat %LANG_INVARIANT, 0, t, szFormat, szTemp, SIZEOF(szTemp)   'LANG_INVARIANT in other countries
        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
         REM tcp print hTCP, "MAIL FROM:<" & m_From & ">"
         y = INSTR(m_from, "<")
         IF y THEN
          TCP PRINT hTCP, "MAIL FROM:" & MID$(m_from,y)
        ELSE
          TCP PRINT hTCP, "MAIL FROM:<" & m_From & ">"
        END IF
 
        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
            REM NumAttachments = PARSECOUNT( m_Attachments, ";," )
            NumAttachments = PARSECOUNT( m_Attachments, ANY ";," ) '8/17/13
            REDIM sArray(1 TO NumAttachments) AS STRING
            REM PARSE m_Attachments, sArray(), ";,"
            PARSE m_Attachments, sArray(), ANY ";," '8/17/13
             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
 
FUNCTION ISEMAIL(BYVAL e AS STRING, MailAddr AS STRING) AS LONG
'------------------------------------------------------------
' verifies that the passed string contains at least one
' valid e-mail address and returns a fixed up version
'------------------------------------------------------------
  LOCAL Mask    AS STRING
  LOCAL p       AS LONG
  LOCAL l       AS LONG
   MailAddr = ""
  IF LEN(e) = 0 THEN
    FUNCTION = 0
    EXIT FUNCTION
  END IF
   Mask = "([a-z0-9._-]+)(@[a-z0-9._-]+)(\.[a-z]+)"
  REGEXPR Mask IN e TO p,l
   IF l > 0 THEN MailAddr = "<" + MID$(e,p,l) + ">"
   FUNCTION = (l > 0)
 END FUNCTION

            Comment

              #46
              TCP open "smtp" did not work after modification.

              Caught testing godaddy that uses the following and authorization
              'cMail.SMTPPort = 3535 'godaddy
              'cMail.SMTPServer = "smtpout.secureserver.net" 'godaddy

              All code consolidated with this correction in second post.
              Code:
              ' Connect to E-mail server (mailhost)
  hTCP = FREEFILE
  ' RBoyd: Configurable port change
  IF m_SMTPPort = 0 THEN '1/13/2016
    TCP OPEN "smtp" AT m_Server AS hTCP TIMEOUT m_Timeout
  ELSE
    TCP OPEN PORT m_SMTPPort AT m_Server AS hTCP TIMEOUT m_Timeout
  END IF
  m_Response = "Cannot connect to E-mail server: " & m_Server
  IF ERR THEN GOTO SendError
              Code:
              CLASS clsEmail     'clsEmail2.inc
   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 %LANG_INVARIANT, 0, t, szFormat, szTemp, SIZEOF(szTemp)   '%LANG_INVARIANT in other countries
       sResult = szTemp
        szFormat = "HH':'mm':'ss"
       GetTimeFormat %LANG_INVARIANT, 0, t, szFormat, szTemp, SIZEOF(szTemp)   'LANG_INVARIANT in other countries
        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
         IF m_SMTPPort = 0 THEN
            TCP OPEN "smtp" AT m_Server AS hTCP TIMEOUT m_Timeout
         ELSE
            TCP OPEN PORT m_SMTPPort AT m_Server AS hTCP TIMEOUT m_Timeout
         END IF
          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
         REM tcp print hTCP, "MAIL FROM:<" & m_From & ">"
         y = INSTR(m_from, "<")
         IF y THEN
          TCP PRINT hTCP, "MAIL FROM:" & MID$(m_from,y)
        ELSE
          TCP PRINT hTCP, "MAIL FROM:<" & m_From & ">"
        END IF
         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
            REM NumAttachments = PARSECOUNT( m_Attachments, ";," )
            NumAttachments = PARSECOUNT( m_Attachments, ANY ";," ) '8/17/13
            REDIM sArray(1 TO NumAttachments) AS STRING
            REM PARSE m_Attachments, sArray(), ";,"
            PARSE m_Attachments, sArray(), ANY ";," '8/17/13
             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
 FUNCTION ISEMAIL(BYVAL e AS STRING, MailAddr AS STRING) AS LONG
'------------------------------------------------------------
' verifies that the passed string contains at least one
' valid e-mail address and returns a fixed up version
'------------------------------------------------------------
  LOCAL Mask    AS STRING
  LOCAL p       AS LONG
  LOCAL l       AS LONG
   MailAddr = ""
  IF LEN(e) = 0 THEN
    FUNCTION = 0
    EXIT FUNCTION
  END IF
   Mask = "([a-z0-9._-]+)(@[a-z0-9._-]+)(\.[a-z]+)"
  REGEXPR Mask IN e TO p,l
   IF l > 0 THEN MailAddr = "<" + MID$(e,p,l) + ">"
   FUNCTION = (l > 0)
 END FUNCTION

              Comment

                #47

                I think this code is an error? If you loop you need to accumulate, right? Do While Not Eof(hTCP) Tcp Line hTCP, sBuffer errcode = Val(Left$(sBuffer, 3)) Loop

                Comment

                  #48
                  I think it is ok since TCP PRINT / TCP LINE INPUT is used not TCP RECV.
                  Looks like error 334 is being checked on each line.
                  The author or an email expert might step in.

                  It is unusual to see such an old unanswered question.

                  Code:
                            ' Send authentication if required
         IF m_EnableAuth THEN
              DO WHILE NOT EOF(hTCP)
                 TCP LINE hTCP, sBuffer
                 errcode = VAL(LEFT$(sBuffer, 3))
             LOOP
             [B]TCP PRINT hTCP, m_AuthType[/B]
              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
                  Last edited by Mike Doty; 7 Jun 2016, 09:09 AM.

                  Comment

                    #49
                    I will try to study the code you have posted me, thanks so much

                    Comment

                    Previous 1 3 template Next
                    Working...
                    X
                    😀
                    🥰
                    🤢
                    😎
                    😡
                    👍
                    👎

                    We process personal data about users of our site, through the use of cookies and other technologies, to deliver our services, and to analyze site activity. For additional details, refer to our Privacy Policy.

                    By clicking "I AGREE" below, you agree to our Privacy Policy and our personal data processing and cookie practices as described therein. You also acknowledge that this forum may be hosted outside your country and you consent to the collection, storage, and processing of your data in the country where this forum is hosted.

                    I Agree