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 (with Priority)

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

  • PBWin/PBCC send email (with Priority)

    modified from send email found in forums. Sorry, I do not recall the original author. Modified to allow the priority to be set in the email:

    Code:
    #IF 00   '  Usage
    
                W_Email_Result = Email_Send($S_Email_Host                            , _                  '  Mailhost URL
                                            S_FTERequestor_Email                     , _                  '  Sender email address
                                            S_FTERecipient_Email                     , _                  '  Receiver email address    "[email protected]"
                                            S_UrgencyPrefix + "FTE TUL Request..."   , _                  '  Message header
                                            S_Email_Message                          , _                  '  Message text     ($Cr separated)
                                            ""                                       , _                  '  Attachment files ($Cr separated)
                                            n_Email_Priority                            )                 '  email priority
                                            
    #ENDIF
    
       DECLARE FUNCTION Email_Send(BYVAL S_Host          AS STRING   , _                   '  Mailhost URL
                                   BYVAL S_Fr            AS STRING   , _                   '  Sender email address
                                   BYVAL S_To            AS STRING   , _                   '  Receiver email address
                                   BYVAL S_Subject       AS STRING   , _                   '  Message header
                                   BYVAL S_Message       AS STRING   , _                   '  Message text     ($Cr separated)
                                   BYVAL S_Attachments   AS STRING   , _                   '  Attachment files ($Cr separated)
                                   BYVAL n_Priority      AS LONG         ) AS LONG         '  email priority, 03 normal, 01 HOT
    
       DECLARE FUNCTION Email_Date AS STRING
       DECLARE FUNCTION Email_MimeEncode(BYVAL S_FileData AS STRING) AS STRING
    
    
    FUNCTION Email_Date AS STRING
    
       '  Retrieve the current time and date in E-mail header format
       LOCAL szFormat AS ASCIIZ * 40, szTemp AS ASCIIZ * 40, sResult AS STRING
       LOCAL t AS SYSTEMTIME, sUCTOffset AS STRING, 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
    
        FUNCTION = sResult + " " + szTemp + " " + sUCTOffset
    
    END FUNCTION
    
    
    FUNCTION Email_MimeEncode(BYVAL S_FileData 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(S_FileData) - 1) MOD 3, "=")                              '  Calculate padding on Base64 stream
    
       lcBlocks = (LEN(S_FileData) + 2) \ 3                                             '  Round up the length of the input
       IF lcBlocks * 3 > LEN(S_FileData) THEN                                           '  data to a multiple of three
          S_FileData = LSET$(S_FileData, lcBlocks * 3 USING $NUL)
       END IF
    
       sResult = SPACE$(lcBlocks * 4)                                                   '  Allocate space for output string
    
       pInput  = STRPTR(S_FileData)                                                     '  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 lBlock
       RSET ABS sResult = Pad                                                           '  Merge in the padding bytes
    
       FUNCTION = sResult
    
    END FUNCTION
    
    
    FUNCTION Email_Send(BYVAL S_Host          AS STRING   , _                  '  Mailhost URL
                        BYVAL S_Fr            AS STRING   , _                  '  Sender email address
                        BYVAL S_To            AS STRING   , _                  '  Receiver email address
                        BYVAL S_Subject       AS STRING   , _                  '  Message header
                        BYVAL S_Message       AS STRING   , _                  '  Message text     ($Cr separated)
                        BYVAL S_Attachments   AS STRING   , _                  '  Attachment files ($Cr separated)
                        BYVAL n_Priority      AS LONG         ) AS LONG        '  email priority, 03 normal, 01 HOT
    
    
       LOCAL lLine        AS LONG     , nTCP      AS LONG     , sAttachment  AS STRING, hFile AS DWORD
       LOCAL sLocalHost   AS STRING   , sResponse AS STRING   , sBoundary    AS STRING
       LOCAL Cnt          AS LONG     , sPart     AS STRING   , sCut         AS STRING, sFile AS STRING
    
       sBoundary = "Boundary." + REMOVE$(GUIDTXT$(GUID$), ANY "{-}")   '  Make a unique filedata boundarymarker
    
       nTCP = FREEFILE                                                 '  Connect to E-mailserver (mailhost)
       TCP OPEN "smtp" AT S_Host AS nTCP : IF ERR THEN EXIT FUNCTION
    
       TCP LINE nTCP, sResponse
       IF LEFT$(sResponse, 3) <> "220" THEN EXIT FUNCTION
    
       HOST NAME TO sLocalHost                                         '  Get the local host name
    
       TCP PRINT nTCP, "HELO " + sLocalHost                            '  Greet the mailhost
       TCP LINE nTCP, sResponse
       IF LEFT$(sResponse, 3) <> "250" THEN EXIT FUNCTION
    
       TCP PRINT nTCP, "MAIL FROM:<" + S_Fr + ">"                      '  Tell the mailhost who we are
       TCP LINE nTCP, sResponse
       IF LEFT$(sResponse, 3) <> "250" THEN EXIT FUNCTION
    
       sPart = S_To
       FOR Cnt = 0 TO TALLY (S_To, ",")
          SCut =  EXTRACT$(sPart, ",")
          TCP PRINT nTCP, "RCPT TO:<" + sCut + ">"                      '  Tell mailhost who message is for
          TCP LINE nTCP, sResponse
          IF LEFT$(sResponse, 3) <> "250" THEN EXIT FUNCTION
          sPart = REMAIN$(sPart, ",")
       NEXT sPart
    
       TCP PRINT nTCP, "DATA"                                          '  Send the message
       TCP LINE nTCP, sResponse
       IF LEFT$(sResponse, 3) <> "354" THEN EXIT FUNCTION
    
       TCP PRINT nTCP, "Date: "    + Email_Date                        '  The E-mail header
       TCP PRINT nTCP, "From: "    + S_Fr
       TCP PRINT nTCP, "To: "      + S_To
       TCP PRINT nTCP, "Subject: " + S_Subject
       TCP PRINT nTCP, "X-Mailer: Arcovox MIME/Base64 E-mailer 1.0"
       TCP PRINT nTCP, "MIME-Version: 1.0"
    
    
       '  http://www.powerbasic.com/support/pbforums/showthread.php?t=39781
       '  You set the priority as header fields in the email (same as Date:, Content-Type: etc).  There are a few possibilities depending on the email client. For example Outlook seems to send:
       '     X-Priority: 1 (Highest)
       '     X-MSMail-Priority: High
       '     Importance: High
       '  X-Priority has a scale of 1 (Highest) to 5 (Low) with 3 (Normal). You only need the number, but adding the brackets and text shouldn't affect how the header is read by the client.
       TCP PRINT nTCP, "X-Priority: " + STR$(n_Priority)
      'TCP PRINT nTCP, "X-Priority: 1 (Highest)"
    
       TCP PRINT nTCP, "Content-Type: multipart/mixed; boundary=" + $DQ + sBoundary + $DQ
       TCP PRINT nTCP, ""
       TCP PRINT nTCP, "--" + sBoundary
    
       ' Create a Plain-text section
       TCP PRINT nTCP, "Content-Type: text/plain; charset=" + $DQ + "us-ascii" + $DQ
       TCP PRINT nTCP, "Content-Transfer-Encoding: 7bit"
       TCP PRINT nTCP, ""
    
       '  Create a main E-mail body section
       sPart = S_Message
       FOR Cnt = 0 TO TALLY(sPart, $CR)
          sCut = EXTRACT$(sPart, $CR)
          TCP PRINT nTCP, sCut
          sPart = REMAIN$(sPart, $CR)
       NEXT Cnt
    
       IF NOT S_Attachments = "" THEN
          '  Create the attachment body section
          sPart = S_Attachments
          FOR Cnt = 0 TO TALLY(S_Attachments, $CR)
             sCut = EXTRACT$(sPart, $CR)
             sPart = REMAIN$(sPart, $CR)
             DIR$ CLOSE
             IF DIR$(sCut) <> "" THEN
                OPEN sCut FOR BINARY ACCESS READ LOCK SHARED AS #hFile 'Read the target file
                GET$ #hFile, LOF(hFile), sAttachment                                  '
                CLOSE #hFile                                                      '
                IF LEN (sAttachment) > 0 THEN
                   sAttachment = Email_MimeEncode(sAttachment)                         'Encode filedata in Base64 for MIME
                   sFile = sCut
                   WHILE INSTR(sFile, ANY "\:")
                      sFile = RIGHT$(sFile, LEN(sFile) -1)
                   WEND
                   TCP PRINT nTCP, "--" + sBoundary
                   TCP PRINT nTCP, "Content-Type: application/octet-stream; name=" + $DQ + sFile + $DQ
                   TCP PRINT nTCP, "Content-Transfer-Encoding: base64"
                   TCP PRINT nTCP, ""
    
                   '  Write the encoded data in lines of 76 characters.  Add an equality character if the last line is less than 76 bytes long
                   FOR lLine = 1 TO LEN(sAttachment) STEP 76
                      IF LEN(sAttachment) - lLine >= 76 THEN
                         TCP PRINT nTCP, MID$(sAttachment, lLine, 76)
                      ELSE
                         TCP PRINT nTCP, MID$(sAttachment, lLine) + "="
                      END IF
                   NEXT lLine
                END IF
             END IF
          NEXT Cnt
          TCP PRINT nTCP, "--" + sBoundary + "--"                     'Send the terminating boundary marker
       END IF
    
       TCP PRINT nTCP, "."                                         'Now finish E-mail off; we're done sending the message
       TCP LINE nTCP, sResponse
       IF LEFT$(sResponse, 3) <> "250" THEN EXIT FUNCTION
    
       TCP PRINT nTCP, "QUIT"                                      'Say goodbye
       TCP LINE nTCP, sResponse
       IF LEFT$(sResponse, 3) <> "221" THEN EXIT FUNCTION
    
       TCP CLOSE nTCP
       FUNCTION = -1
    
    END FUNCTION

  • #2
    Was not able to get this to compile. What compiler were you using?

    Comment

    Working...
    X