romfast/comun
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
1f43c29955734f0aec9f05c328afbcedb767ccbe
comun/Programe/verificare_roris_ecluze.prg
Marius Mutu fab869990d Initial commit — sursa ROAACNPRO 
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-06-10 16:01:00 +03:00

1353 lines
37 KiB
Plaintext
Raw Blame History

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 <<IIF(!EMPTY(m.ldDataOra), 'extract(year from generation) >= ' + 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),'<br>' + 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), [<br/>], 1, 1000, 1)
lcBody = Strtran(m.lcBody, Chr(13), [<br/>], 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, [,], [&#44;], 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
Reference in New Issue View Git Blame Copy Permalink