IDENTIFICATION DIVISION. PROGRAM-ID. SENDMAIL. ENVIRONMENT DIVISION. CONFIGURATION SECTION. SOURCE-COMPUTER. INTERACTIVE-COBOL. OBJECT-COMPUTER. INTERACTIVE-COBOL. * Sample program using the IC_SEND_MAIL builtin * added in 3.50 of ICOBOL * * * Make sure the the environment parament ICSMTPSERVER is set * to find the SMTP server. (ICSMTPPORT is optional) * * RHJ 3.50 New. * 3.57 Updated for username/password support * 3.65 Updated with Help, etc. * INPUT-OUTPUT SECTION. DATA DIVISION. FILE SECTION. WORKING-STORAGE SECTION. 77 ICSMTPSERVER-ENV PIC X(20) VALUE "ICSMTPSERVER". 77 ICSMTPSERVER-ENTRY PIC X(70) VALUE SPACES. 01 MAIL-STUFF. * Initialized at the beginning of the program 02 TO-LIST PIC X(80). 02 FROM-ADDR PIC X(80). 02 CC-LIST PIC X(80). 02 BCC-LIST PIC x(80). 02 SUBJECT PIC X(80). 02 TOTAL-BODY. 04 BODY-PART OCCURS 12 TIMES PIC x(80). * 03 BODY-1 PIC X(80). * 03 BODY-2 PIC X(80). * 03 BODY-3 PIC X(80). * 03 BODY-4 PIC X(80). * 03 BODY-5 PIC X(80). * 03 BODY-6 PIC X(80). * 03 BODY-7 PIC X(80). * 03 BODY-8 PIC X(80). * 03 BODY-9 PIC X(80). * 03 BODY-10 PIC X(80). * 03 BODY-11 PIC X(80). * 03 BODY-12 PIC X(80). 02 MIME-TYPE PIC X(20). 02 ATT-FILE PIC X(80). 02 USER-PASS-ENTRY PIC X(70). 01 I PIC 99. 01 START-LOC PIC 9(5). 01 BODY-LEN PIC 9(5). 01 BODY-TEXT PIC X(4000). 01 BODY-TEXT-START PIC 9(5). 01 BODY-TEXT-LEN PIC 9(5). 01 EXCEPTION-STATUS PIC 9(5). 01 EXCEPT-MSG PIC X(60). 01 ESC-CODE PIC 99. 01 ANY-KEY PIC X. SCREEN SECTION. 01 BLANK-SCREEN. 02 BLANK SCREEN. 01 HELP-SCREEN-BLANKS. 02 LINE 10 BLANK LINE. 02 LINE 11 BLANK LINE. 02 LINE 12 BLANK LINE. 02 LINE 13 BLANK LINE. 02 LINE 14 BLANK LINE. 02 LINE 15 BLANK LINE. 02 LINE 16 BLANK LINE. 02 LINE 17 BLANK LINE. 02 LINE 18 BLANK LINE. 02 LINE 24 BLANK LINE. 01 HELP-SCREEN. 02 LINE 10 COL 10 BRIGHT UNDERLINE "Help Selection:". 02 LINE 11 COL 1 "To:, Fr:, and Subject: entries are required". 02 LINE 12 COL 1 "CC:, BC:, entries can be blank". 02 LINE 13 COL 1 " To:, CC:, BC:, can be a list of addresses separated by comma". 02 LINE 14 COL 1 "Mime: entry must be blank unless a File is to be passed". 02 LINE 15 COL 1 " then it must be a valid type: Text, Video, ...". 02 LINE 16 COL 1 "User,pass: entry is required if the SMTP server requires Authorization". 02 LINE 17 COL 1 " then it must match that required by the server, password is case sensitive". 02 LINE 18 COL 1 " To debug use the -ai switches to icrun.". 02 LINE 24 COL 1 "Hit any key to clear Help". 02 PIC X TO ANY-KEY. 01 MAIN-SCREEN. 02 LINE 1 COL 10 BRIGHT " Sample Mail Sender v2". 02 SMTP-ENTRY. 04 COL 40 "SMTP: ". 04 PIC X(30) USING ICSMTPSERVER-ENTRY. 02 MAIN-ENTRY. 03 FILLER. 04 LINE 2 COL 1 "To: ". 04 PIC X(75) USING TO-LIST. 04 LINE 3 COL 1 "Fr: ". 04 PIC X(75) USING FROM-ADDR. 04 LINE 4 COL 1 "CC: ". 04 PIC X(75) USING CC-LIST. 04 LINE 5 COL 1 "BC: ". 04 PIC X(75) USING BCC-LIST. 04 LINE 6 COL 1 "Subject: ". 04 PIC X(40) USING SUBJECT. 04 FILE-ENTRY. 05 LINE 6 COL 59 "Mime: ". 05 PIC X(15) USING MIME-TYPE. 05 LINE 7 COL 1 "File: ". 05 PIC X(70) USING ATT-FILE. 04 USER-ENTRY. 05 LINE 8 COL 1 "User,pass: ". 05 PIC X(69) USING USER-PASS-ENTRY. 04 LINE 9 COL 1 "Body:". 04 LINE 10 COL 1 PIC X(80) USING BODY-PART (1). 04 LINE 11 COL 1 PIC X(80) USING BODY-PART (2). 04 LINE 12 COL 1 PIC X(80) USING BODY-PART (3). 04 LINE 13 COL 1 PIC X(80) USING BODY-PART (4). 04 LINE 14 COL 1 PIC X(80) USING BODY-PART (5). 04 LINE 15 COL 1 PIC X(80) USING BODY-PART (6). 04 LINE 16 COL 1 PIC X(80) USING BODY-PART (7). 04 LINE 17 COL 1 PIC X(80) USING BODY-PART (8). 04 LINE 18 COL 1 PIC X(80) USING BODY-PART (9). 04 LINE 19 COL 1 PIC X(80) USING BODY-PART (10). 04 LINE 20 COL 1 PIC X(80) USING BODY-PART (11). 04 LINE 21 COL 1 PIC X(80) USING BODY-PART (12). 02 LINE 22 COL 1 "use \\ in body for extra lf, CC, BC, Mime, File, User,pass, can be blank". 02 LINE 24 COL 1 "F1 Send, F5 Change SMTP, F6 Help, F7 Exit". 01 ERROR-MESSAGE. 02 LINE 23 COL 1 "Error: ". 02 PIC ZZZZ9 FROM EXCEPTION-STATUS. 02 COL PLUS 1 PIC X(60) USING EXCEPT-MSG. 01 GOOD-MESSAGE. 02 LINE 23 COL 1 "Success: ". 02 PIC ZZZZ9 FROM EXCEPTION-STATUS. 02 COL PLUS 1 PIC X(60) USING EXCEPT-MSG. 01 ERROR-MESSAGE-BLANK. 02 LINE 23 BLANK LINE. PROCEDURE DIVISION. MAIN SECTION. START-UP. * Initialize input MOVE SPACES TO MAIL-STUFF. * MOVE "text" to MIME-TYPE. * Clear screen DISPLAY BLANK-SCREEN. CALL "IC_GET_ENV" USING ICSMTPSERVER-ENV, ICSMTPSERVER-ENTRY ON EXCEPTION * Could show warning MOVE "** SMTP server not set **" TO ICSMTPSERVER-ENTRY END-CALL. MAIL-IT. * main Mail Loop DISPLAY MAIN-SCREEN. ACCEPT MAIN-ENTRY. * Clear message line from previous loop DISPLAY ERROR-MESSAGE-BLANK. ACCEPT ESC-CODE FROM ESCAPE. IF ESC-CODE = 8 * F7 end GO TO END-IT-EXIT. IF ESC-CODE = 7 * F6 Help DISPLAY HELP-SCREEN-BLANKS; DISPLAY HELP-SCREEN; ACCEPT HELP-SCREEN; DISPLAY HELP-SCREEN-BLANKS; GO TO MAIL-IT. IF ESC-CODE = 6 * F5 change SMTP ACCEPT SMTP-ENTRY ACCEPT ESC-CODE FROM ESCAPE IF ESC-CODE = 1 GO TO END-IT-EXIT END-IF CALL "IC_SET_ENV" USING ICSMTPSERVER-ENV, ICSMTPSERVER-ENTRY ON EXCEPTION ACCEPT EXCEPTION-STATUS FROM EXCEPTION CALL "IC_MSG_TEXT" USING EXCEPTION-STATUS, EXCEPT-MSG DISPLAY ERROR-MESSAGE MOVE SPACES TO ICSMTPSERVER-ENTRY END-CALL GO TO MAIL-IT END-IF. IF ESC-CODE NOT = 2 AND ESC-CODE NOT = 3 * ESC-CODE NOT = 4 AND * ESC-CODE NOT = 5 GO TO MAIL-IT. MOVE SPACES TO BODY-TEXT. MOVE 1 TO BODY-TEXT-START; MOVE 0 TO BODY-TEXT-LEN. CALL "IC_TRIM" USING TOTAL-BODY, START-LOC, BODY-LEN. ADD START-LOC TO BODY-LEN. ADD 79 TO BODY-LEN. DIVIDE 80 INTO BODY-LEN. MOVE 1 TO I. PERFORM BODY-LEN TIMES CALL "IC_TRIM" USING BODY-PART (I), START-LOC, BODY-LEN IF BODY-LEN > 0 IF BODY-LEN NOT = 1 IF BODY-PART (I) (START-LOC + BODY-LEN - 2:2) = "\\" SUBTRACT 2 FROM BODY-LEN END-IF END-IF MOVE BODY-PART (I) (1:BODY-LEN) TO BODY-TEXT (BODY-TEXT-START:) ADD BODY-LEN TO BODY-TEXT-START END-IF MOVE X"0d0a" TO BODY-TEXT (BODY-TEXT-START:2) ADD 2 TO BODY-TEXT-START, BODY-TEXT-LEN ADD 1 TO I END-PERFORM. INSPECT BODY-TEXT REPLACING ALL "\\" BY X"0d0a". * Add extra lines requested IF ESC-CODE = 2 * Main send, all arguments CALL "IC_SEND_MAIL" USING TO-LIST, FROM-ADDR, CC-LIST, BCC-LIST, SUBJECT, BODY-TEXT, MIME-TYPE, ATT-FILE, USER-PASS-ENTRY ON EXCEPTION ACCEPT EXCEPTION-STATUS FROM EXCEPTION CALL "IC_MSG_TEXT" USING EXCEPTION-STATUS, EXCEPT-MSG DISPLAY ERROR-MESSAGE NOT ON EXCEPTION ACCEPT EXCEPTION-STATUS FROM EXCEPTION CALL "IC_MSG_TEXT" USING EXCEPTION-STATUS, EXCEPT-MSG DISPLAY GOOD-MESSAGE END-CALL END-IF. IF ESC-CODE = 3 * Simple send, no Mime, File, Username,password CALL "IC_SEND_MAIL" USING TO-LIST, FROM-ADDR, CC-LIST, BCC-LIST, SUBJECT, BODY-TEXT ON EXCEPTION ACCEPT EXCEPTION-STATUS FROM EXCEPTION CALL "IC_MSG_TEXT" USING EXCEPTION-STATUS, EXCEPT-MSG DISPLAY ERROR-MESSAGE NOT ON EXCEPTION ACCEPT EXCEPTION-STATUS FROM EXCEPTION CALL "IC_MSG_TEXT" USING EXCEPTION-STATUS, EXCEPT-MSG DISPLAY GOOD-MESSAGE END-CALL END-IF. GO TO MAIL-IT. * Loop END-IT-EXIT. * Exit (this will return if CALL'ed) EXIT PROGRAM. END-IT-STOP. * Stop STOP RUN.