Close Databases All Set Century On Set Date Dmy Set Exact On Set Ansi On Set Deleted Off Set Safety Off * Clasa oEmail * oEmail > oThunderbirdEmailCmd * oEmail > oCDO * oEmail > oOutlook * oEmail > oMapi * getoEmail: citeste optiunile de email din ROA\settings.ini si intoarce obiectul oMail * loMail = getoEmail() * loMail.cTo = 'test@test.ro' * loMail.EmailSetAttachment('c:\factura.pdf') * lnErrors = loMail.Send() * if lnErrors > 0 * messageb(loMail.GetErrorMessage) * end if *!* 07.04.2020 *!* Am adaugat clasa trimiterea de email prin client Mapi #Define oAnonymous 0 && Perform no authentication (anonymous) #Define oBasic 1 && Use the basic (clear text) authentication mechanism. * https://www.berezniker.com/content/pages/visual-foxpro/cdo-2000-class-sending-emails #Define cdoSendPassword "http://schemas.microsoft.com/cdo/configuration/sendpassword" #Define cdoSendUserName "http://schemas.microsoft.com/cdo/configuration/sendusername" #Define cdoSendUsingMethod "http://schemas.microsoft.com/cdo/configuration/sendusing" #Define cdoSMTPAuthenticate "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate" #Define cdoSMTPConnectionTimeout "http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout" #Define cdoSMTPServer "http://schemas.microsoft.com/cdo/configuration/smtpserver" #Define cdoSMTPServerPort "http://schemas.microsoft.com/cdo/configuration/smtpserverport" #Define cdoSMTPUseSSL "http://schemas.microsoft.com/cdo/configuration/smtpusessl" #Define cdoURLGetLatestVersion "http://schemas.microsoft.com/cdo/configuration/urlgetlatestversion" #Define cdoAnonymous 0 && Perform no authentication (anonymous) #Define cdoBasic 1 && Use the basic (clear text) authentication mechanism. #Define cdoSendUsingPort 2 && Send the message using the SMTP protocol over the network. #Define cdoXMailer "urn:schemas:mailheader:x-mailer" #Define xlCellTypeVisible 12 #Define xlSourceRange 4 #Define xlHtmlStatic 0 #Define olFolderSentMail 5 #Define olFormatHTML 2 #Define wdFormatOriginalFormatting 16 && Preserves original formatting of the pasted material #Define SUCCESS_SUCCESS 0 #Define MAPI_DIALOG 8 #Define MAPI_ORIG 0 #Define MAPI_TO 1 #Define MAPI_CC 2 #Define MAPI_BCC 3 *-------------------------------------------------------------------------------------------- ************************************************ *** Verificare ecluzare sas-uri/camere ecluze RORIS ************************************************ lcDirector = ADDBS(JUSTPATH(SYS(16,0))) lcConvoaie = m.lcDirector + 'convoaie.dbf' IF !FILE(m.lcConvoaie) CREATE TABLE (m.lcConvoaie) (vye_id C(36), declaratie C(8), ; ag N(1), cv N(1), ov N(1), nv N(1), ; ag_sasn N(1), cv_sasn N(1), ov_cn N(1), nv_cn N(1), ; ag_data T NULL, cv_data T NULL, ov_data T NULL, nv_data T NULL) SELECT convoaie INDEX on declaratie TAG declaratie USE IN (SELECT('convoaie')) ENDIF USE (m.lcConvoaie) IN 0 SHARED ALIAS convoaie * transmit doar ecluzarile mai noi decat ultima data de ecluzare CALCULATE MAX(ag_data), MAX(cv_data), MAX(ov_data), MAX(nv_data) TO lnAgData, lnCVData, lnOVData, lnNVData IN convoaie ldDataOra = MAX(lnAgData, lnCVData, lnOVData, lnNVData) lnHandle = SQLConnect("roa", "acn","ROMFASTSOFT") If m.lnHandle <= 0 Aerror(laEroare) WriteLog(laEroare(3)) Return Endif TEXT TO lcsql TEXTMERGE noshow select distinct vye_id, declaratio as declaratie, agigea as ag, cernavoda as cv, navodari as nv, ovidiu as ov, agigea_data as ag_data, cernavoda_data as cv_data, navodari_data as nv_data, ovidiu_data as ov_data, agigea_sasn as ag_sasn, cernavoda_sasn as cv_sasn, ovidiu_cn as ov_cn, navodari_cn as nv_cn from (select v.vye_id, v.declaratio, v.generation, nvl(vlt.AGIGEA,0) as AGIGEA, nvl(vlt.CERNAVODA,0) as CERNAVODA, nvl(vlt.NAVODARI,0) as NAVODARI, nvl(vlt.OVIDIU,0) as OVIDIU, vlt.AGIGEA_DATA, vlt.CERNAVODA_DATA, vlt.OVIDIU_DATA, vlt.NAVODARI_DATA, (case when nvl(vlt.AGIGEA,0) = 1 and nvl(vltm.AGIGEA_SAS1,0) = 0 and nvl(vltm.AGIGEA_SAS2,0) = 0 then 1 else 0 end) as AGIGEA_SASN, (case when nvl(vlt.CERNAVODA,0) = 1 and nvl(vltm.CERNAVODA_SAS1,0) = 0 and nvl(vltm.CERNAVODA_SAS2,0) = 0 then 1 else 0 end) as CERNAVODA_SASN, (case when nvl(vlt.OVIDIU,0) = 1 and nvl(vltm.OVIDIU_C1,0) = 0 and nvl(vltm.OVIDIU_C2,0) = 0 then 1 else 0 end) as OVIDIU_CN, (case when nvl(vlt.NAVODARI,0) = 1 and nvl(vltm.NAVODARI_C1,0) = 0 and nvl(vltm.NAVODARI_C2,0) = 0 then 1 else 0 end) as NAVODARI_CN From IPS_VVOYAGES v join IPS_VVOYAGE_MEMBERS vm On v.id = vm.VYE_ID left join ips_vvoyage_locks_tab vlt on v.id = vlt.vye_id left join ips_vvoyage_locks_vms_tab vltm on vm.vye_id = vltm.vye_id and vm.id = vltm.vms_id) where <= ' + ALLTRIM(STR(YEAR(m.ldDataOra)-1)) + ' and ', '')>>(agigea_sasn = 1 or cernavoda_sasn = 1 or ovidiu_cn = 1 or navodari_cn = 1) order by declaratio; ENDTEXT lnSucces = SQLExec(m.lnHandle, m.lcSql, 'crsConvoaie') SQLDISCONNECT(m.lnHandle) lcText = '' lnConvoaie = 0 If m.lnSucces < 0 Aerror(laEroare) WriteLog(laEroare(3)) Else SELECT convoaie SET ORDER TO declaratie lcText = 'Lista convoaie cu ecluzare, mai noi decat ' + TRANSFORM(m.ldDataOra) + ', care nu au inregistrate sas-ul/camera ecluzei:' + CHR(13) + CHR(10) Select crsConvoaie SCAN SCATTER NAME loRec lcDeclaratie = PADR(loRec.declaratie, 8, ' ') SELECT convoaie IF !SEEK(m.lcDeclaratie) APPEND BLANK ENDIF GATHER NAME loRec WITH loRec IF (.ag_data > m.ldDataOra AND .ag_sasn = 1) OR (.cv_data > m.ldDataOra AND .cv_sasn = 1) OR ; (.ov_data > m.ldDataOra AND .ov_cn = 1) OR (.nv_data > m.ldDataOra AND .nv_cn = 1) lcText = lcText + m.lcDeclaratie lnConvoaie = lnConvoaie + 1 IF .ag_data > m.ldDataOra AND .ag_sasn = 1 lcText = lcText + ', AG (' + TRANSFORM(.ag_data) + ')' ENDIF IF .cv_data > m.ldDataOra AND .cv_sasn = 1 lcText = lcText + ', CV (' + TRANSFORM(.cv_data) + ')' ENDIF IF .ov_data > m.ldDataOra AND .ov_cn = 1 lcText = lcText + ', OV (' + TRANSFORM(.ov_data) + ')' ENDIF IF .nv_data > m.ldDataOra AND .nv_cn = 1 lcText = lcText + ', NV (' + TRANSFORM(.nv_data) + ')' ENDIF lcText = lcText + CHR(13) + CHR(10) ENDIF ENDWITH ENDSCAN lcImportFile = Addbs(Justpath(Sys(16,0))) + 'verificare_roris_ecluze_' + DTOC(DATE(),1) + '.txt' Strtofile(m.lcText, m.lcImportFile,1) ENDIF USE IN (SELECT('crsConvoaie')) USE IN (SELECT('convoaie')) ************************************************ lcSetariFile = m.lcDirector + 'settings.ini' IF !FILE(m.lcSetariFile) TEXT TO lcSettings noshow [email] mailserver = mail.acn.ro port = 25 username = facturare@acn.ro password = fe1VLsNMZDZVJKW from = compania@acn.ro to = cc = bcc = sendwithoutresults = 1 ENDTEXT STRTOFILE(m.lcSettings,m.lcSetariFile) ENDIF SET STEP ON lcSetari = FILETOSTR(m.lcSetariFile) lnLinii = ALINES(laLinii, lcSetari) lcMailServer = '' lcPort = '' lcUsername = '' lcPassword = '' lcFrom = '' lcTo = '' lcCC = '' lcBCC = '' llSSL = .F. llSendWithoutResults = .T. FOR lnLinie = 1 TO lnLinii lcLinie = laLinii(m.lnLinie) IF AT('=', m.lcLinie) = 0 LOOP ENDIF lcVariabila = LOWER(ALLTRIM(GETWORDNUM(m.lcLinie, 1, '='))) lcValoare = ALLTRIM(GETWORDNUM(m.lcLinie, 2, '=')) IF m.lcVariabila = 'mailserver' lcMailServer = m.lcValoare ENDIF IF m.lcVariabila = 'port' lcPort = m.lcValoare ENDIF IF m.lcVariabila = 'username' lcUsername = m.lcValoare ENDIF IF m.lcVariabila = 'password' lcPassword = m.lcValoare ENDIF IF m.lcVariabila = 'from' lcFrom = m.lcValoare ENDIF IF m.lcVariabila = 'to' lcTo = m.lcValoare ENDIF IF m.lcVariabila = 'cc' lcCC = m.lcValoare ENDIF IF m.lcVariabila = 'bcc' lcBCC = m.lcValoare ENDIF IF m.lcVariabila = 'ssl' llSSL = (INT(VAL(m.lcValoare)) = 1) ENDIF IF m.lcVariabila = 'sendwithoutresults' llSendWithoutResults = (INT(VAL(m.lcValoare)) = 1) ENDIF ENDFOR * Trimit email doar daca sunt rezultate? IF m.lnConvoaie = 0 AND !m.llSendWithoutResults WriteLog('0 convoaie. Nu se trimite email.') RETURN ENDIF llThunderbirdCMD = .F. llCDO = .T. llOutlook = .F. llMapi = .F. Do Case Case m.llThunderbirdCMD loEmail = Createobject("oThunderbirdEmailCmd") Case m.llCDO loEmail = Createobject("oCDO") Case m.llOutlook loEmail = Createobject("oOutlook") Case m.llMapi loEmail = Createobject("oMapi") Otherwise Return Endcase ************************** * CDO Specific loEmail.cServer = m.lcMailServer loEmail.nServerPort = INT(VAL(m.lcPort)) loEmail.cUserName = m.lcUsername loEmail.cPassword = m.lcPassword loEmail.lUseSSL = m.llSSL loEmail.nAuthenticate = Iif(Empty(loEmail.cUserName), oAnonymous, oBasic) ************************** ************************** * Thunderbird Specific loEmail.EmailSetExePath('C:\Program Files (x86)\Mozilla Thunderbird\thunderbird.exe') loEmail.EmailSetWait() ************************** ************************** * Outlook Specific loEmail.EmailSetPreview(.F.) loEmail.EmailSetDisplayWithoutInfo(.T.) ************************** loEmail.cFrom = lcFrom loEmail.cTo = m.lcTo loEmail.cCC = m.lcCC loEmail.cBCC = m.lcBCC loEmail.cSubject = ALLTRIM(STR(m.lnConvoaie)) + ' convoaie cu ecluzare, mai noi decat ' + TRANSFORM(m.ldDataOra) + ', care nu au inregistrate sas-ul/camera ecluzei:' loEmail.cHtmlBody = STRTRAN(m.lcText, CHR(13) + CHR(10),'
' + CHR(13)+CHR(10),1,10000,1) loEmail.cTextBody = '' && m.lcText loEmail.EmailSendWithoutAttachments(.T.) SET STEP ON lnErrors = loEmail.Send() ltDataEmail = Datetime() llSucces = (m.lnErrors = 0) lcEroare = Iif(!m.llSucces, loEmail.GetErrorMessage(), '') WriteLog('Email trimis la ' + m.lcTo + ' : ' + IIF(m.llSucces, 'Succes', lcEroare)) * ----------------------------------- * oEmail.Send * > EmailSend * >> EmailCreateCfg * >> EmailSetConfiguration * >> EmailSetHeader * >> EmailSetParameters Define Class oEmail As Custom Protected aErrors[1], nErrorCount, oMsg, oCfg, cXMailer nErrorCount = 0 * Message attributes oMsg = Null cFrom = "" cFromName = "" cReplyTo = "" cTo = "" cCC = "" cBCC = "" cAttachment = "" && attachment file list separated by comma nAttachments = 0 && number of attachment files cSubject = "" && subiect email factura cHtmlBody = "" && continut email factura cTextBody = "" cHtmlBodyUrl = "" cBorderouSubject = "" && subiect email borderou cBorderouBody = "" && continut email borderou cCharset = "" * Priority: Normal, High, Low or empty value (Default) cPriority = "" * Configuration object fields values oCfg = Null cServer = "" nServerPort = 25 * Use SSL connection lUseSSL = .F. nConnectionTimeout = 30 && Default 30 sec's nAuthenticate = oAnonymous cUserName = "" cPassword = "" * Do not use cache for cHtmlBodyUrl lURLGetLatestVersion = .T. * Optional. Creates your own X-MAILER field in the header cXMailer = "" cEmailExePath = '' cEmailProfile = '' lEmailWait = .F. && wait for the email to be sent, to advance to the next email lEmailPreview = .F. && preview each mail (default .F.) lDisplayEmailWithoutInfo = .F. && display mail without from, to, subject, body, attachment lCanDisplayEmailWithoutInfo = .T. && can the email without from, to, subject, body be displayed to user? (CDO does not display anything, for now) lFirstEmail = .T. && after the first email becomes .F., in case you want to do some things only the first time (eg: show the Sent folder in Outlook) lSendWithoutAttachments = .F. && if email can be sent without attachment (Default = .F.) Protected Procedure Init This.ClearErrors() Endproc * Send message * Return Number of Errors (0 = succes) Procedure Send Local lnErrorCount lnErrorCount = This.GetErrorCount() If m.lnErrorCount > 0 This.ClearMessage() Return m.lnErrorCount Endif With This .ClearErrors() .EmailCreateCfg() && abstract, to be implemented Endwith * Check server, user, password lnErrorCount = This.SetConfiguration() If m.lnErrorCount = 0 * If email without info doesn't display to the user, add error If !(This.lDisplayEmailWithoutInfo And This.lCanDisplayEmailWithoutInfo) If Empty(This.cFrom) This.AddError("ERROR : From is empty.") Endif If Empty(This.cSubject) This.AddError("ERROR : Subject is empty.") Endif If Empty(This.cTo) && And Empty(This.cCC) And Empty(This.cBCC) * This.AddError("ERROR : To, CC and BCC are all empty.") * Nu permit trimiterea de emailuri (cu facturi) fara TO. * Altfel le trimite doar la CC/BCC, adica trimite copia inapoi. * CC/BCC sunt fixe in settings.ini si nu ma intereseaza daca sunt sau nu completate This.AddError("ERROR : To is empty.") Endif Endif Endif && SetConfiguration lnErrorCount = This.GetErrorCount() If m.lnErrorCount = 0 This.EmailSetHeader() This.EmailSetParameters() Endif lnErrorCount = This.GetErrorCount() If m.lnErrorCount = 0 This.AddAttachments() * If email without attachment doesn't display to the user, add error If !(This.lDisplayEmailWithoutInfo And This.lCanDisplayEmailWithoutInfo) If !This.lSendWithoutAttachments And Empty(This.EmailGetAttachmentsNumber()) This.AddError("ERROR : There are no attachments.") Endif Endif Endif * Send Email lnErrorCount = This.GetErrorCount() If m.lnErrorCount = 0 This.EmailSend() lnErrorCount = This.GetErrorCount() Endif This.lFirstEmail = .F. This.ClearMessage() Return m.lnErrorCount Endproc * Clear errors collection Procedure ClearErrors() This.nErrorCount = 0 Dimension This.aErrors[1] This.aErrors[1] = Null Return This.nErrorCount Endproc * Return # of errors in the error collection Procedure GetErrorCount Return This.nErrorCount Endproc * Return error by index Procedure Geterror Lparameters tnErrorno If tnErrorno <= This.GetErrorCount() Return This.aErrors[tnErrorno] Else Return Null Endif Endproc * Return all error messages into one message Procedure GetErrorMessage Lparameters tlClearErrors * tlClearErrors (optional): clear all error messages Local lcErrorMessage, lnError, lnErrors lnErrors = This.GetErrorCount() lcErrorMessage = '' For lnError = 1 To m.lnErrors lcErrorMessage = m.lcErrorMessage + This.Geterror(m.lnError) + '***' Endfor * Clear errors If m.tlClearErrors This.ClearErrors() Endif Return m.lcErrorMessage Endproc && GetErrorMessage * Populate configuration object Protected Procedure SetConfiguration * Validate supplied configuration values If Empty(This.cServer) This.AddError("ERROR: SMTP Server isn't specified.") Endif If Not Inlist(This.nAuthenticate, oAnonymous, oBasic) This.AddError("ERROR: Invalid Authentication protocol ") Endif If This.nAuthenticate = oBasic ; AND (Empty(This.cUserName) Or Empty(This.cPassword)) This.AddError("ERROR: User name/Password is required for basic authentication") Endif If This.GetErrorCount() > 0 Return This.GetErrorCount() Endif * Populate configuration objects This.EmailSetConfiguration() Return This.GetErrorCount() Endproc *---------------------------------------------------- * Add message to the error collection Protected Procedure AddError Lparameters tcErrorMsg This.nErrorCount = This.nErrorCount + 1 Dimension This.aErrors[This.nErrorCount] This.aErrors[This.nErrorCount] = tcErrorMsg Return This.nErrorCount Endproc *---------------------------------------------------- * Format an error message and add to the error collection Protected Procedure AddOneError Lparameters tcPrefix, tnError, tcMethod, tnLine Local lcErrorMsg, laList[1] If Inlist(tnError, 1427, 1429) Aerror(laList) lcErrorMsg = Transform(laList[7], "@0") + " " + laList[3] Else lcErrorMsg = Message() Endif This.AddError(tcPrefix + ":" + Transform(tnError) + " # " + ; tcMethod + " # " + Transform(tnLine) + " # " + lcErrorMsg) Return This.nErrorCount Endproc *---------------------------------------------------- * Simple Error handler. Adds VFP error to the objects error collection Protected Procedure Error Lparameters tnError, tcMethod, tnLine This.AddOneError("ERROR: ", tnError, tcMethod, tnLine ) Return This.nErrorCount Endproc Procedure EmailSetProfile Lparameters tcProfile This.cEmailProfile = m.tcProfile Endproc Procedure EmailSetExePath Lparameters tcExePath This.cEmailExePath = m.tcExePath Endproc Procedure EmailSetWait Lparameters tlWait This.lEmailWait = m.tlWait Endproc && EmailSetWait *------------------------------------------------------- * Add a file to the attachement list Procedure EmailSetAttachment Lparameters tcFile If !Empty(m.tcFile) And Type('tcFile') = 'C' This.cAttachment = This.cAttachment + Iif(!Empty(This.cAttachment), ",", "") + m.tcFile Endif Endproc && SetAttachment *------------------------------------------------------- * Overwrite the attachement list with a list of files Procedure EmailSetAttachments Lparameters tcFiles If !Empty(m.tcFiles) And Type('tcFiles') = 'C' This.cAttachment = m.tcFiles Endif Endproc && SetAttachment *------------------------------------------------------- * Empty the recipient list in subclass Procedure EmailClearMessage * To be implemented Endproc && EmailClearMessage Procedure ClearMessage This.EmailClearMessage() This.cTo = "" This.cHtmlBody = "" This.cSubject = "" This.cAttachment = "" Endproc && ClearMessage Procedure EmailSendWithoutAttachments Lparameters tlSendWithoutAttachments This.lSendWithoutAttachments = m.tlSendWithoutAttachments Endproc Procedure AddAttachments Local laList[1], laDummy[1] Local lcAttachment, lnAttachment, lnAttachments * Process attachments If Not Empty(This.cAttachment) * Accepts comma or semicolon lnAttachments = Alines(laList, This.cAttachment, [,], [;]) For lnAttachment = 1 To m.lnAttachments lcAttachment = Alltrim(laList[m.lnAttachment]) * Ignore empty values If Empty(laList[m.lnAttachment]) Loop Endif * Make sure that attachment exists If Adir(laDummy, lcAttachment) = 0 This.AddError("ERROR: Attachment not Found - " + lcAttachment) Else * The full path is required. If Upper(lcAttachment) <> Upper(Fullpath(lcAttachment)) lcAttachment = Fullpath(lcAttachment) Endif This.EmailAddAttachment(lcAttachment) Endif Endfor Endif Endproc && AddAttachments Procedure EmailAddAttachment Lparameters tcAttachment * To be implemented Endproc && EmailAddAtachment Procedure EmailGetAttachmentsNumber Return Getwordcount(This.cAttachment, [,]) Endproc Procedure EmailSetPreview Lparameters tlSetPreview This.lEmailPreview = m.tlSetPreview Endproc && EmailSetPreview Procedure EmailSetDisplayWithoutInfo Lparameters tlSetDisplay This.lDisplayEmailWithoutInfo = m.tlSetDisplay Endproc && EmailSetDisplayWithoutInfo *------------------------------------------------------- * Create configuration objects Procedure EmailCreateCfg * to be implemented Endproc *------------------------------------------------------- * Set mail header fields, if necessary. For now sets X-MAILER, if specified Procedure EmailSetHeader * to be implemented Endproc *------------------------------------------------------- * Set to, from, atachments.. Procedure EmailSetParameters * to be implemented Endproc *------------------------------------------------------- * Set server, username, password * Return Number of Errors (0 = success) Procedure EmailSetConfiguration() * to be implemented Return 0 Endproc *------------------------------------------------------- * Send email Procedure EmailSend * to be implemented Endproc *------------------------------------------------------- * Add Error Procedure EmailAddError Lparameters tcErrorMessage This.AddError("ERROR : " + Transform(m.tcErrorMessage)) Endproc *---------------------------------------------------- * Protected Procedure cPriority_assign(tvVal) * Check for incorrect values If Inlist("~" + Proper(tvVal) + "~", "~High~", "~Normal~", "~Low~") Or Empty(tvVal) This.cPriority = Proper(Alltrim(tvVal)) Else This.AddError("ERROR: Invalid value for cPriority property.") Endif Endproc Enddefine && oEmail *----------------------------------------------------------- *!* oEmail.Send *!* > EmailCreateCfg *!* > EmailSetConfiguration *!* > EmailSetHeader *!* > EmailSetParameters *!* > EmailSend Define Class oThunderbirdEmailCmd As oEmail Procedure EmailSend Local loRun As 'api_apprun' Of 'process.vcx' Local lcBody, lcCommandLine, lcExePath, lcProfile lcProfile = This.cEmailProfile lcExePath = This.cEmailExePath lcBody = Iif(!Empty(This.cHtmlBody), This.cHtmlBody, This.cTextBody) If Empty(This.cHtmlBody) lcBody = Strtran(m.lcBody, Chr(13) + Chr(10), [
], 1, 1000, 1) lcBody = Strtran(m.lcBody, Chr(13), [
], 1, 1000, 1) Else lcBody = Strtran(m.lcBody, Chr(13) + Chr(10), [], 1, 1000, 1) lcBody = Strtran(m.lcBody, Chr(13), [], 1, 1000, 1) Endif lcBody = Strtran(m.lcBody, [,], [,], 1, 1000, 1) lcCommandLine = ["] + m.lcExePath + ["] + ; IIF(!Empty(m.lcProfile), [-profile "] + m.lcProfile + ["], []) + ; [ -compose ] + ; IIF(!Empty(This.cFrom), [from="] + This.cFrom + ["], []) + ; IIF(!Empty(This.cTo), [,to="] + This.cTo + ["], []) + ; IIF(!Empty(This.cCC), [,cc="] + This.cCC + ["], []) + ; IIF(!Empty(This.cBCC), [,bcc="] + This.cBCC + ["], []) + ; IIF(!Empty(This.cSubject), [,subject="] + This.cSubject + ["], []) + ; IIF(!Empty(m.lcBody), [,body="] + m.lcBody + ["], []) + ; IIF(!Empty(This.cAttachment), [,attachment='] + This.cAttachment + ['], []) If !'process.vcx' $ Lower(Set("Classlib")) Set Classlib To 'D:\ROA\ROAACNPRO\COMUN\clase\process.vcx' Additive Endif loRun = Createobject('api_apprun') If File (m.lcExePath) loRun.iccommandline = m.lcCommandLine If This.lEmailWait loRun.launchappandwait() Else loRun.launchapp() Endif Else This.EmailAddError('Thunderbird exe path ' + m.lcExePath + ' does not exist!') Endif Endproc && EmailSend Enddefine && ThunderbirdEmailCMD *----------------------------------------------------------- *!* oEmail.Send *!* > EmailCreateCfg *!* > EmailSetConfiguration *!* > EmailSetHeader *!* > EmailSetParameters *!* > EmailSend Define Class oCDO As oEmail Protected oMsg, oCfg * Message attributes oMsg = Null * Configuration object fields values oCfg = Null Procedure Init DoDefault() Local loEx As Exception This.lCanDisplayEmailWithoutInfo = .F. * Optional. Creates your own X-MAILER field in the header This.cXMailer = "VFP CDO 2000 mailer Ver 1.1.100 2010" Endproc *------------------------------------------------------- Procedure EmailCreateCfg Local loEx As Exception Try This.oMsg = Createobject("CDO.Message") This.oCfg = Createobject("CDO.Configuration") This.oMsg.Configuration = This.oCfg Catch To loEx This.AddError('ERROR: CDO Configuration could not be instantiated ' + Transform(loEx.ErrorNo) + ' ' + loEx.Message) Endtry Endproc *------------------------------------------------------- * Populate configuration object Procedure EmailSetConfiguration With This.oCfg.Fields * Send using SMTP server .Item(cdoSendUsingMethod) = cdoSendUsingPort .Item(cdoSMTPServer) = This.cServer .Item(cdoSMTPServerPort) = This.nServerPort .Item(cdoSMTPConnectionTimeout) = This.nConnectionTimeout .Item(cdoSMTPAuthenticate) = This.nAuthenticate If This.nAuthenticate = cdoBasic .Item(cdoSendUserName) = This.cUserName .Item(cdoSendPassword) = This.cPassword Endif .Item(cdoURLGetLatestVersion) = This.lURLGetLatestVersion .Item(cdoSMTPUseSSL) = This.lUseSSL .Update() Endwith Endproc *------------------------------------------------------- * Set mail header fields, if necessary. For now sets X-MAILER, if specified Procedure EmailSetHeader Local loHeader If Not Empty(This.cXMailer) loHeader = This.oMsg.Fields With loHeader .Item(cdoXMailer) = This.cXMailer .Update() Endwith Endif Endproc *------------------------------------------------------- Procedure EmailSetParameters * Fill message attributes Local lcMailHeader With This.oMsg .From = This.cFrom .ReplyTo = This.cReplyTo .To = This.cTo .CC = This.cCC .BCC = This.cBCC .Subject = This.cSubject * Create HTML body from external HTML (file, URL) If Not Empty(This.cHtmlBodyUrl) .CreateMHTMLBody(This.cHtmlBodyUrl) Endif * Send HTML body. Creates TextBody as well If Not Empty(This.cHtmlBody) .HtmlBody = This.cHtmlBody Endif * Send Text body. Could be different from HtmlBody, if any If Not Empty(This.cTextBody) .TextBody = This.cTextBody Endif If Not Empty(This.cCharset) If Not Empty(.HtmlBody) .HtmlBodyPart.Charset = This.cCharset Endif If Not Empty(.TextBody) .TextBodyPart.Charset = This.cCharset Endif Endif If Not Empty(This.cCharset) .BodyPart.Charset = This.cCharset Endif * Priority If Not Empty(This.cPriority) lcMailHeader = "urn:schemas:mailheader:" .Fields(lcMailHeader + "Priority") = Lower(This.cPriority) .Fields(lcMailHeader + "Importance") = Lower(This.cPriority) Do Case Case This.cPriority = "High" .Fields(lcMailHeader + "X-Priority") = 1 && 5=Low, 3=Normal, 1=High Case This.cPriority = "Normal" .Fields(lcMailHeader + "X-Priority") = 3 && 5=Low, 3=Normal, 1=High Case This.cPriority = "Low" .Fields(lcMailHeader + "X-Priority") = 5 && 5=Low, 3=Normal, 1=High Endcase .Fields.Update() Endif Endwith Endproc Procedure EmailAddAttachment Lparameters tcAttachment This.oMsg.AddAttachment(m.tcAttachment) Endproc *------------------------------ Procedure EmailClearMessage This.oMsg = Null This.oCfg = Null Endproc && EmailClearMessage *---------------------------------------------------- * Send message Procedure EmailSend This.oMsg.Send() Endproc Enddefine && oCDO Define Class oOutlook As oEmail oOutlook = Null oMailItem = Null Procedure Init DoDefault() Local loEx As Exception Try This.oOutlook = Createobject('outlook.application') Catch To loEx This.AddError('ERROR: OUTLOOK could not be instantiated ' + Transform(loEx.ErrorNo) + ' ' + loEx.Message) Endtry Endproc && Init ************************************ Procedure EmailCreateCfg Local loEx As Exception If !Isnull(This.oOutlook) Try * Create Mail Item This.oMailItem = This.oOutlook.CreateItem(0) Catch To loEx This.AddError('ERROR: OUTLOOK MailItem could not be instantiated ' + Transform(loEx.ErrorNo) + ' ' + loEx.Message) Endtry Endif Endproc && EmailCreateCfg ************************************ Procedure EmailSetParameters Local lcAttachment, lnAttachment With This.oMailItem .To = This.cTo .Subject = This.cSubject .CC = This.cCC .BCC = This.cBCC .BodyFormat = olFormatHTML .HtmlBody = This.cHtmlBody Endwith Endproc && EmailSetParameters Procedure EmailAddAttachment Lparameters tcAttachment This.oMailItem.Attachments.Add(m.tcAttachment) Endproc *------------------------------ Procedure EmailClearMessage This.oMailItem = Null Endproc && EmailClearMessage *------------------------------ Procedure EmailSend Local llEmailDisplay, llEmailPreview, loDefaultFolder, loMailItem, loNameSpace loMailItem = This.oMailItem * Display Sent folder only for the first email, so that the emails will get send If This.lFirstEmail loNameSpace = This.oOutlook.getnamespace('MAPI') loDefaultFolder = loNameSpace.GetDefaultFolder(olFolderSentMail) && SentMail loDefaultFolder.Display() Endif * Daca nu sunt completate toate informatiile arat emailul utilizatorului llEmailDisplay = This.lDisplayEmailWithoutInfo And (Empty(This.cTo) Or Empty(This.cSubject) Or (!This.lSendWithoutAttachments And Empty(This.EmailGetAttachmentsNumber()))) llEmailPreview = This.lEmailPreview && Daca nu arat fiecare email, il trimit automat If m.llEmailPreview Or m.llEmailDisplay loMailItem.Display Else loMailItem.Send Endif This.oMailItem = Null loMailItem = "" Endproc && EmailSend Enddefine &&oOutlook *--------------------------------- Define Class oMapi As oEmail snd = .F. rcp = .F. att = .F. *------------------------------------------------------- Procedure EmailCreateCfg Local loEx As Exception Try This.snd = Createobject("TRecipients") This.rcp = Createobject("TRecipients") This.att = Createobject("TAttachments") Catch To loEx This.AddError('ERROR: Mapi Configuration could not be instantiated ' + Transform(loEx.ErrorNo) + ' ' + loEx.Message) Endtry Endproc *------------------------------------------------------- Procedure EmailSetParameters Local lcRecipient, lnRecipient, lnRecipients This.AddSender(This.cFromName, This.cFrom) This.AddRecipient(This.cTo, MAPI_TO) This.AddRecipient(This.cCC, MAPI_CC) This.AddRecipient(This.cBCC, MAPI_BCC) Endproc Procedure AddSender(lcSndName, lcSndAddr) Local lnClass lnClass = MAPI_ORIG If Type("lcSndAddr") <> "C" lcSndAddr = lcSndName Endif This.snd.AppendItem(m.lnClass, lcSndName, lcSndAddr) Endproc && AddSender * --------------------------- * Fill To, CC, BCC Procedure AddRecipient Lparameters tcRecipientList, tnClass * tcRecipientpList: comma delimited list of recipients * tnClass: MAPI_TO, MAPI_CC, MAPI_BCC Local lcRecipientAddress, lcRecipientList, lcRecipientName, lnClass, lnRecipient, lnRecipients lnClass = Iif(Type('tnClass') = 'N', m.tnClass, MAPI_TO) lcRecipientList = Iif(Type('tcRecipientList') = 'C', m.tcRecipientList, '') lnRecipients = Getwordcount(m.lcRecipientList, [,]) For lnRecipient = 1 To m.lnRecipients lcRecipientAddress = Getwordnum(m.lcRecipientList, m.lnRecipient, [,]) lcRecipientName = m.lcRecipientAddress This.rcp.AppendItem(m.lnClass, m.lcRecipientName, m.lcRecipientAddress) Endfor Endproc && AddRecipient Procedure EmailAddAttachment Lparameters tcAttachment Return This.att.AppendItem(m.tcAttachment) Endproc Procedure EmailClearMessage This.rcp.ClearItems This.att.ClearItems Endproc && EmailClearMessage *---------------------------------------------------- * Send message Procedure EmailSend Local lcMapiMessage, loSubject, loBody, ii, lnResult, lcStoredPath loSubject = Createobject("PChar", This.cSubject) loBody = Createobject("PChar", This.cHtmlBody) lcStoredPath = Sys(5) + Sys(2003) * assembling MapiMessage structure lcMapiMessage = num2dword(0) + ; num2dword(loSubject.getAddr()) + num2dword(loBody.getAddr()) + ; num2dword(0) + num2dword(0) + num2dword(0) + num2dword(0) + ; num2dword(This.snd.getAddr()) + ; num2dword(This.rcp.ItemCount) + num2dword(This.rcp.getAddr()) + ; num2dword(This.att.ItemCount) + ; num2dword(Iif(This.att.ItemCount = 0, 0, This.att.getAddr())) Declare Integer MAPISendMail In mapi32; INTEGER lhSession, Integer ulUIParam, String @lpMessage, ; INTEGER flFlags, Integer ulReserved * Daca nu sunt completate toate informatiile arat emailul utilizatorului llEmailDisplay = This.lDisplayEmailWithoutInfo And (Empty(This.cTo) Or Empty(This.cSubject) Or (!This.lSendWithoutAttachments And Empty(This.EmailGetAttachmentsNumber()))) llEmailPreview = This.lEmailPreview Set Step On && Daca nu arat fiecare email, il trimit automat If m.llEmailPreview Or m.llEmailDisplay lnResult = MAPISendMail(0, 0, @lcMapiMessage, MAPI_DIALOG, 0) Else lnResult = MAPISendMail(0, 0, @lcMapiMessage, 0, 0) Endif If (m.lnResult <> 0) This.AddError("ERROR : Message not sent.") Endif Set Default To (lcStoredPath) Return (lnResult = 0) && sendmessage Endproc Enddefine && oMapi *------------------------------------------------------ * oMapi helper classes Define Class TRecipients As Custom && array of recipients ItemCount = 0 Dimen arrRecip[1] RcpsBuffer = .F. Procedure Destroy This.UnlockData This.ClearItems Procedure getAddr This.LockData Return This.RcpsBuffer.getAddr() Procedure LockData This.UnlockData Local lcBuffer, ii lcBuffer = "" For ii = 1 To This.ItemCount lcBuffer = lcBuffer + This.arrRecip[ii].GetValue() Endfor This.RcpsBuffer = Createobject("PChar", lcBuffer) Procedure UnlockData If Type("THIS.RcpsBuffer") = "O" This.RcpsBuffer.ReleaseString This.RcpsBuffer = .F. Endif Procedure AppendItem(lnClass, lcName, lcAddress) This.ItemCount = This.ItemCount + 1 Dimen This.arrRecip[THIS.ItemCount] This.arrRecip[THIS.ItemCount] = Createobject("TRecipient", lnClass, lcName, lcAddress) Procedure ClearItems Local ii For ii = 1 To This.ItemCount This.arrRecip[ii].ReleaseRecipient This.arrRecip[ii] = .F. Endfor This.ItemCount = 0 Dimen This.arrRecip[1] Enddefine && trecipients Define Class TRecipient As Custom RcpClass = 0 && 0-sender, 1-primary rec., 2-copy rec., 3-blind copy rec. RcpName = .F. RcpAddress = .F. RcpBuffer = "" Procedure Init(lnClass, lcName, lcAddress) This.InitRecipient(lnClass, lcName, lcAddress) Procedure Destroy This.ReleaseRecipient Procedure ReleaseRecipient If Type("THIS.RcpAddress") = "O" This.RcpAddress.ReleaseString This.RcpAddress = .F. Endif If Type("THIS.RcpName") = "O" This.RcpName.ReleaseString This.RcpName = .F. Endif Procedure InitRecipient(lnClass, lcName, lcAddress) This.ReleaseRecipient This.RcpName = Createobject("PChar", lcName) This.RcpAddress = Createobject("PChar", lcAddress) This.RcpBuffer = num2dword(0) + ; num2dword(lnClass) + ; num2dword(This.RcpName.getAddr()) + ; num2dword(This.RcpAddress.getAddr()) + ; num2dword(0) + num2dword(0) Function GetValue Return This.RcpBuffer Enddefine && trecipient Define Class TAttachments As Custom ItemCount = 0 Dimen arrAttach[1] AttsBuffer = .F. Procedure Destroy This.UnlockData This.ClearItems Procedure getAddr This.LockData Return This.AttsBuffer.getAddr() Procedure LockData This.UnlockData Local lcBuffer, ii lcBuffer = "" For ii = 1 To This.ItemCount lcBuffer = lcBuffer + This.arrAttach[ii].GetValue() Endfor This.AttsBuffer = Createobject("PChar", lcBuffer) Procedure UnlockData If Type("THIS.AttsBuffer") = "O" This.AttsBuffer.ReleaseString This.AttsBuffer = .F. Endif Procedure AppendItem(lcFilename) If File(lcFilename) This.ItemCount = This.ItemCount + 1 Dimen This.arrAttach[THIS.ItemCount] This.arrAttach[THIS.ItemCount] = ; CREATEOBJECT("TAttachment", lcFilename, This.ItemCount) Return Type("THIS.arrAttach[THIS.ItemCount]") = "O" Else Return .F. Endif Procedure ClearItems Local ii For ii = 1 To This.ItemCount This.arrAttach[ii].ReleaseAttachment This.arrAttach[ii] = .F. Endfor This.ItemCount = 0 Dimen This.arrAttach[1] Enddefine && tattachments Define Class TAttachment As Custom AttBuffer = "" AttFilename = .F. Procedure Init(lcFilename, nPosition) This.InitAttachment(m.lcFilename, m.nPosition) Procedure Destroy This.ReleaseAttachment Procedure InitAttachment(lcFilename, nPosition) *!* typedef struct { *!* ULONG ulReserved; *!* ULONG flFlags; *!* ULONG nPosition; *!* LPTSTR lpszPathName; *!* LPTSTR lpszFileName; *!* LPVOID lpFileType; *!* } MapiFileDesc, FAR *lpMapiFileDesc; This.ReleaseAttachment This.AttFilename = Createobject("PChar", lcFilename) This.AttBuffer = num2dword(0) + num2dword(0) + ; num2dword(m.nPosition) + ; num2dword(This.AttFilename.getAddr()) + ; num2dword(0) + num2dword(0) Procedure ReleaseAttachment If Type("THIS.AttFilename") = "O" This.AttFilename.ReleaseString This.AttFilename = .F. Endif Function GetValue Return This.AttBuffer Enddefine && tattachment Define Class PChar As Custom Protected Hmem Procedure Init(lcString) This.Hmem = 0 This.setValue(lcString) Procedure Destroy This.ReleaseString Function getAddr && returns a pointer to the string Return This.Hmem Function GetValue && returns string value Local lnSize, lcBuffer lnSize = This.getAllocSize() lcBuffer = Space(lnSize) If This.Hmem <> 0 Declare RtlMoveMemory In kernel32 As MemToStr; STRING @, Integer, Integer = MemToStr(@lcBuffer, This.Hmem, lnSize) Endif Return lcBuffer Function getAllocSize && returns allocated memory size (string length) Declare Integer GlobalSize In kernel32 Integer Hmem Return Iif(This.Hmem = 0, 0, GlobalSize(This.Hmem)) Procedure setValue(lcString) && assigns new string value #Define GMEM_FIXED 0 This.ReleaseString Declare Integer GlobalAlloc In kernel32 Integer, Integer Declare RtlMoveMemory In kernel32 As StrToMem; INTEGER, String @, Integer Local lnSize lcString = lcString + Chr(0) lnSize = Len(lcString) This.Hmem = GlobalAlloc(GMEM_FIXED, lnSize) If This.Hmem <> 0 = StrToMem(This.Hmem, @lcString, lnSize) Endif Procedure ReleaseString && releases allocated memory If This.Hmem <> 0 Declare Integer GlobalFree In kernel32 Integer = GlobalFree(This.Hmem) This.Hmem = 0 Endif Enddefine && pchar Function num2dword(lnValue) #Define m0 256 #Define m1 65536 #Define m2 16777216 Local b0, b1, b2, b3 b3 = Int(lnValue / m2) b2 = Int((lnValue - b3 * m2) / m1) b1 = Int((lnValue - b3 * m2 - b2 * m1) / m0) b0 = Mod(lnValue, m0) Return Chr(b0) + Chr(b1) + Chr(b2) + Chr(b3) Endfunc && num2dword Procedure WriteLog Lparameters tcMesaj lcLogFile = Addbs(Justpath(Sys(16,0))) + 'verificare_roris_ecluze.log' Strtofile(Transform(Datetime()) + ' ' + Transform(m.tcMesaj) + Chr(13), lcLogFile, 1) Endproc && WriteLog