*====================================================================
* ILE-RPG module EMLDSTB
* E-mail a message to a distribution list- DSTTYPE(B)
* This module belongs to pgm EMLDST.
*
* After compiling this module,
* create the programn as follow:
* CRTPGM PGM(MMAIL/EMLDST) MODULE(MMAIL/EMLDST MMAIL/EMLDSTA
* MMAIL/EMLDSTB) ACTGRP(*CALLER) AUT(*USE)
*
*====================================================================
/copy *LIBL/qrpglesrc,hspecs
* File SENDERIDS- Used to identify the sender of the message
FSENDERIDS if e k disk usropn
* File DSTRLISTS- Used to define the recipients for a given distribution list
FDSTRLISTS if e k disk usropn
* Special characters
Fchars if e k disk usropn
/copy *LIBL/qrpglesrc,prototypeb
/copy *LIBL/qrpglesrc,mailproto
/copy *LIBL/qrpglesrc,usec
/copy *LIBL/qrpglesrc,variables3
* Main procedure Prototype and Interface
D EMLDSTB PR
D SenderID 20
D Subject 70
D TextStmf 256
D DataLib 10
D DstL 4
D AttachStmf 256
D myAttachType 50
D NbrReceivers 10i 0
D EMLDSTB PI
D SenderID 20
D Subject 70
D TextStmf 256
D DataLib 10
D DstL 4
D AttachStmf 256
D myAttachType 50
D NbrReceivers 10i 0
*
D DstLAll s like(DstL) inz('*ALL')
D AtSign s 1
D STRListInd s n
D ENDListInd s n
D cmd s 500
D email s 256
D TempStmf s 512
D ReturnPth s 256
D MimeSName s 50
D MimeSEmail s 50
D ToMNameArr s 50 dim(1000)
D ToMAddrArr s 256 dim(1000)
D ToMDistArr s 10i 0 dim(1000)
D ToAddrArr s 256 dim(1000)
D ToDistArr s 10i 0 dim(1000)
D MimeFSubj s 70
D TextFile s 512
D Charset s 50 inz('iso-8859-1')
D AtchFName s 512
D ContType s 21
D BinFlag s 1
D i s 10i 0
D r s 10i 0
D ImbAtt s 10i 0
D FromAddr s 255
D CpfID s 7
D module s 10
D topgmq s 5 inz('*PRV')
D msgtype s 7 inz('*INFO')
D msg s 512
*=====================================================================
* Open files
C exsr OpnF
* Get AT sign
C exsr GetAtSign
* Check the sender's ID
C SenderID chain sidrcd
C if not %found
C eval msg='Sender ID "' + %trim(SenderID) +
C '" not found in file ' +
C %trim(DataLib) + '/SENDERIDS.'
C exsr SndErrMsg
C endif
* Send a single message to multiple addressees
C exsr SndEmail
*==================
* Back to caller
C exsr Exit
*=====================================================================
* Send a single message to multiple addressees
*=====================================================================
C SndEmail begsr
* Create MIME temporary stream file
C eval TempStmf=TempCrtF
* Add the return path header
C eval ReturnPth=sidrpth
C callp MimeRtnPth(TempStmf:ReturnPth)
* Add the Sender header
C eval MimeSName =sidname
C eval MimeSEmail=sidemail
C callp MimeSender(TempStmf:
C MimeSName:MimeSEmail)
* Add the dummy To header
C eval ToMNameArr(1)='Distribution list ' +
C %trim(DstL)
C eval ToMAddrArr(1)='someone'+AtSign+
C 'somewhere.net'
C eval ToMDistArr(1)=0
C eval ToMNameArr(2)=' '
C eval ToMAddrArr(2)=' '
C callp MimeDistr(TempStmf:ToMNameArr:
C ToMAddrArr:ToMDistArr)
* Add the Subject header
C eval MimeFSubj=Subject
C callp MimeSubj(TempStmf:MimeFSubj)
* Add the "Content-Type: MULTIPART/MIXED; ..." header
C callp MimeMultiP(TempStmf)
* Include the external message text as multipart/alternative
C eval TextFile=TextStmf
C eval rc=MimeImbTxtF(TempStmF:TextFile:
C charset)
* Add the attachment, if requested so
C if AttachStmf<>'/NIL'
C eval AtchFName=AttachStmf
C eval ContType=myAttachType
C eval BinFlag='Y'
C eval r=%scan('text/':ContType)
C if r=1
C eval BinFlag='N'
C endif
C eval ImbAtt=2
C callp MimeImbAtt(TempStmf:AtchFName:
C ContType:BinFlag:ImbAtt)
C endif
* Close the MIME file by the part delimiter followed by "--"
C callp MimeClose(TempStmf )
* Send a single message to a bunch of receivers
*==================
C exsr ClrAddrArr
C eval FromAddr=MimeSEmail
C eval STRListInd=*off
C eval ENDListInd=*off
C DOW ENDListInd=*off
* - add up to 1000 receivers
C exsr AddToDstL
* - send a message to a bunch of receivers
C eval CpfID=SendMail(TempStmf:FromAddr:
C ToAddrArr:ToDistArr)
C ENDDO
*==================
*
C endsr
*=====================================================================
* Clear Array "ToAddrArr"
*=====================================================================
/free
Begsr ClrAddrArr;
for i=1 to 1000;
ToAddrArr(i)=' ';
endfor;
Endsr;
/end-free
*=====================================================================
* Add receivers to the real distribution list
*=====================================================================
C AddToDstL begsr
C IF STRListInd=*off
C eval STRListInd=*on
C eval i=0
C if DstL<>DstlAll
C DstL setll dstrcd
C DstL reade dstrcd
C else
C read dstrcd
C endif
C ENDIF
*
C DOW not %eof
C IF dststatus='1' and
C dstemail<>' '
C eval email=dstemail
C eval rc=VldEmail(email)
C if rc=0
C exsr SavToDstl
C else
C eval msg='E-mail address "' + %trim(email) +
C '" not valid.'
C exsr SndWrnMsg
C endif
C if i>=1000
C leave
C endif
C ENDIF
C if DstL<>DstlAll
C DstL reade dstrcd
C else
C read dstrcd
C endif
C ENDDO
*
C if i<1000
C eval ENDListInd=*on
C endif
*
C endsr
*=====================================================================
* Save into the real distribution list the info related to one addressee
*=====================================================================
C SavToDstL begsr
C eval nbrReceivers=nbrReceivers+1
C eval i=i+1
C eval ToAddrArr(i)=%trim(dstemail)
C eval ToDistArr(i)=0
*
C endsr
*=====================================================================
* Get AT sign
*=====================================================================
C GetAtSign begsr
* Get at sign
C eval rc = doCmd('ovrdbf file(chars) +
C tofile(MMAIL/chars) +
C secure(*yes) +
C ovrscope(*job)')
C open Chars
C eval charkey = 'AT SIGN'
C charkey chain charrcd
C if %found
C eval AtSign = charval
C else
C eval AtSign = x'5b'
C endif
C close Chars
C eval rc = doCmd('dltovr file(chars) +
C lvl(*job)')
*
C endsr
*=====================================================================
* Open files
*=====================================================================
C OpnF begsr
*
C if not %open(SENDERIDS)
C eval rc=docmd('ovrdbf SENDERIDS '+
C %trim(datalib) + '/SENDERIDS +
C secure(*yes) ovrscope(*job)')
C open SENDERIDS
C endif
*
C if not %open(DSTRLISTS)
C eval rc=docmd('ovrdbf DSTRLISTS '+
C %trim(datalib) + '/DSTRLISTS +
C secure(*yes) ovrscope(*job)')
C open DSTRLISTS
C endif
*
C endsr
*=====================================================================
* Close files
*=====================================================================
C CloF begsr
*
C if %open(SENDERIDS)
C close SENDERIDS
C eval rc=docmd('dltovr SENDERIDS lvl(*job)')
C endif
*
*
C if %open(DSTRLISTS)
C close DSTRLISTS
C eval rc=docmd('dltovr DSTRLISTS lvl(*job)')
C endif
*
C endsr
*=====================================================================
* Send warning message
*=====================================================================
C SndWrnMsg begsr
C eval module=psdsPgmnam
C callp SndPgmMsg(module:topgmq:msgtype:msg)
*
C endsr
*=====================================================================
* Send error message
*=====================================================================
C SndErrMsg begsr
C eval module=psdsPgmnam
C callp SndPgmMsg(module:topgmq:msgtype:msg)
C exsr Exit
*
C endsr
*=====================================================================
* Back to caller
*=====================================================================
C Exit begsr
C exsr CloF
C eval *inlr=*on
C return
*
C endsr