1973 lines
54 KiB
Plaintext
1973 lines
54 KiB
Plaintext
#INCLUDE COMUN.H
|
|
|
|
*** ==================== LOG ============================ ***
|
|
Define Class Log As Custom
|
|
cLog = ''
|
|
cOutputFile = 'c:\log_' + Dtos(Date()) + '.txt'
|
|
lAdditive = .T.
|
|
*
|
|
Proc Init
|
|
Lparameters tcOutputfile, tlAdditive
|
|
|
|
If !Empty(tcOutputfile) And Type('tcOutputFile') = 'C'
|
|
This.cOutputFile = tcOutputfile
|
|
Endi
|
|
If Pcount() = 2 And Type('tlAdditive') = 'L'
|
|
This.lAdditive = tlAdditive
|
|
Endif
|
|
|
|
This.Log()
|
|
This.Log()
|
|
This.WRITELOG()
|
|
|
|
Endproc
|
|
*
|
|
Proc Log
|
|
Lparameters tcMessage, tcProgram
|
|
Local lcLog
|
|
If Pcount() = 0 Or Type('tcMessage') # 'C' Or Empty(tcMessage)
|
|
lcLog = CRLF
|
|
Else
|
|
lcLog = Ttoc(Datetime()) + ' ' + Sys(0) + CRLF + tcMessage + CRLF
|
|
Endi
|
|
This.cLog = This.cLog + lcLog
|
|
Endproc
|
|
*
|
|
Proc ResetLog
|
|
This.cLog = ''
|
|
Endproc
|
|
*
|
|
Proc WRITELOG
|
|
Lpar tcMessage, tcOutputfile, tlAdditive
|
|
Local lcOutputfile, llAdditive, lcLog, lcLogDirectory
|
|
If !Empty(tcOutputfile) And Type('tcOutputFile') = 'C'
|
|
lcOutputfile = tcOutputfile
|
|
Else
|
|
lcOutputfile = This.cOutputFile
|
|
Endi
|
|
If Pcount() < 3 Or Type('tlAdditive') # 'L'
|
|
llAdditive = This.lAdditive
|
|
Else
|
|
llAdditive = tlAdditive
|
|
Endi
|
|
If Type('tcMessage') = 'C'
|
|
If Empty(tcMessage)
|
|
lcLog = CRLF
|
|
Else
|
|
lcLog = Ttoc(Datetime()) + ' ' + Sys(0) + CRLF + tcMessage + CRLF
|
|
Endi
|
|
Else
|
|
lcLog = This.cLog
|
|
Endi
|
|
If !Empty(lcOutputfile)
|
|
lcLogDirectory = Justpath(lcOutputfile)
|
|
If !Directory(lcLogDirectory)
|
|
Md (lcLogDirectory)
|
|
Endif
|
|
Strtofile(lcLog, lcOutputfile, llAdditive)
|
|
Endi
|
|
Endproc
|
|
*
|
|
Enddefine && LOG
|
|
*
|
|
|
|
|
|
Define Class oexecutor As Custom
|
|
nHandle = 0
|
|
cSql = ''
|
|
cSchema = ''
|
|
cCursor = ''
|
|
nSucces = 0
|
|
cEroare = ''
|
|
nEroare = 0
|
|
cTime = ''
|
|
lReconnect = .T. && cred ca trebuie setat pe .F. inainte de o serie de proceduri executate cu tranzactie manuala
|
|
lShowError = .F.
|
|
lQuitOnError = .F.
|
|
lError = .F.
|
|
cErrorMessage = ""
|
|
lApplicationError = .F. && eroare generata de RAISE_APPLICATION_ERROR - afisez doar textul erorii.
|
|
|
|
Declare aEroare[1]
|
|
|
|
|
|
* PROCEDURE INIT( tnHandle, tcSql, tcCursor )
|
|
* Date : 06/10/2004, 12:18:21
|
|
* author : marius.mutu
|
|
* description:
|
|
|
|
****** PARAMETER BLOCK **************
|
|
* Parameters : 3
|
|
* Parameter 1:
|
|
* Parameter 2:
|
|
* Parameter 3:
|
|
*
|
|
******************************************* INCEPUT:INIT *******************************************
|
|
Procedure Init
|
|
Lparameters tnHandle, tcSql, tcCursor
|
|
|
|
|
|
If Empty(tnHandle)
|
|
If Type('gnHandle') = 'N'
|
|
This.nHandle = gnHandle
|
|
Endif
|
|
Else
|
|
This.nHandle = tnHandle
|
|
Endif
|
|
|
|
Endproc
|
|
******************************************* SFARSIT: INIT *******************************************
|
|
|
|
|
|
* PROCEDURE oExecute( tcSql, tcCursor,tlProgress, tnHandle )
|
|
* Date : 06/10/2004, 12:16:11
|
|
* author : marius.mutu
|
|
* description:
|
|
|
|
****** PARAMETER BLOCK **************
|
|
* Parameters : 3
|
|
* Parameter 1:
|
|
* Parameter 2:
|
|
* Parameter 3:
|
|
*
|
|
******************************************* INCEPUT:oExecute *******************************************
|
|
Procedure oExecute(toHash)
|
|
&& tcSql, tcCursor, tnHandle
|
|
Local lnHandle, lcSql, lcSchema, lcCursor, lcTempCursor, lnSucces, laEroare, lcEroare, llReconnect, lnTip, lcTip, lcEroare, lShowError
|
|
Local loEx As Exception
|
|
|
|
Declare laEroare[1]
|
|
lcEroare = ''
|
|
|
|
Local lnTip
|
|
lnTip = 0
|
|
|
|
This.Oreset()
|
|
|
|
lcSql = Iif(toHash.HasProperty("cSql"), toHash.GetValue("cSql"), Upper(This.cSql))
|
|
lcSchema = Iif(toHash.HasProperty("cSchema"), toHash.GetValue("cSchema"), Upper(This.cSchema))
|
|
lcCursor = Iif(toHash.HasProperty("cCursor"), toHash.GetValue("cCursor"), Upper(This.cCursor))
|
|
lnHandle = Iif(toHash.HasProperty("nHandle"), toHash.GetValue("nHandle"), goConn.GetHandle())
|
|
lShowError = Iif(toHash.HasProperty("lShowError"), toHash.GetValue("lShowError"), .T.) && daca se afiseaza mesajul de eroare
|
|
|
|
* Strtofile(lcSql+Chr(13)+Chr(10),Addbs(Justpath(Sys(16,0)))+"log.txt",.T.)
|
|
&& DACA AM TRANZACTIE MANUALA NU FAC RECONNECT
|
|
If SQLGetprop(lnHandle,"Transactions") = 2 && TRANZACTIE MANUALA
|
|
llReconnect = .F.
|
|
Else
|
|
llReconnect = .T.
|
|
Endif
|
|
|
|
lnTip = Iif('ROLLBACK'$lcSql Or 'COMMIT'$lcSql,1,0) && daca ROLLBACK SAU COMMIT TIP = 1, ALTFEL 0
|
|
|
|
Do Case
|
|
Case lnTip = 0
|
|
|
|
lnSucces = -1
|
|
Do While .T.
|
|
*!* daca exista SCHEMA => folosesc CURSORADAPTER (ar trebui sa folosesc mereu???)
|
|
If !Empty(lcSchema)
|
|
Local loC As CursorAdapter
|
|
loC = Createobject("cursoradapter")
|
|
loC.DataSourceType ="ODBC"
|
|
loC.Datasource = lnHandle
|
|
loC.SelectCmd = lcSql
|
|
loC.CursorSchema = lcSchema
|
|
loC.Alias = lcCursor
|
|
Use In (Select(lcCursor))
|
|
llSucces = loC.CursorFill(!Empty(lcSchema))
|
|
If llSucces
|
|
loC.CursorDetach()
|
|
Endif
|
|
lnSucces = Iif(llSucces, CT_SUCCES, CT_INSUCCES)
|
|
Else
|
|
*!* PENTRU SQLEXEC ASINCRON - DO WHILE PANA SE TERMINA EXECUTIA
|
|
Do While .T.
|
|
Try
|
|
lnSucces = SQLExec(lnHandle, lcSql, lcCursor)
|
|
Catch To loEx
|
|
lnSucces = CT_INSUCCES
|
|
Endtry
|
|
|
|
If lnSucces = 0
|
|
*
|
|
Else
|
|
Exit
|
|
Endif
|
|
Enddo
|
|
|
|
lnSucces = Iif(lnSucces > 0, CT_SUCCES, CT_INSUCCES)
|
|
Endif
|
|
|
|
If lnSucces = CT_SUCCES
|
|
If Used(lcCursor)
|
|
lcTempCursor = Sys(2015)
|
|
Use Dbf(lcCursor) In 0 Again Shared Alias (lcTempCursor)
|
|
Use In (lcCursor)
|
|
Use Dbf(lcTempCursor) In 0 Again Alias (lcCursor)
|
|
Use In (lcTempCursor)
|
|
Endif
|
|
Exit
|
|
Else
|
|
Release laEroare
|
|
Declare laEroare(1)
|
|
lnEroare1 = 0
|
|
lnEroare2 = 0
|
|
lcTextEroare = []
|
|
lnHandle = 0
|
|
llEroare = .F.
|
|
|
|
Aerror(laEroare)
|
|
If Alen(laEroare) > 1
|
|
lnEroare1 = laEroare[1]
|
|
lnEroare2 = laEroare[5]
|
|
lcTextEroare = laEroare[3]
|
|
This.cEroare = lcTextEroare
|
|
lcTextEroare = This.oPrelucrareEroare()
|
|
lnHandle = laEroare[6]
|
|
llEroare = .T.
|
|
Endif
|
|
|
|
goApp.ProcessError(GetHash("lShowError=>" + Iif(lShowError, "1", "0") + "??lApplicationError=>" + Iif(This.lApplicationError, "1", "0") + "??cError=> " + lcTextEroare + "??cUserMessage=>" + lcSql))
|
|
|
|
This.lError = goApp.HasError()
|
|
This.cErrorMessage = goApp.GetError()
|
|
This.nSucces = lnSucces
|
|
This.cEroare = This.cErrorMessage
|
|
This.nEroare = Iif(Alen(laEroare)>=5,laEroare[5],0)
|
|
|
|
|
|
If llReconnect And lnEroare1 = 1526 And Inlist(lnEroare2,12152,3114,12560) && 12512 = TNS: UNABLE TO SEND BREAK MESSAGE; 3114 = NOT CONNECTED TO ORACLE; 12560 = PROTOCOL ADAPTER ERROR
|
|
Do While lnRaspuns = .T. && conectare
|
|
lnRaspuns = AMESSAGEBOX('Eroare de conectare.' + Chr(13) + lcTextEroare + Chr(13) + 'Doriti reconectare?',4+32,'Eroare') && retry = 4; cancel = 2
|
|
If lnRaspuns = 6
|
|
|
|
lnSucces = goConn.Connect()
|
|
|
|
If lnSucces = CT_INSUCCES
|
|
|
|
Release laEroare
|
|
Loop
|
|
Else
|
|
Exit
|
|
Endif
|
|
Else
|
|
&& daca nu doresc conectare atunci ies din program
|
|
Return To Master
|
|
Endif && lnRaspuns = 6
|
|
Enddo && conectare
|
|
|
|
Loop && daca am iesit cu un handle valid intru din nou in loop si execut din nou comanda
|
|
Endif && lnEroare1 = 1526 AND INLIST(lnEroare2,12152,3114,12560)
|
|
|
|
Exit
|
|
Endif && lnSucces = CT_INSUCCES
|
|
|
|
Enddo && .T.
|
|
|
|
Case lnTip = 1
|
|
If 'ROLLBACK'$lcSql
|
|
lnSucces = Sqlrollback(lnHandle)
|
|
Else
|
|
lnSucces = Sqlcommit(lnHandle)
|
|
Endif
|
|
|
|
If lnSucces < 0
|
|
goApp.ProcessError()
|
|
This.lError = goApp.HasError()
|
|
This.cErrorMessage = goApp.GetError()
|
|
This.nSucces = lnSucces
|
|
This.cEroare = This.cErrorMessage
|
|
This.nEroare = Iif(Alen(laEroare)>=5,laEroare[5],0)
|
|
Endif
|
|
Endcase
|
|
|
|
&& loghez sql
|
|
If lnSucces > 0
|
|
goApp.Log(lcSql)
|
|
ELSE
|
|
SET STEP ON
|
|
Endif
|
|
Return Iif(lnSucces > 0, CT_SUCCES, CT_INSUCCES)
|
|
|
|
Endproc
|
|
******************************************* SFARSIT: oExecute *******************************************
|
|
|
|
*!* salveaza rezultatul unei functii in variabila data ca referinta
|
|
*!* intoarce SUCCES = (1,-1)
|
|
*!* lnSucces = oFunction2Value("MyFunction(MyParam1, MyParam2)", @pnReturnValue)
|
|
Function oFunction2Value
|
|
Lparameters tcFunction, tuRetValue
|
|
|
|
lcSql = "select " + tcFunction + " as retvalue from dual"
|
|
lcCursor = Sys(2015)
|
|
lcField = lcCursor + ".retvalue"
|
|
|
|
lnSucces = This.oExecute(lcSql, lcCursor)
|
|
|
|
If lnSucces = CT_SUCCES
|
|
tuRetValue = Evaluate(lcField)
|
|
If Used(lcCursor)
|
|
Use In (lcCursor)
|
|
Endif
|
|
Endif
|
|
|
|
Return lnSucces
|
|
|
|
Endfunc && oFunction2Value
|
|
******************************************* SFARSIT: oFunction2Value *******************************************
|
|
|
|
*!* salveaza rezultatul unui select in variabila data ca referinta
|
|
*!* daca se intorc mai multe randuri - eroare
|
|
*!* intoarce SUCCES = (1,-1)
|
|
*!* lnSucces = oSelect2Value("Select sum(cantitate) from tabel where conditie", @pnReturnValue)
|
|
Function oSelect2Value
|
|
Lparameters tcSql, tuRetValue
|
|
|
|
Local lcSelect, lcSql, lcCursor, lcField, lnSucces
|
|
|
|
lcSelect = Select()
|
|
lcSql = m.tcSql
|
|
lcCursor = Sys(2015)
|
|
|
|
lnSucces = This.oExecute(GetHash('cSql=>' + m.lcSql + '??cCursor=>' + m.lcCursor))
|
|
|
|
If m.lnSucces = CT_SUCCES
|
|
If Reccount(lcCursor) > 1
|
|
goApp.ProcessError(GetHash("cUserMessage=>Au rezultat mai multe valori. Se astepta o singura valoare."))
|
|
lnSucces = CT_INSUCES
|
|
Else
|
|
lcField = lcCursor + '.' + Field(1)
|
|
tuRetValue = Evaluate(lcField)
|
|
Endif
|
|
Use In (SELECT(m.lcCursor))
|
|
Endif
|
|
|
|
Select (m.lcSelect)
|
|
Return lnSucces
|
|
Endfunc &&oSelect2Value
|
|
******************************************* SFARSIT: oFunction2Value *******************************************
|
|
|
|
******************************************* INCEPUT: oPrelucrareEroare *******************************************
|
|
&& Prelucreaza mesajul de eroare : daca este intre ORA-20000 si ORA-20999 atunci afiseaza doar textul erorii
|
|
Function oPrelucrareEroare
|
|
Local lcTextEroare
|
|
lcTextEroare = This.cEroare
|
|
|
|
If Like('*ORA-20???:*',lcTextEroare)
|
|
This.lApplicationError = .T.
|
|
|
|
lnPozi=At("ORA-20",lcTextEroare)+11
|
|
lnPozf=At("ORA",lcTextEroare,2)
|
|
lcTextEroare=Substr(lcTextEroare,lnPozi,lnPozf-lnPozi)
|
|
*!* ELSE
|
|
*!* lnPozf=At("ORA-",lcTextEroare,3)
|
|
*!* lcTextEroare=Substr(lcTextEroare,1,lnPozf-1)+[...]
|
|
Endif
|
|
Return lcTextEroare
|
|
Endfunc && oPrelucrareEroare
|
|
******************************************* SFARSIT: oPrelucrareEroare *******************************************
|
|
* PROCEDURE oReset( )
|
|
* Date : 06/10/2004, 12:21:06
|
|
* author : marius.mutu
|
|
* description:
|
|
|
|
****** PARAMETER BLOCK **************
|
|
* Parameters : 0
|
|
*
|
|
******************************************* INCEPUT:oReset *******************************************
|
|
Procedure Oreset( )
|
|
With This
|
|
.aEroare = .F.
|
|
.nSucces = 0
|
|
.cSql = ''
|
|
.cCursor = ''
|
|
Endwith
|
|
Endproc
|
|
******************************************* SFARSIT: oReset *******************************************
|
|
|
|
Enddefine && oExecutor
|
|
|
|
|
|
|
|
|
|
*** oConn ===========================================================================================
|
|
Define Class oConn As Custom
|
|
|
|
cHost = ''
|
|
cUser = ''
|
|
cPassword = ''
|
|
cConnectionString = ''
|
|
nHandle = 0
|
|
cEroare = ''
|
|
Declare aEroare[7]
|
|
lShowError = .F.
|
|
lReconnect = .F. && Daca llReconnect = .T. se apeleaza InitSesiune din oInit_Optiuni.prg
|
|
lError = .F.
|
|
cErrorMessage = ''
|
|
|
|
*** IsConnected ===========================================================================================
|
|
Function IsConnected
|
|
Local llConnected
|
|
llConnected = This.nHandle > 0
|
|
Return llConnected
|
|
Endfunc && IsConnected
|
|
|
|
*** GetHandle ===========================================================================================
|
|
Function GetHandle
|
|
Return This.nHandle
|
|
Endfunc && GetHandle
|
|
|
|
*** Connect ===========================================================================================
|
|
Procedure Connect
|
|
Lparameters tcHost, tcUser, tcPassword, tlReconnect
|
|
|
|
*!* tlReconnect = .T. daca se apeleaza connect la reconectare (atunci se apeleaza si InitSesiune())
|
|
Local lnSucces, laEroare, lcString, lcHost, lcUser, lcPassword, lcSql, lcConnectionString
|
|
Local loEx As Exception
|
|
|
|
If Pcount() < 3 Or Type('tcHost') # 'C' Or Type('tcUser') # 'C' Or Type('tcPassword') # 'C'
|
|
This.cHost = goApp.oSettings.GetValue("HOST")
|
|
This.cUser = goApp.oSettings.GetValue("USER")
|
|
This.cPassword = goApp.oSettings.GetValue("PASSWORD")
|
|
This.cConnectionString = goApp.oSettings.GetValue("CONNECTIONSTRING")
|
|
Else
|
|
This.cHost = tcHost
|
|
This.cUser = tcUser
|
|
This.cPassword = tcPassword
|
|
Endif
|
|
|
|
lcHost = This.cHost
|
|
lcUser = This.cUser
|
|
lcPassword = This.cPassword
|
|
lcConnectionString = This.cConnectionString
|
|
|
|
If Pcount() < 4 Or Type('tlReconnect') # 'L'
|
|
llReconnect = This.lReconnect
|
|
Else
|
|
llReconnect = tlReconnect
|
|
Endif
|
|
|
|
SQLSetprop(0,"DispLogin",3)
|
|
If Empty(m.lcConnectionString)
|
|
lcString="dsn="+Alltrim(lcHost)+";Uid="+Alltrim(lcUser)+";Pwd="+Alltrim(lcPassword)+";"
|
|
Else
|
|
lcString = m.lcConnectionString
|
|
Endif
|
|
lcString = Textmerge(m.lcString)
|
|
|
|
If !This.IsConnected()
|
|
Try
|
|
This.nHandle = Sqlstringconnect(lcString)
|
|
Catch To loEx
|
|
This.nHandle = -1
|
|
This.ProcessError(loEx.ErrorNo, loEx.Procedure, loEx.Lineno)
|
|
Endtry
|
|
goApp.Log("Conectare, Handle = " + Alltrim(Transform(This.nHandle)))
|
|
Endif
|
|
|
|
If Type('gnHandle') = 'N'
|
|
gnHandle = This.nHandle
|
|
Endif
|
|
|
|
If Type('goExecutor') = 'O'
|
|
goExecutor.nHandle = This.nHandle
|
|
Endif
|
|
|
|
If This.IsConnected()
|
|
lnSucces = CT_SUCCES
|
|
|
|
*** SETARI SESIUNE DUPA CONECTARE
|
|
This.postConn()
|
|
|
|
*!* IF llReconnect
|
|
*!* lnSucces = InitSesiune() && IN oInit_Optiuni.prg
|
|
*!* ENDIF
|
|
Else
|
|
lnSucces = CT_INSUCCES
|
|
This.ProcessError()
|
|
Endif
|
|
|
|
Return lnSucces
|
|
|
|
Endproc && Connect
|
|
*** END Connect ===========================================================================================
|
|
|
|
*** Disconnect ===========================================================================================
|
|
Procedure Disconnect
|
|
|
|
Local loEx As Exception, lnSucces, lnHandle, llException
|
|
lnSucces = CT_SUCCES
|
|
llException = .F.
|
|
|
|
If This.IsConnected()
|
|
lnHandle = This.GetHandle()
|
|
*!* TRY
|
|
lnSucces = SQLDisconnect(lnHandle)
|
|
lnSucces = Iif(lnSucces > 0, CT_SUCCES, CT_INSUCCES)
|
|
*!* CATCH TO loEx
|
|
*!* lnSucces = CT_INSUCCES
|
|
*!* llException = .T.
|
|
*!* THIS.ProcessError(loEx.ERRORNO, loEx.PROCEDURE, loEx.LINENO)
|
|
*!* ENDTRY
|
|
|
|
If lnSucces = CT_INSUCCES
|
|
&& daca am prins exceptia s-a inregistrat deja eroarea
|
|
If !llException
|
|
This.ProcessError()
|
|
Endif
|
|
Else
|
|
This.nHandle = -1
|
|
|
|
If Type('gnHandle') = 'N'
|
|
gnHandle = This.nHandle
|
|
Endif
|
|
|
|
If Type('goExecutor') = 'O'
|
|
goExecutor.nHandle = This.nHandle
|
|
Endif
|
|
|
|
Endif
|
|
Endif
|
|
|
|
If lnSucces > 0
|
|
goApp.Log("Deconectare, Handle = " + Alltrim(Transform(m.lnHandle)))
|
|
Endif
|
|
|
|
Return Iif(lnSucces > 0, CT_SUCCES, CT_INSUCCES)
|
|
|
|
Endproc &&
|
|
*** END Disconnect ===========================================================================================
|
|
|
|
*!*=================================================================
|
|
Procedure Destroy
|
|
This.Disconnect()
|
|
Endproc && DESTROY
|
|
|
|
*!*=================================================================
|
|
Procedure Error(nError,cMethod,nLine)
|
|
This.ProcessError(nError,cMethod,nLine)
|
|
Endproc && ERROR
|
|
|
|
*** ProcessError ===========================================================================================
|
|
Procedure ProcessError
|
|
Lparameters nError,cMethod,nLine
|
|
|
|
|
|
Local loHash
|
|
loHash = GetHash()
|
|
If Pcount() = 3
|
|
loHash.SetValue("nError", nError)
|
|
loHash.SetValue("cMethod", cMethod)
|
|
loHash.SetValue("nLine", nLine)
|
|
Endif
|
|
|
|
If Type('goApp') = 'O'
|
|
goApp.ProcessError(loHash)
|
|
|
|
This.cErrorMessage = goApp.GetError()
|
|
This.lError = goApp.HasError()
|
|
Endif
|
|
|
|
Endproc && ProcessError
|
|
*** END ProcessError ===========================================================================================
|
|
|
|
*** postConn ===========================================================================================
|
|
Procedure postConn
|
|
*** PUNCT ZECIMAL
|
|
Local lcSql, loHash, lnSucces
|
|
lnSucces = CT_SUCCES
|
|
If goApp.oSettings.GetValue("database") = 'ORACLE'
|
|
lcSql=[ALTER SESSION SET NLS_NUMERIC_CHARACTERS = ".,"]
|
|
loHash= GetHash("cSql=>" + lcSql)
|
|
lnSucces = goExecutor.oExecute(loHash)
|
|
Endif
|
|
Return lnSucces
|
|
|
|
Endproc && postConn
|
|
*** END postConn ===========================================================================================
|
|
|
|
|
|
Enddefine && oConn
|
|
*** END oConn ===========================================================================================
|
|
|
|
* ===================== GetHash ====================================
|
|
* INTOARCE UN OBIECT DE TIP HASH CREAT DIN tcPropertyValueList
|
|
*!* loHash = GetHash([cselect=>select id, name from test??cwhere=>id=pnId??corder=>name])
|
|
*!* lnMembers = AMEMBERS(laMembers, loHash)
|
|
*!* FOR i = 1 TO lnMembers
|
|
*!* MESSAGEBOX(loHash.&laMembers(i))
|
|
*!* ENDFOR
|
|
* ==================================================================
|
|
Function GetHash
|
|
Lparameters tcPropertyValueList
|
|
|
|
Local loHash
|
|
|
|
loHash = Createobject("MyHash", tcPropertyValueList)
|
|
Return loHash
|
|
|
|
Endfunc
|
|
|
|
|
|
Define Class MyHash As Collection
|
|
|
|
*!* sir "proprietate1=>valoare1??proprietate2=>valoare2"
|
|
*!* genereaza proprietati si valori din sirul initial
|
|
Procedure Init
|
|
Lparameters tcPropertyValueList
|
|
|
|
Local i, lnProperties, lcPropertyValue, lcValue, luValue
|
|
Local lnPos
|
|
Declare laLinii[1]
|
|
|
|
&& tcPropertyValueList = [cselect =>ala bala portocala??cfiltru=>un filtru - atentie la spatiile din stanga valorii]
|
|
If Type('tcPropertyValueList') = 'C' And !Empty(tcPropertyValueList)
|
|
|
|
lnProperties = Alines(laLinii,tcPropertyValueList,4,'??')
|
|
For i = 1 To lnProperties
|
|
lcPropertyValue = Alltrim(laLinii[i])
|
|
lnPos = At('=>', lcPropertyValue)
|
|
If lnPos > 0
|
|
lcProperty = Left(lcPropertyValue,lnPos - 1)
|
|
lcValue = Substr(lcPropertyValue, lnPos + 2)
|
|
luValue = This.GetDefaultValue(lcProperty, lcValue)
|
|
This.SetValue(lcProperty, luValue)
|
|
Endif
|
|
Endfor
|
|
|
|
Endif
|
|
Endproc && INIT
|
|
|
|
*!* Seteaza valoarea unei proprietati daca exista sau adauga proprietatea, si intoarce valoarea
|
|
Procedure SetValue
|
|
Lparameters tcProperty, tuValue
|
|
|
|
Local loC As Collection
|
|
loC = This
|
|
|
|
If Type('loc(tcProperty)') <> 'U'
|
|
loC(tcProperty) = tuValue
|
|
Else
|
|
loC.Add(tuValue, tcProperty)
|
|
Endif
|
|
|
|
Return loC(tcProperty)
|
|
|
|
Endproc && SetValue
|
|
|
|
*!* Intoarce valoarea unei proprietati daca exista, altfel valoarea empty() corespunzator tipului proprietatii
|
|
Function GetValue
|
|
Lparameters tcProperty
|
|
|
|
Local luValue
|
|
Local loC As Collection
|
|
loC = This
|
|
|
|
If Type('loC(tcProperty)') <> 'U'
|
|
luValue = loC(tcProperty)
|
|
Else
|
|
luValue = loC.GetDefaultValue(tcProperty)
|
|
Endif
|
|
Return luValue
|
|
|
|
Endfunc && GetValue
|
|
|
|
*!* Intoarce valoarea empty() a unei proprietati dupa tip = prima litera din numele proprietatii daca nu primeste decat tcProperty
|
|
*!* Converteste tcValue la tipul variabilei tcProperty daca tcValue e primit ca parametru
|
|
Function GetDefaultValue
|
|
Lparameters tcProperty, tcValue
|
|
|
|
Local lcType, luValue
|
|
luValue = ""
|
|
lcType = Upper(Left(tcProperty,1))
|
|
llEmptyValue = Iif(Pcount() = 1, .T., .F.)
|
|
|
|
Do Case
|
|
Case lcType $ "CM"
|
|
luValue = Iif(llEmptyValue, '', tcValue)
|
|
Case lcType $ "NIF"
|
|
luValue = Iif(llEmptyValue, 0, Val(tcValue))
|
|
Case lcType = "T"
|
|
luValue = Iif(llEmptyValue, Dtot({}), Ctot(tcValue))
|
|
Case lcType = "D"
|
|
luValue = Iif(llEmptyValue, {}, Ctod(tcValue))
|
|
Case lcType = "L"
|
|
luValue = Iif(llEmptyValue, .F., Iif(tcValue = "1" Or Upper(tcValue) = "T" Or Upper(tcValue) = '.T.' Or Upper(tcValue) = 'YES', .T., .F.))
|
|
Otherwise
|
|
luValue = ""
|
|
Endcase
|
|
|
|
Return luValue
|
|
Endfunc && GetDefaultValue
|
|
|
|
*!* Intoarce .T. daca exista proprietatea
|
|
Function HasProperty
|
|
Lparameters tcProperty
|
|
|
|
Local llReturn
|
|
Local loC As Collection
|
|
loC = This
|
|
llReturn = .F.
|
|
|
|
If Type('loC(tcProperty)') <> 'U'
|
|
llReturn = .T.
|
|
Endif
|
|
|
|
Return llReturn
|
|
|
|
Endfunc && HasProperty
|
|
|
|
Enddefine
|
|
* ===================== MyHash ====================================
|
|
* OBIECT EMULARE HASH
|
|
* loHash = GetHash([cselect=>select id, name from test??cwhere=>id=pnId??corder=>name])
|
|
* ==================================================================
|
|
Define Class MyHashOld As Custom
|
|
|
|
|
|
Procedure ReadMe
|
|
If .F.
|
|
Local loHash
|
|
loHash = Createobject("MyHash", [cselect=>select id, name from test??cwhere=>id=pnId??corder=>name])
|
|
Endif
|
|
Endproc && readme
|
|
|
|
*!* sir "proprietate1=>valoare1??proprietate2=>valoare2"
|
|
*!* genereaza proprietati si valori din sirul initial
|
|
Procedure Init
|
|
Lparameters tcPropertyValueList
|
|
|
|
Local i, lnProperties, lcPropertyValue, lcValue, luValue
|
|
Local lnPos
|
|
Declare laLinii[1]
|
|
|
|
&& tcPropertyValueList = [cselect =>ala bala portocala??cfiltru=>un filtru - atentie la spatiile din stanga valorii]
|
|
If Type('tcPropertyValueList') = 'C' And !Empty(tcPropertyValueList)
|
|
*!* lnProperties = GETWORDCOUNT(tcPropertyValueList,'??')
|
|
*!* FOR i = 1 TO lnProperties
|
|
*!* lcPropertyValue = ALLTRIM(GETWORDNUM(tcPropertyValueList,i,'??'))
|
|
*!* IF AT('=>', lcPropertyValue) > 0
|
|
*!* lcProperty = GETWORDNUM(lcPropertyValue, 1, '=>')
|
|
*!* lcValue = GETWORDNUM(lcPropertyValue, 2, '=>')
|
|
*!* luValue = THIS.GetDefaultValue(lcProperty, lcValue)
|
|
*!* THIS.SetValue(lcProperty, luValue)
|
|
*!* ENDIF
|
|
*!* ENDFOR
|
|
lnProperties = Alines(laLinii,tcPropertyValueList,4,'??')
|
|
For i = 1 To lnProperties
|
|
lcPropertyValue = Alltrim(laLinii[i])
|
|
lnPos = At('=>', lcPropertyValue)
|
|
If lnPos > 0
|
|
lcProperty = Left(lcPropertyValue,lnPos - 1)
|
|
lcValue = Substr(lcPropertyValue, lnPos + 2)
|
|
luValue = This.GetDefaultValue(lcProperty, lcValue)
|
|
This.SetValue(lcProperty, luValue)
|
|
Endif
|
|
Endfor
|
|
|
|
Endif
|
|
Endproc && INIT
|
|
|
|
*!* Seteaza valoarea unei proprietati daca exista sau adauga proprietatea, si intoarce valoarea
|
|
Procedure SetValue
|
|
Lparameters tcProperty, tuValue
|
|
|
|
If Type('THIS.&tcProperty') <> 'U'
|
|
This.&tcProperty = tuValue
|
|
Else
|
|
This.AddProperty(tcProperty, tuValue)
|
|
Endif
|
|
|
|
Return This.&tcProperty
|
|
|
|
Endproc && SetValue
|
|
|
|
*!* Intoarce valoarea unei proprietati daca exista, altfel valoarea empty() corespunzator tipului proprietatii
|
|
Function GetValue
|
|
Lparameters tcProperty
|
|
|
|
Local lcProperty, luValue
|
|
lcProperty = 'THIS.' + tcProperty
|
|
|
|
If Type('THIS.&tcProperty') <> 'U'
|
|
luValue = This.&tcProperty
|
|
Else
|
|
luValue = This.GetDefaultValue(tcProperty)
|
|
Endif
|
|
Return luValue
|
|
|
|
Endfunc && GetValue
|
|
|
|
*!* Intoarce valoarea empty() a unei proprietati dupa tip = prima litera din numele proprietatii daca nu primeste decat tcProperty
|
|
*!* Converteste tcValue la tipul variabilei tcProperty daca tcValue e primit ca parametru
|
|
Function GetDefaultValue
|
|
Lparameters tcProperty, tcValue
|
|
|
|
Local lcType, luValue
|
|
luValue = ""
|
|
lcType = Upper(Left(tcProperty,1))
|
|
llEmptyValue = Iif(Pcount() = 1, .T., .F.)
|
|
|
|
Do Case
|
|
Case lcType $ "CM"
|
|
luValue = Iif(llEmptyValue, '', tcValue)
|
|
Case lcType $ "NIF"
|
|
luValue = Iif(llEmptyValue, 0, Val(tcValue))
|
|
Case lcType = "T"
|
|
luValue = Iif(llEmptyValue, Dtot({}), Ctot(tcValue))
|
|
Case lcType = "D"
|
|
luValue = Iif(llEmptyValue, {}, Ctod(tcValue))
|
|
Case lcType = "L"
|
|
luValue = Iif(llEmptyValue, .F., Iif(tcValue = "1" Or Upper(tcValue) = "T" Or Upper(tcValue) = '.T.' Or Upper(tcValue) = 'YES', .T., .F.))
|
|
Otherwise
|
|
luValue = ""
|
|
Endcase
|
|
|
|
Return luValue
|
|
Endfunc && GetDefaultValue
|
|
|
|
*!* Intoarce .T. daca exista proprietatea
|
|
Function HasProperty
|
|
Lparameters tcProperty
|
|
|
|
Local lcProperty, llReturn
|
|
lcProperty = 'THIS.' + tcProperty
|
|
llReturn = .F.
|
|
|
|
If Type('THIS.&tcProperty') <> 'U'
|
|
llReturn = .T.
|
|
Endif
|
|
|
|
Return llReturn
|
|
|
|
Endfunc && HasProperty
|
|
|
|
Enddefine && Hash
|
|
|
|
|
|
|
|
***---------------------------------
|
|
Function AMESSAGEBOX
|
|
Lparameters tcMessage, tnDialogBoxType, tcTitle, tcFont, tnTimeOut ,tnTimeoutValue
|
|
|
|
Local loMessage, lnReturn, lcMessageboxForm
|
|
|
|
*!* *!* LOGHEZ ERORILE
|
|
*!* IF TYPE('goLog') = 'O' AND 'ERROR'$UPPER(tcMessage) OR 'EROARE'$UPPER(tcMessage) OR 'ORA-'$UPPER(tcMessage)
|
|
*!* goLog.LOG(tcMessage,PROGRAM())
|
|
*!* ENDIF
|
|
If Type('tnDialogBoxType') # 'N'
|
|
tnDialogBoxType = 0
|
|
Endif
|
|
|
|
If Type('tcTitle') # 'C'
|
|
tcTitle = ''
|
|
Endif
|
|
|
|
If Type('gcNumeProgram') = 'C' And gcNumeProgram = 'ROASTART'
|
|
lcMessageboxForm = "messagebox_form_desktop" && desktop .T.
|
|
Else
|
|
lcMessageboxForm = "messagebox_form"
|
|
Endif
|
|
If !'MESSAGEBOX'$Upper(Set("Classlib"))
|
|
If Type('lnTimeOut') = 'N' And lnTimeOut # 0
|
|
lnReturn = Messagebox(tcMessage, tnDialogBoxType, tcTitle, tnTimeOut)
|
|
Else
|
|
lnReturn = Messagebox(tcMessage, tnDialogBoxType, tcTitle)
|
|
Endif
|
|
Else
|
|
loMessage = Newobject(lcMessageboxForm, "MessageBox.vcx", "", tcMessage, tnDialogBoxType, tcTitle, tcFont, tnTimeOut ,tnTimeoutValue)
|
|
loMessage.Show(1)
|
|
lnReturn = loMessage.IDOpcion
|
|
Endif
|
|
|
|
|
|
Return lnReturn
|
|
|
|
Endfunc && amessagebox
|
|
***---------------------------------
|
|
|
|
|
|
Function sir2array
|
|
Lparameters tcSir, taArray, tcSeparator
|
|
|
|
Local lcSeparator, lnValues, i, lcValue, luValue, lnPos
|
|
|
|
External Array taArray
|
|
|
|
If Empty(tcSeparator)
|
|
lcSeparator = ';'
|
|
Else
|
|
lcSeparator = tcSeparator
|
|
Endif
|
|
|
|
lnValues = Alines(taArray, tcSir, 4, lcSeparator)
|
|
|
|
Return lnValues
|
|
|
|
Endfunc && sir2array
|
|
|
|
|
|
|
|
***---------------------------------------------------------------------
|
|
Procedure OPEN_DEFAULT_APP
|
|
Parameters tcfilename
|
|
|
|
Declare Integer ShellExecute In shell32.Dll ;
|
|
INTEGER hndWin, ;
|
|
STRING cAction, ;
|
|
STRING cFileName, ;
|
|
STRING cParams, ;
|
|
STRING cDir, ;
|
|
INTEGER nShowWin
|
|
cFileName = tcfilename
|
|
cAction = "open"
|
|
ShellExecute(0,cAction,cFileName,"","",1)
|
|
|
|
Endproc && OPEN_DEFAULT_APP
|
|
|
|
|
|
|
|
Procedure BringWindowTop
|
|
Local lnHwnd
|
|
|
|
#Define GW_CHILD 5 && 0x00000005
|
|
#Define GW_HWNDNEXT 2 && 0x00000002
|
|
#Define SW_MAXIMIZE 3 && 0x00000003
|
|
#Define SW_NORMAL 1 && 0x00000002
|
|
#Define WAIT_OBJECT_0 0 && 0x00000000
|
|
|
|
Declare Integer CloseHandle In Kernel32 Integer hObject
|
|
Declare Integer BringWindowToTop In Win32API Integer HWnd
|
|
Declare Integer GetDesktopWindow In User32
|
|
*!* DECLARE INTEGER GetProp IN User32 INTEGER HWND, STRING lpString
|
|
Declare Integer GetWindow In User32 Integer HWnd, Integer uCmd
|
|
*!* DECLARE INTEGER SHOWWINDOW IN Win32API INTEGER HWND, INTEGER nCmdShow
|
|
|
|
lnHwnd = GetWindow(GetDesktopWindow(), GW_CHILD)
|
|
BringWindowToTop(lnHwnd)
|
|
|
|
CloseHandle(lnHwnd)
|
|
|
|
Clear Dlls "BringWindowToTop", "GetDesktopWindow", "GetWindow", "CloseHandle"
|
|
Endproc
|
|
|
|
|
|
|
|
*!*===============================================================
|
|
Procedure newguid
|
|
Local lcPK,lcBuffer,i,lnHex,lnUpper,lnLower
|
|
*!* DECLARE INTEGER CoCreateGuid IN OLE32.DLL STRING @lcBuffer
|
|
lcBuffer=Space(17)
|
|
lcPK=Space(0)
|
|
If CoCreateGuid(@lcBuffer) = 0
|
|
For i=1 To 16
|
|
lnHex=Asc(Substr(lcBuffer,i,1))
|
|
lnUpper=Int(lnHex/16)
|
|
lnLower=lnHex-(lnUpper*16)
|
|
lcPK=lcPK+Substr('0123456789ABCDEF',lnUpper+1,1)+;
|
|
SUBSTR('0123456789ABCDEF',lnLower+1,1)
|
|
Endfor
|
|
Endif
|
|
Return lcPK
|
|
Endproc
|
|
|
|
*!*===============================================================
|
|
Procedure GETCALLSTACK
|
|
Local nPos
|
|
nPos=Program(-1) - 2
|
|
|
|
|
|
Local cCallStack,i
|
|
cCallStack=""
|
|
For i=nPos To 1 Step -1
|
|
cCallStack=cCallStack + Program(i) + Chr(13)+Chr(10)
|
|
Endfor
|
|
|
|
|
|
Return cCallStack
|
|
|
|
Endproc && GETCALLSTACK
|
|
|
|
Function setini
|
|
Parameter pcinifile, pcsection, ;
|
|
pcvar, pcval
|
|
Private lasect
|
|
Private lavars
|
|
Private All Like j*
|
|
Dimension lasect[1], lavars[ 1,3]
|
|
jlsuccess = .T.
|
|
If .Not. Empty(pcinifile)
|
|
jcfilename = Iif(At('.', ;
|
|
pcinifile) > 0, ;
|
|
pcinifile, ;
|
|
pcinifile + ;
|
|
'.INI')
|
|
pcsection = Alltrim(pcsection)
|
|
pcvar = Alltrim(pcvar)
|
|
pcval = Alltrim(pcval)
|
|
If File(jcfilename)
|
|
jnhandle = Fopen(jcfilename, ;
|
|
2)
|
|
If jnhandle < 0
|
|
jlsuccess = .F.
|
|
= Messagebox( ;
|
|
'Unable to open file: ' + ;
|
|
jcfilename, ;
|
|
'File Open Error', ;
|
|
0)
|
|
Return jlsuccess
|
|
Endif
|
|
Else
|
|
jnhandle = -1
|
|
Endif
|
|
= buildarray(jnhandle, ;
|
|
@lasect,@lavars)
|
|
If jnhandle > -1
|
|
= Fclose(jnhandle)
|
|
Endif
|
|
jsuccess = buildini(jcfilename, ;
|
|
pcsection,pcvar, ;
|
|
pcval,@lasect, ;
|
|
@lavars)
|
|
Else
|
|
jlsuccess = .F.
|
|
Endif
|
|
Return jlsuccess
|
|
Endfunc && setini
|
|
*!*
|
|
Function buildini
|
|
Parameter pcfilename, pcsection, ;
|
|
pcvar, pcval, pasect, ;
|
|
pavars
|
|
Private All Like j*
|
|
jlsuccess = .T.
|
|
jnfhandle = 0
|
|
jlfoundvar = .F.
|
|
jnfound = 0
|
|
If .Not. Empty(pasect)
|
|
For jncount = 1 To ;
|
|
ALEN(pasect, 1)
|
|
If Upper(pasect(jncount)) == ;
|
|
UPPER(pcsection)
|
|
jnfound = jncount
|
|
Exit
|
|
Endif
|
|
Endfor
|
|
Endif
|
|
If jnfound > 0
|
|
For jncount = 1 To ;
|
|
ALEN(pavars, 1)
|
|
If pavars(jncount,1) == ;
|
|
pcvar .And. ;
|
|
pavars(jncount,3) == ;
|
|
jnfound
|
|
pavars[ jncount, ;
|
|
2] = pcval
|
|
jlfoundvar = .T.
|
|
Exit
|
|
Endif
|
|
Endfor
|
|
If .Not. jlfoundvar
|
|
If .Not. ;
|
|
EMPTY(pavars(1))
|
|
jnlen2 = Alen(pavars, ;
|
|
1) + 1
|
|
Dimension pavars[ ;
|
|
jnlen2, ;
|
|
3]
|
|
Else
|
|
jnlen2 = 1
|
|
Endif
|
|
pavars[ jnlen2, 1] = ;
|
|
pcvar
|
|
pavars[ jnlen2, 2] = ;
|
|
pcval
|
|
pavars[ jnlen2, 3] = ;
|
|
jnfound
|
|
Endif
|
|
Else
|
|
If .Not. Empty(pasect(1))
|
|
jnlen = Alen(pasect, 1) + ;
|
|
1
|
|
Dimension pasect[ ;
|
|
jnlen]
|
|
Else
|
|
jnlen = 1
|
|
Endif
|
|
pasect[ jnlen] = pcsection
|
|
If .Not. Empty(pavars(1))
|
|
jnlen2 = Alen(pavars, ;
|
|
1) + 1
|
|
Dimension pavars[ ;
|
|
jnlen2, 3]
|
|
Else
|
|
jnlen2 = 1
|
|
Endif
|
|
pavars[ jnlen2, 1] = pcvar
|
|
pavars[ jnlen2, 2] = pcval
|
|
pavars[ jnlen2, 3] = jnlen
|
|
Endif
|
|
If File(pcfilename)
|
|
jcoldfile = Substr(pcfilename, ;
|
|
1, At('.', ;
|
|
pcfilename) - 1) + ;
|
|
'.BAK'
|
|
If File(jcoldfile)
|
|
Delete File (jcoldfile)
|
|
Endif
|
|
Rename (pcfilename) To ;
|
|
(jcoldfile)
|
|
Endif
|
|
jnfhandle = Fcreate(pcfilename)
|
|
If .Not. jnfhandle == -1 .And. ;
|
|
.Not. Empty(pasect)
|
|
For ncount = 1 To ;
|
|
ALEN(pasect, 1)
|
|
If (';' $ ;
|
|
pasect(ncount)) .Or. ;
|
|
EMPTY(pasect(ncount))
|
|
= Fputs(jnfhandle, ;
|
|
pasect(ncount))
|
|
Else
|
|
= Fputs(jnfhandle, ;
|
|
'[' + ;
|
|
pasect(ncount) + ;
|
|
']')
|
|
Endif
|
|
For ncount2 = 1 To ;
|
|
ALEN(pavars, 1)
|
|
If pavars(ncount2, ;
|
|
3) == ncount
|
|
= Fputs(jnfhandle, ;
|
|
pavars(ncount2, ;
|
|
1) + ' = ' + ;
|
|
pavars(ncount2, ;
|
|
2))
|
|
Endif
|
|
Endfor
|
|
Endfor
|
|
= Fclose(jnfhandle)
|
|
Else
|
|
= Messagebox( ;
|
|
'Unable to create file: ' + ;
|
|
jcfilename, ;
|
|
'File create error',0)
|
|
jlsuccess = .F.
|
|
Endif
|
|
Return jlsuccess
|
|
Endfunc && buildini
|
|
*!*
|
|
Function buildarray
|
|
Parameter pnfhandle, pasect, ;
|
|
pavars
|
|
Private All Like j*
|
|
jnalen = 1
|
|
jnvarlen = 1
|
|
If pnfhandle > -1
|
|
= Fseek(pnfhandle, 0)
|
|
Do While .Not. ;
|
|
FEOF(pnfhandle)
|
|
jcline = Fgets(pnfhandle)
|
|
If ';' $ jcline .Or. ;
|
|
EMPTY(jcline)
|
|
If Empty(pasect(1))
|
|
pasect[ 1] = ;
|
|
jcline
|
|
Else
|
|
jnalen = Alen(pasect, ;
|
|
1) + ;
|
|
1
|
|
Dimension pasect[ ;
|
|
jnalen]
|
|
pasect[ ;
|
|
jnalen] = ;
|
|
jcline
|
|
Endif
|
|
Else
|
|
jnfound1 = At('[', jcline)
|
|
jnfound2 = At(']', jcline)
|
|
If jnfound1 > 0 .And. jnfound2 > 0
|
|
jcsection = Substr(jcline, ;
|
|
jnfound1 + ;
|
|
1, ;
|
|
jnfound2 - ;
|
|
2)
|
|
If Empty(pasect(1))
|
|
pasect[ ;
|
|
1] = ;
|
|
jcsection
|
|
Else
|
|
jnalen = ;
|
|
ALEN(pasect, ;
|
|
1) + 1
|
|
Dimension ;
|
|
pasect[ ;
|
|
jnalen]
|
|
pasect[ ;
|
|
jnalen] = ;
|
|
jcsection
|
|
Endif
|
|
jnalen = Alen(pasect, ;
|
|
1)
|
|
Else
|
|
If At('=', ;
|
|
jcline) > ;
|
|
0
|
|
If Empty(pavars(1, ;
|
|
1))
|
|
pavars[ ;
|
|
1, ;
|
|
1] = ;
|
|
ALLTRIM(Substr(jcline, ;
|
|
1, ;
|
|
AT( ;
|
|
'=', ;
|
|
jcline) - ;
|
|
1))
|
|
pavars[ ;
|
|
1, ;
|
|
2] = ;
|
|
ALLTRIM(Substr(jcline, ;
|
|
AT( ;
|
|
'=', ;
|
|
jcline) + ;
|
|
1))
|
|
pavars[ ;
|
|
1, ;
|
|
3] = ;
|
|
jnalen
|
|
Else
|
|
jnvarlen = ;
|
|
ALEN(pavars, ;
|
|
1) + ;
|
|
1
|
|
Dimension ;
|
|
pavars[ ;
|
|
jnvarlen, ;
|
|
3]
|
|
pavars[ ;
|
|
jnvarlen, ;
|
|
1] = ;
|
|
ALLTRIM(Substr(jcline, ;
|
|
1, ;
|
|
AT( ;
|
|
'=', ;
|
|
jcline) - ;
|
|
1))
|
|
pavars[ ;
|
|
jnvarlen, ;
|
|
2] = ;
|
|
ALLTRIM(Substr(jcline, ;
|
|
AT( ;
|
|
'=', ;
|
|
jcline) + ;
|
|
1))
|
|
pavars[ ;
|
|
jnvarlen, ;
|
|
3] = ;
|
|
jnalen
|
|
Endif
|
|
Endif
|
|
Endif
|
|
Endif
|
|
Enddo
|
|
Endif
|
|
Return .T.
|
|
Endfunc && buildarray
|
|
*!*
|
|
Function getini
|
|
Parameter pcinifile, pcsection, ;
|
|
pcvar
|
|
Private All Like j*
|
|
jcretval = ''
|
|
If .Not. Empty(pcinifile)
|
|
jcfilename = Iif(At('.', ;
|
|
pcinifile) > 0, ;
|
|
pcinifile, ;
|
|
pcinifile + ;
|
|
'.INI')
|
|
If File(jcfilename)
|
|
jnhandle = Fopen(jcfilename)
|
|
If jnhandle < 0
|
|
jlsuccess = .F.
|
|
= Messagebox( ;
|
|
'Unable to open file: ' + ;
|
|
jcfilename, ;
|
|
'File Open Error', ;
|
|
0)
|
|
Else
|
|
pcsection = Alltrim(Upper(pcsection))
|
|
pcvar = Alltrim(Upper(pcvar))
|
|
jcretval = readini(@jnhandle, ;
|
|
pcsection, ;
|
|
pcvar)
|
|
= Fclose(jnhandle)
|
|
Endif
|
|
Endif
|
|
Endif
|
|
Return jcretval
|
|
Endfunc && getini
|
|
*!*
|
|
Function readini
|
|
Parameter pnfhandle, pcsection, ;
|
|
pcvar
|
|
Private All Like j*
|
|
jcline = ''
|
|
jcsection = ''
|
|
jnfound1 = 0
|
|
jnfound2 = 0
|
|
jnfound3 = 0
|
|
jnalen = 0
|
|
jcretval = ''
|
|
If .Not. Empty(pnfhandle)
|
|
= Fseek(pnfhandle, 0)
|
|
Do While .Not. ;
|
|
FEOF(pnfhandle)
|
|
jcline = Fgets(pnfhandle)
|
|
jnfound1 = At('[', ;
|
|
jcline)
|
|
jnfound2 = At(']', ;
|
|
jcline)
|
|
If jnfound1 > 0 .And. ;
|
|
jnfound2 > 0
|
|
jcsection = Upper(Substr(jcline, ;
|
|
jnfound1 + ;
|
|
1, ;
|
|
jnfound2 - ;
|
|
2))
|
|
Endif
|
|
If jcsection == ;
|
|
pcsection
|
|
jnfound3 = At('=', ;
|
|
jcline)
|
|
If jnfound3 > 0
|
|
If Alltrim(Upper(Substr(jcline, ;
|
|
1, ;
|
|
jnfound3 - ;
|
|
1))) == ;
|
|
pcvar
|
|
jcretval = ;
|
|
ALLTRIM(Substr(jcline, ;
|
|
jnfound3 + ;
|
|
1))
|
|
Exit
|
|
Endif
|
|
Endif
|
|
Endif
|
|
Enddo
|
|
Endif
|
|
Return jcretval
|
|
Endfunc && readini
|
|
|
|
|
|
* Foloseste comment de la coloane si tooltiptext de la grid pt a salva recordsource si controlsource din grid inainte de reconstructie
|
|
Procedure SAVE_GRID_COMMENT
|
|
Param toGrid
|
|
*wait wind 'save_grid'
|
|
Private pogrid
|
|
If Param()=0 Or Type('togrid')!="O"
|
|
Return .F.
|
|
Endif
|
|
|
|
pogrid=toGrid
|
|
|
|
* remember control sources in the column's comment field
|
|
With pogrid
|
|
Local nColumnIndex
|
|
For m.nColumnIndex = 1 To .ColumnCount
|
|
.Columns(m.nColumnIndex).Comment = .Columns(m.nColumnIndex).ControlSource
|
|
Endfor
|
|
.ToolTipText=.RecordSource
|
|
.RecordSource=""
|
|
Endwith
|
|
|
|
Return .T.
|
|
Endproc && SAVE_GRID_COMMENT
|
|
***--------------------------------------------------------------
|
|
Procedure RESTORE_GRID_COMMENT
|
|
Param toGrid
|
|
|
|
*wait wind 'restore_grid'
|
|
Private pogrid
|
|
If Param()=0 Or Type('togrid')!="O"
|
|
Return .F.
|
|
Endif
|
|
|
|
pogrid=toGrid
|
|
|
|
|
|
With pogrid
|
|
* restore record source
|
|
.RecordSource = .ToolTipText
|
|
* restore control sources
|
|
For m.nColumnIndex = 1 To .ColumnCount
|
|
.Columns(m.nColumnIndex).ControlSource = .Columns(m.nColumnIndex).Comment
|
|
Endfor
|
|
.ToolTipText=""
|
|
Endwith
|
|
Return .T.
|
|
Endproc && RESTORE_GRID_COMMENT
|
|
|
|
|
|
* Foloseste comment de la coloane si tooltiptext de la grid pt a salva recordsource si controlsource din grid inainte de reconstructie
|
|
Procedure SAVE_GRID_TAG
|
|
Param toGrid
|
|
*wait wind 'save_grid'
|
|
Private pogrid
|
|
If Param()=0 Or Type('togrid')!="O"
|
|
Return .F.
|
|
Endif
|
|
|
|
pogrid=toGrid
|
|
|
|
* remember control sources in the column's comment field
|
|
With pogrid
|
|
Local nColumnIndex
|
|
For m.nColumnIndex = 1 To .ColumnCount
|
|
.Columns(m.nColumnIndex).Tag = .Columns(m.nColumnIndex).ControlSource
|
|
Endfor
|
|
.ToolTipText=.RecordSource
|
|
.RecordSource=""
|
|
Endwith
|
|
|
|
Return .T.
|
|
Endproc && SAVE_GRID_TAG
|
|
***--------------------------------------------------------------
|
|
Procedure RESTORE_GRID_TAG
|
|
Param toGrid
|
|
|
|
*wait wind 'restore_grid'
|
|
Private pogrid
|
|
If Param()=0 Or Type('togrid')!="O"
|
|
Return .F.
|
|
Endif
|
|
|
|
pogrid=toGrid
|
|
|
|
|
|
With pogrid
|
|
* restore record source
|
|
.RecordSource = .ToolTipText
|
|
* restore control sources
|
|
For m.nColumnIndex = 1 To .ColumnCount
|
|
.Columns(m.nColumnIndex).ControlSource = .Columns(m.nColumnIndex).Tag
|
|
Endfor
|
|
.ToolTipText=""
|
|
Endwith
|
|
Return .T.
|
|
Endproc && RESTORE_GRID_TAG
|
|
|
|
|
|
*-------------------------------------------
|
|
* Function...: Xmenu
|
|
* Author.....: MARTIN
|
|
* Date.......: 04/06/1997
|
|
* Notes......: Based on an idea from Steve Zimmelman for FoxPro 2.x
|
|
* Parameters.: tcItems = Semicolon-separated String with the various options
|
|
* ...........: tnBar = Initially selected item (default=1)
|
|
* Returns....: Selected item number
|
|
* See Also...: PROMPT() [FoxPro Native]
|
|
*
|
|
Procedure XMENU
|
|
Lparameters TCITEMS, TNBAR
|
|
|
|
Local NITEMCOUNT, AITEMS, X, NROW, NCOL, CTITLE, NLASTPOS, CCOLOR, AITEMS
|
|
|
|
Private CPOPMENU, NSELECT && They flow into the GetChoice internal procedure
|
|
|
|
If Pcount() < 2
|
|
TNBAR = 1
|
|
Endif
|
|
|
|
Activate Screen
|
|
|
|
* Parse every item
|
|
*
|
|
m.NITEMCOUNT = Occurs( ';', TCITEMS ) + 1
|
|
Dimen AITEMS[ m.nItemCount ]
|
|
m.NLASTPOS = 1
|
|
|
|
For m.X = 1 To m.NITEMCOUNT
|
|
|
|
If m.X < m.NITEMCOUNT
|
|
|
|
AITEMS[ m.x ] = Subs( m.TCITEMS, m.NLASTPOS, ;
|
|
( At( ';', m.TCITEMS, m.X ) - 1 ) - m.NLASTPOS + 1 )
|
|
Else
|
|
AITEMS[ m.x ] = Subs( m.TCITEMS, m.NLASTPOS, ;
|
|
( Len( m.TCITEMS ) - m.NLASTPOS ) + 1 )
|
|
Endif
|
|
|
|
If AITEMS[ m.x ] # "\-"
|
|
|
|
AITEMS[ m.x ] = Allt( AITEMS[ m.x ] )
|
|
Endif
|
|
|
|
m.NLASTPOS=At( ';', m.TCITEMS, m.X ) + 1
|
|
Next
|
|
|
|
* Calculates the mouse pointer position
|
|
*
|
|
m.NROW = Iif( Mrow() + m.NITEMCOUNT < Srow(), Mrow() - 1, Srow() - m.NITEMCOUNT )
|
|
m.NCOL = Iif( Mcol() + 10 < Scol(), Mcol() - 3, Mcol() - 13 )
|
|
|
|
* Gets an unique name for the pop-up
|
|
*
|
|
m.CPOPMENU = 'M' + Sys(3) + "_"
|
|
|
|
Define Popup ( m.CPOPMENU ) SHORTCUT Relative From NROW, NCOL
|
|
|
|
For m.X = 1 To m.NITEMCOUNT
|
|
|
|
Define Bar m.X Of ( m.CPOPMENU ) Prompt AITEMS[ m.x ]
|
|
Next
|
|
|
|
m.CANS = ""
|
|
m.NSELECT = 0
|
|
Clear Type
|
|
|
|
On Selection Popup ( m.CPOPMENU ) Do GETCHOICE
|
|
|
|
Activate Popup ( m.CPOPMENU ) Bar TNBAR
|
|
|
|
Pop Key
|
|
Release Popup ( m.CPOPMENU )
|
|
|
|
Return Iif( Lastkey()=27, 0, m.NSELECT )
|
|
|
|
Endproc && XMENU
|
|
|
|
*--------------------
|
|
Procedure GETCHOICE
|
|
|
|
m.NSELECT = Bar()
|
|
|
|
Deactivate Popup ( m.CPOPMENU )
|
|
|
|
Return
|
|
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& MENIU &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|
|
|
|
*** COPIERE SHALLOW - proprietatile care contin referinte la alte obiecte pastreaza aceleasi referinte
|
|
*** EX1: loDestinationObject = CopyObject(loSourceObject) -> creeaza un obiect nou si copie proprietatile din loSourceObject
|
|
*** EX2: CopyObject(loSourceObject, @loDestinationObject) -> adauga/copiaza proprietatile din loSourceObject in loDestinationObject (obiect nou sau existent)
|
|
Function CopyObject
|
|
Lparameters toObject, toNewObject
|
|
Local laProps[1], lnI, lcPropName, loEx As Exception
|
|
* For Empty class only
|
|
If Type("toObject") <> "O"
|
|
toNewObject = Null
|
|
Return Null
|
|
Endif
|
|
|
|
If Type('toNewObject') <> 'O'
|
|
If Type('toObject.Class')='C' And Type('toObject.ClassLibrary')='C'
|
|
toNewObject = Newobject(toObject.Class,toObject.ClassLibrary)
|
|
Else
|
|
toNewObject = Createobject("Empty")
|
|
Endif
|
|
Endif
|
|
|
|
|
|
For lnI=1 To Amembers(laProps, toObject, 0)
|
|
lcPropName = Lower(laProps[lnI])
|
|
* Pre VFP9
|
|
*IF TYPE([ALEN( toObject.&lcPropName)]) = "N"
|
|
If Type([toObject.] + lcPropName,1) = "A"
|
|
* Array
|
|
If !Pemstatus(toNewObject, lcPropName, 5) && If the property does not exist
|
|
AddProperty(toNewObject, lcPropName + "[1]", Null )
|
|
Endif
|
|
= Acopy(toObject.&lcPropName, toNewObject.&lcPropName)
|
|
Else
|
|
If !Pemstatus(toNewObject, lcPropName, 5) && If the property does not exist
|
|
AddProperty(toNewObject, lcPropName, Evaluate("toObject." + lcPropName) )
|
|
Else
|
|
Try
|
|
toNewObject.&lcPropName = Evaluate("toObject." + lcPropName)
|
|
Catch && TO loEx WHEN loEx.ErrorNo = 1743 && PROPERTY IS READONLY - NU FAC NIMIC
|
|
*
|
|
Endtry
|
|
Endif
|
|
Endif
|
|
Endfor
|
|
|
|
Return toNewObject
|
|
Endfunc && CopyObject
|
|
|
|
|
|
Procedure MakeDirectoryStructure
|
|
Lparameters tcDirector
|
|
|
|
Local lnDirectoare, lcSubDirector, lcSubdirectorLocal, i
|
|
|
|
lnDirectoare = Getwordcount(Justpath(m.tcDirector), "\")
|
|
lcSubdirectorLocal = ""
|
|
For i = 1 To lnDirectoare
|
|
lcSubDirector = Getwordnum(Justpath(m.tcDirector), i, "\")
|
|
lcSubdirectorLocal = m.lcSubdirectorLocal + m.lcSubDirector + "\"
|
|
If !Directory(m.lcSubdirectorLocal)
|
|
Md(m.lcSubdirectorLocal)
|
|
Endif
|
|
Endfor
|
|
|
|
Endproc && MakeDirectoryStructure
|
|
*
|
|
FUNCTION cValidCNP
|
|
LPARAMETERS lpcnp
|
|
|
|
IF TYPE('lpCNP') ='N'
|
|
lpCNP = ALLTRIM(STR(m.lpcnp))
|
|
ENDIF
|
|
|
|
IF LEN(ALLTRIM(lpcnp)) <> 13
|
|
RETURN .F.
|
|
ENDIF
|
|
n1 = VAL(SUBSTR(lpcnp, 1, 1))
|
|
n2 = VAL(SUBSTR(lpcnp, 2, 1))
|
|
n3 = VAL(SUBSTR(lpcnp, 3, 1))
|
|
n4 = VAL(SUBSTR(lpcnp, 4, 1))
|
|
n5 = VAL(SUBSTR(lpcnp, 5, 1))
|
|
n6 = VAL(SUBSTR(lpcnp, 6, 1))
|
|
n7 = VAL(SUBSTR(lpcnp, 7, 1))
|
|
n8 = VAL(SUBSTR(lpcnp, 8, 1))
|
|
n9 = VAL(SUBSTR(lpcnp, 9, 1))
|
|
n10 = VAL(SUBSTR(lpcnp, 10, 1))
|
|
n11 = VAL(SUBSTR(lpcnp, 11, 1))
|
|
n12 = VAL(SUBSTR(lpcnp, 12, 1))
|
|
n13 = VAL(SUBSTR(lpcnp, 13, 1))
|
|
c = MOD((n1 * 2 + n2 * 7 + n3 * 9 + ;
|
|
n4 * 1 + n5 * 4 + n6 * 6 + n7 * ;
|
|
3 + n8 * 5 + n9 * 8 + n10 * 2 + ;
|
|
n11 * 7 + n12 * 9), 11)
|
|
IF c = 10
|
|
c = 1
|
|
ENDIF
|
|
IF c = n13
|
|
RETURN .T.
|
|
ELSE
|
|
RETURN .F.
|
|
ENDIF
|
|
ENDFUNC
|
|
|
|
*
|
|
FUNCTION GetDataCNP
|
|
LPARAMETERS plcnp
|
|
LOCAL mlan
|
|
mlan = SUBSTR(plcnp, 2, 2)
|
|
IF VAL(mlan) > 20 AND !INLIST(LEFT(plcnp, 1), "5", "6")
|
|
mlan = "19" + mlan
|
|
ELSE
|
|
mlan = "20" + mlan
|
|
ENDIF
|
|
RETURN CTOD(SUBSTR(plcnp, 6, 2) + "." + SUBSTR(plcnp, 4, 2) + "." + mlan)
|
|
ENDFUNC
|
|
*
|
|
*
|
|
* Copiata din D:\ROA\ROACONT\COMUN\programe\oproceduri_comune.prg (GetNrFromString),
|
|
* ca sa nu duplic logica: taie de la inceputul sirului literele si separatorii,
|
|
* pana la prima cifra. Ex. 'RO 15613488' -> '15613488', 'CUI 14770212' -> '14770212'.
|
|
FUNCTION GetNrFromString
|
|
LPARAMETERS plstr
|
|
LOCAL mlenstr
|
|
mlenstr = LEN(ALLTRIM(plstr))
|
|
|
|
DO WHILE ISALPHA(plstr) .OR. LEFT(plstr, 1) == " ";
|
|
.OR. LEFT(plstr, 1) == "&" .OR. LEFT(plstr, 1) == "/";
|
|
.OR. LEFT(plstr, 1) == "-" .OR. LEFT(plstr, 1) == "_";
|
|
.OR. LEFT(plstr, 1) == "." .OR. LEFT(plstr, 1) == ":"
|
|
plstr = RTRIM(SUBSTR(plstr, 2, mlenstr))
|
|
ENDDO
|
|
|
|
RETURN plstr
|
|
ENDFUNC
|
|
*
|
|
FUNCTION VerifCF
|
|
LPARAMETERS plcfisc
|
|
LOCAL mlsuma, mlrest
|
|
plcfisc = getnrfromstring(plcfisc)
|
|
IF LEN(ALLTRIM(plcfisc)) = 13
|
|
IF .NOT. cvalidcnp(plcfisc)
|
|
RETURN .F.
|
|
ELSE
|
|
RETURN .T.
|
|
ENDIF
|
|
ELSE
|
|
IF LEN(ALLTRIM(plcfisc)) < 2 OR LEN(ALLTRIM(plcfisc)) > 10 OR plcfisc = "0"
|
|
RETURN .F.
|
|
ENDIF
|
|
ENDIF
|
|
plcfisc = PADL(ALLTRIM(plcfisc), 10, "0")
|
|
mlsuma = 0
|
|
FOR i = 1 TO 10
|
|
mlsuma = mlsuma + VAL(SUBSTR(plcfisc, i, 1)) * VAL(SUBSTR("753217532", i, 1))
|
|
ENDFOR
|
|
mlrest = MOD((mlsuma * 10), 11)
|
|
IF mlrest = 10
|
|
mlrest = 0
|
|
ENDIF
|
|
IF VAL(SUBSTR(plcfisc, 10, 1)) <> mlrest
|
|
RETURN .F.
|
|
ELSE
|
|
RETURN .T.
|
|
ENDIF
|
|
ENDFUNC
|
|
*
|
|
* Intoarce un cod fiscal fara atributul de tara. sterge literele si alte caractere nonnumerice
|
|
* RO 1879855 -> 1879855
|
|
FUNCTION GetCodFiscalFRO
|
|
LPARAMETERS tcCF
|
|
|
|
lcCodFiscalFRO = ALLTRIM(CHRTRAN(ALLTRIM(UPPER(TRANSFORM(m.tcCF))), "ABCDEFGHIJKLMNOPQRSTUVWXYZ -./()", ""))
|
|
|
|
RETURN m.lcCodFiscalFRO
|
|
ENDFUNC
|
|
*
|
|
* Clasifica partenerul importat (Fidelio hotel, BIZ restaurant) in persoana fizica / juridica
|
|
* si curata DOAR CNP-urile invalide.
|
|
*
|
|
* De ce asa:
|
|
* - la declaratii (D394/D406) o PERSOANA FIZICA poate fi raportata FARA CNP, deci un CNP
|
|
* invalid se poate goli fara sa pierdem nimic si fara sa dea eroare de validare;
|
|
* - o PERSOANA JURIDICA trebuie sa aiba cod fiscal, deci codul ei NU se sterge niciodata:
|
|
* daca e gresit, ramane asa ca sa fie semnalat la validarea declaratiei si sa fie corectat
|
|
* la sursa (in Fidelio), nu ascuns aici.
|
|
*
|
|
* De ce NU ne putem baza pe validarea romaneasca ca sa decidem tipul:
|
|
* codurile straine pot fi si numai cifre (fara prefix de tara), deci un cod numeric care nu
|
|
* trece algoritmul romanesc NU inseamna automat "gresit". Tipul se decide din alte semnale,
|
|
* in ordinea increderii:
|
|
* 1. tcTipCunoscut - tip venit din import, daca sistemul sursa il stie (cel mai sigur)
|
|
* 2. prefix de tara pe cod (RO/BE/DE...) sau litere in cod => persoana juridica
|
|
* 3. denumire cu forma juridica (SRL, SA, PFA, ASOCIATIA...) => persoana juridica
|
|
* 4. numar de registrul comertului in tcRegCom (J40/1234/2018, L2019...) => juridica
|
|
* serie+numar de CI (2 litere + 6 cifre) => fizica
|
|
* 5. CNP valid pe 13 cifre => fizica; CUI romanesc valid => juridica
|
|
* 6. altfel => fizica (majoritatea covarsitoare a clientilor de hotel)
|
|
*
|
|
* Parametri:
|
|
* tcCod - codul brut din import (CODFISCAL_CNP)
|
|
* tnTipPersoana - IESIRE prin referinta: 1 = juridica, 2 = fizica
|
|
* tcDenumire - optional, denumirea partenerului (pentru forma juridica)
|
|
* tcRegCom - optional, REGCOMERT_CI_PASS (nr. registrul comertului sau serie CI)
|
|
* tcCodTara - optional, codul/denumirea tarii daca importul o stie
|
|
* tcTipCunoscut - optional, tipul deja stiut din import: '1'/'PJ' sau '2'/'PF'
|
|
*
|
|
* Intoarce: codul de pastrat in ROA. Sir GOL doar cand este persoana fizica cu CNP invalid.
|
|
FUNCTION GetCodFiscalValid
|
|
LPARAMETERS tcCod, tnTipPersoana, tcDenumire, tcRegCom, tcCodTara, tcTipCunoscut
|
|
|
|
LOCAL lcCod, lcBrut, lcCifre, lcCifreReg, lcPrefix, lcPrefixBrut, lcTara, lcTip
|
|
LOCAL llLitere, llPrefixFiscal, lnParam
|
|
lnParam = PCOUNT()
|
|
|
|
lcCod = GetCodFiscalCurat(m.tcCod)
|
|
lcCifre = CHRTRAN(m.lcCod, CHRTRAN(m.lcCod, '0123456789', ''), '')
|
|
lcPrefix = ALLTRIM(CHRTRAN(m.lcCod, CHRTRAN(m.lcCod, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', ''), ''))
|
|
llLitere = !EMPTY(m.lcPrefix)
|
|
|
|
* Eticheta din codul BRUT ('CUI 14770212') e semnal de persoana juridica, chiar daca
|
|
* GetCodFiscalCurat o scoate din codul salvat. 'RO' se pastreaza in cod pentru ca inseamna
|
|
* platitor de TVA, iar in ROA acela e alt partener decat neplatitorul cu acelasi numar.
|
|
lcBrut = ALLTRIM(UPPER(TRANSFORM(NVL(m.tcCod, ''))))
|
|
lcPrefixBrut = ALLTRIM(CHRTRAN(m.lcBrut, CHRTRAN(m.lcBrut, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', ''), ''))
|
|
llPrefixFiscal = INLIST(m.lcPrefixBrut, 'RO', 'CUI', 'CF', 'CIF')
|
|
|
|
lcTara = IIF(m.lnParam > 4 AND VARTYPE(m.tcCodTara) = 'C', ALLTRIM(UPPER(m.tcCodTara)), '')
|
|
lcTip = IIF(m.lnParam > 5 AND VARTYPE(m.tcTipCunoscut) = 'C', ALLTRIM(UPPER(m.tcTipCunoscut)), '')
|
|
|
|
DO CASE
|
|
CASE INLIST(m.lcTip, '1', 'PJ', 'J')
|
|
tnTipPersoana = 1
|
|
CASE INLIST(m.lcTip, '2', 'PF', 'F')
|
|
tnTipPersoana = 2
|
|
CASE m.llPrefixFiscal
|
|
* eticheta romaneasca de cod fiscal (RO/CUI/CF/CIF) => persoana juridica
|
|
tnTipPersoana = 1
|
|
CASE !EMPTY(m.lcTara) AND !INLIST(m.lcTara, 'RO', 'ROU', 'ROMANIA')
|
|
* tara straina declarata: nu putem valida romaneste, tratam ca juridica
|
|
tnTipPersoana = 1
|
|
CASE EstePersoanaJuridica(m.tcDenumire)
|
|
tnTipPersoana = 1
|
|
CASE EsteNrRegComert(m.tcRegCom)
|
|
tnTipPersoana = 1
|
|
CASE LEN(m.lcCifre) = 13 AND cValidCNP(m.lcCifre)
|
|
tnTipPersoana = 2
|
|
CASE EsteSerieCI(m.tcRegCom)
|
|
tnTipPersoana = 2
|
|
CASE m.llLitere
|
|
* cod cu litere fara alt semnal: TVA intracomunitar (BE0325777171) daca incepe cu
|
|
* un cod de tara UE, altfel e cel mai probabil pasaport de persoana fizica
|
|
tnTipPersoana = IIF(EsteCodTVAStrain(m.lcCod), 1, 2)
|
|
CASE BETWEEN(LEN(m.lcCifre), 2, 10) AND VerifCF(m.lcCifre)
|
|
tnTipPersoana = 1
|
|
OTHERWISE
|
|
* clientii de hotel sunt in marea lor majoritate persoane fizice
|
|
tnTipPersoana = 2
|
|
ENDCASE
|
|
|
|
IF m.tnTipPersoana = 1
|
|
* persoana juridica: codul NU se sterge niciodata, chiar daca nu trece validarea.
|
|
* Vrem sa fim atentionati la declaratie, nu sa ascundem problema.
|
|
RETURN m.lcCod
|
|
ENDIF
|
|
|
|
* persoana fizica: pastram CNP-ul doar daca este valid, altfel gol (permis la declaratii).
|
|
* Pasapoartele si seriile de CI nu sunt CNP-uri, deci nu se salveaza pe cod fiscal.
|
|
IF LEN(m.lcCifre) = 13 AND cValidCNP(m.lcCifre)
|
|
RETURN m.lcCifre
|
|
ENDIF
|
|
|
|
* recuperare: in Fidelio se intampla ca operatorul sa inverseze campurile si sa scrie CNP-ul
|
|
* in 'serie CI / pasaport'. Daca acolo gasim un CNP valid, il folosim pe acela.
|
|
lcCifreReg = GetCodFiscalCurat(m.tcRegCom)
|
|
lcCifreReg = CHRTRAN(m.lcCifreReg, CHRTRAN(m.lcCifreReg, '0123456789', ''), '')
|
|
IF LEN(m.lcCifreReg) = 13 AND cValidCNP(m.lcCifreReg)
|
|
RETURN m.lcCifreReg
|
|
ENDIF
|
|
|
|
RETURN ''
|
|
ENDFUNC
|
|
*
|
|
* .T. daca sirul arata a cod de TVA intracomunitar: 2 litere = cod de tara UE, urmate de cifre.
|
|
* Ex: 'BE0325777171', 'DE811234567', 'HU12345678'. NU include 'RO' (tratat separat).
|
|
FUNCTION EsteCodTVAStrain
|
|
LPARAMETERS tcCod
|
|
|
|
LOCAL lcCod, lcTari, lcTara, lcRest
|
|
lcCod = ALLTRIM(UPPER(TRANSFORM(NVL(m.tcCod, ''))))
|
|
lcCod = CHRTRAN(m.lcCod, ' .-', '')
|
|
IF LEN(m.lcCod) < 6
|
|
RETURN .F.
|
|
ENDIF
|
|
|
|
* coduri de tara UE + cateva uzuale in turism
|
|
lcTari = ' AT BE BG CY CZ DE DK EE EL ES FI FR GR HR HU IE IT LT LU LV MT NL PL PT SE SI SK ' + ;
|
|
' GB CH NO MD UA RS TR US '
|
|
|
|
lcTara = LEFT(m.lcCod, 2)
|
|
IF !(' ' + m.lcTara + ' ' $ m.lcTari)
|
|
RETURN .F.
|
|
ENDIF
|
|
|
|
* dupa codul de tara trebuie sa urmeze numai cifre
|
|
lcRest = SUBSTR(m.lcCod, 3)
|
|
RETURN LEN(CHRTRAN(m.lcRest, CHRTRAN(m.lcRest, '0123456789', ''), '')) = LEN(m.lcRest)
|
|
ENDFUNC
|
|
*
|
|
* Curata un cod fiscal / CNP de spatii, puncte si separatori redundanti, pastrand literele
|
|
* semnificative.
|
|
* 'RO 23565004' -> 'RO23565004'
|
|
* 'CUI 14770212' -> '14770212'
|
|
* '2920121295914.' -> '2920121295914'
|
|
*
|
|
* ATENTIE: prefixul 'RO' NU se adauga niciodata de la noi. In ROA, 'RO12345678' (platitor de
|
|
* TVA) si '12345678' (neplatitor) sunt DOI parteneri diferiti, deci prefixul se pastreaza
|
|
* exact cum a venit din import. Etichetele 'CUI'/'CF'/'CIF' sunt doar text descriptiv, nu
|
|
* atribut fiscal, deci se sterg fara sa fie inlocuite cu 'RO'.
|
|
FUNCTION GetCodFiscalCurat
|
|
LPARAMETERS tcCod
|
|
|
|
LOCAL lcCod, lcCifre, lcPrefix
|
|
lcCod = ALLTRIM(UPPER(TRANSFORM(NVL(m.tcCod, ''))))
|
|
lcCod = CHRTRAN(m.lcCod, CHR(9) + CHR(13) + CHR(10), ' ')
|
|
* scot spatiile si punctele; liniuta si slash-ul pot face parte din coduri straine
|
|
lcCod = ALLTRIM(CHRTRAN(m.lcCod, ' .', ''))
|
|
|
|
* 'CUI 14770212' -> '14770212': eticheta nu spune nimic despre calitatea de platitor de TVA
|
|
lcPrefix = ALLTRIM(CHRTRAN(m.lcCod, CHRTRAN(m.lcCod, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', ''), ''))
|
|
IF INLIST(m.lcPrefix, 'CUI', 'CF', 'CIF')
|
|
lcCifre = CHRTRAN(m.lcCod, CHRTRAN(m.lcCod, '0123456789', ''), '')
|
|
IF !EMPTY(m.lcCifre)
|
|
lcCod = m.lcCifre
|
|
ENDIF
|
|
ENDIF
|
|
|
|
RETURN m.lcCod
|
|
ENDFUNC
|
|
*
|
|
* .T. daca denumirea contine o forma juridica (SRL, SA, PFA, ASOCIATIA, LTD, GMBH...).
|
|
* Compara pe cuvinte intregi, ca sa nu ia 'SA' din 'SAVU' sau 'II' din 'MIHAII'.
|
|
FUNCTION EstePersoanaJuridica
|
|
LPARAMETERS tcDenumire
|
|
|
|
LOCAL lcDen, lcForme, lcCuv, lnI, lnCuvinte
|
|
lcDen = ALLTRIM(UPPER(TRANSFORM(NVL(m.tcDenumire, ''))))
|
|
IF EMPTY(m.lcDen)
|
|
RETURN .F.
|
|
ENDIF
|
|
|
|
* separatorii devin spatii, ca sa pot compara cuvant cu cuvant
|
|
lcDen = CHRTRAN(m.lcDen, '.,-/()"' + CHR(9), ' ')
|
|
|
|
lcForme = ' SRL SA SC SNC SCS SCA PFA II IF SRLD RA RL ' + ;
|
|
' ASOCIATIA ASOCIATIE FUNDATIA FUNDATIE SOCIETATEA COOPERATIVA CABINET ' + ;
|
|
' PRIMARIA MINISTERUL AGENTIA INSTITUTUL SPITALUL SCOALA LICEUL COLEGIUL ' + ;
|
|
' UNIVERSITATEA UNIVERSITE UNIVERSITY UNIVERSITAT INSPECTORATUL DIRECTIA ' + ;
|
|
' LTD LIMITED GMBH AG BV NV INC LLC PLC CORP CORPORATION COMPANY HOLDING KFT SPZOO OOD '
|
|
|
|
lnCuvinte = GETWORDCOUNT(m.lcDen, ' ')
|
|
FOR lnI = 1 TO m.lnCuvinte
|
|
lcCuv = ALLTRIM(GETWORDNUM(m.lcDen, m.lnI, ' '))
|
|
IF !EMPTY(m.lcCuv) AND (' ' + m.lcCuv + ' ') $ m.lcForme
|
|
RETURN .T.
|
|
ENDIF
|
|
ENDFOR
|
|
|
|
RETURN .F.
|
|
ENDFUNC
|
|
*
|
|
* .T. daca sirul arata a numar de inregistrare la Registrul Comertului.
|
|
* Forme acceptate: 'J40/1234/2018', 'F13/45/2005', 'C23/9/2019', 'L2019000159348', '54/1997'
|
|
FUNCTION EsteNrRegComert
|
|
LPARAMETERS tcRegCom
|
|
|
|
LOCAL lcReg, lcRest
|
|
lcReg = ALLTRIM(UPPER(TRANSFORM(NVL(m.tcRegCom, ''))))
|
|
lcReg = CHRTRAN(m.lcReg, ' ', '')
|
|
IF EMPTY(m.lcReg)
|
|
RETURN .F.
|
|
ENDIF
|
|
|
|
* J40/1234/2018 - litera + cifre + doua slash-uri
|
|
IF INLIST(LEFT(m.lcReg, 1), 'J', 'F', 'C') AND OCCURS('/', m.lcReg) = 2 AND ;
|
|
ISDIGIT(SUBSTR(m.lcReg, 2, 1))
|
|
RETURN .T.
|
|
ENDIF
|
|
|
|
* L2019000159348 / J2018000211289 - litera urmata de minim 10 cifre
|
|
IF INLIST(LEFT(m.lcReg, 1), 'J', 'L') AND LEN(m.lcReg) >= 11
|
|
lcRest = SUBSTR(m.lcReg, 2)
|
|
IF ISDIGIT(m.lcRest) AND LEN(CHRTRAN(m.lcRest, CHRTRAN(m.lcRest, '0123456789', ''), '')) = LEN(m.lcRest)
|
|
RETURN .T.
|
|
ENDIF
|
|
ENDIF
|
|
|
|
* 54/1997 - numar/an, tipic institutiilor publice
|
|
IF OCCURS('/', m.lcReg) = 1 AND LEN(m.lcReg) <= 8 AND ;
|
|
ISDIGIT(m.lcReg) AND LEN(GETWORDNUM(m.lcReg, 2, '/')) = 4
|
|
RETURN .T.
|
|
ENDIF
|
|
|
|
RETURN .F.
|
|
ENDFUNC
|
|
*
|
|
* .T. daca sirul arata a serie + numar de carte de identitate: 2 litere urmate de 6 cifre.
|
|
* Ex: 'ZV 093375', 'IF834409', 'RK 340434'
|
|
FUNCTION EsteSerieCI
|
|
LPARAMETERS tcRegCom
|
|
|
|
LOCAL lcReg
|
|
lcReg = ALLTRIM(UPPER(TRANSFORM(NVL(m.tcRegCom, ''))))
|
|
lcReg = CHRTRAN(m.lcReg, ' -.', '')
|
|
IF LEN(m.lcReg) <> 8
|
|
RETURN .F.
|
|
ENDIF
|
|
|
|
RETURN ISALPHA(LEFT(m.lcReg, 1)) AND ISALPHA(SUBSTR(m.lcReg, 2, 1)) AND ;
|
|
ISDIGIT(SUBSTR(m.lcReg, 3, 1)) AND ;
|
|
LEN(CHRTRAN(SUBSTR(m.lcReg, 3), CHRTRAN(SUBSTR(m.lcReg, 3), '0123456789', ''), '')) = 6
|
|
ENDFUNC
|
|
*
|