#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 * * Normalizeaza codul fiscal / CNP primit din import (Fidelio hotel, BIZ restaurant). * Intoarce codul curatat daca este valid, altfel SIR GOL, ca sa nu dea erori la D394/D406. * * ATENTIE: algoritmul de validare (CNP si CUI) este DOAR pentru Romania. Partenerii straini * au coduri care nu respecta regulile romanesti (BE0325777171, DICA9712015/99KS, NN9J17714), * deci NU se valideaza si NU se sterg: se pastreaza asa cum vin, ca persoana juridica. * * Cod considerat ROMANESC: * - numai cifre (eventual cu spatii, puncte, liniute), SAU * - prefix 'RO' / 'CUI' / 'CF' urmat de cifre * Pentru codurile romanesti: * - 13 cifre => CNP, validat cu cifra de control (cValidCNP); invalid => '' * - 2-10 cifre => CUI persoana juridica, validat cu VerifCF; invalid => '' * - alta lungime (12, 14, 15 cifre etc.) => invalid => '' * Pentru orice alt cod cu litere (partener strain, pasaport) => se intoarce codul curatat de * spatii duble, fara validare. * * Parametri: * tcCod - codul brut din import * tnTipPersoana - optional, prin referinta: 1 = juridica, 2 = fizica, 0 = necunoscut * tcCodTara - optional, codul de tara al partenerului ('RO', 'BE', ...). Daca este * completat si nu este 'RO', codul NU se valideaza cu regulile romanesti. FUNCTION GetCodFiscalValid LPARAMETERS tcCod, tnTipPersoana, tcCodTara LOCAL lcCod, lcCifre, lcPrefix, lcTara, llRO, llRomanesc, lnParam lnParam = PCOUNT() IF m.lnParam > 1 tnTipPersoana = 0 ENDIF lcCod = ALLTRIM(UPPER(TRANSFORM(NVL(m.tcCod, '')))) lcCod = ALLTRIM(CHRTRAN(m.lcCod, CHR(9) + CHR(13) + CHR(10), ' ')) IF EMPTY(m.lcCod) RETURN '' ENDIF lcTara = IIF(m.lnParam > 2 AND VARTYPE(m.tcCodTara) = 'C', ALLTRIM(UPPER(m.tcCodTara)), '') * partea numerica: GetNrFromString taie prefixul de litere/separatori ('RO 15613488' -> '15613488') lcCifre = ALLTRIM(GetNrFromString(m.lcCod)) lcCifre = CHRTRAN(m.lcCifre, CHRTRAN(m.lcCifre, '0123456789', ''), '') * prefixul de litere ramas in fata cifrelor (RO, CUI, CF, BE, DICA...) lcPrefix = ALLTRIM(CHRTRAN(m.lcCod, CHRTRAN(m.lcCod, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', ''), '')) llRO = INLIST(m.lcPrefix, 'RO', 'CUI', 'CF', 'CIF') * romanesc = fara litere deloc, sau cu prefix romanesc, si fara tara straina declarata llRomanesc = (EMPTY(m.lcPrefix) OR m.llRO) AND ; (EMPTY(m.lcTara) OR m.lcTara == 'RO' OR m.lcTara == 'ROMANIA') IF !m.llRomanesc * partener strain: nu pot valida cu algoritmul romanesc, pastrez codul asa cum vine IF m.lnParam > 1 tnTipPersoana = 1 ENDIF RETURN ALLTRIM(STRTRAN(m.lcCod, ' ', ' ')) ENDIF IF EMPTY(m.lcCifre) RETURN '' ENDIF DO CASE CASE LEN(m.lcCifre) = 13 AND !m.llRO IF cValidCNP(m.lcCifre) IF m.lnParam > 1 tnTipPersoana = 2 ENDIF RETURN m.lcCifre ENDIF RETURN '' CASE BETWEEN(LEN(m.lcCifre), 2, 10) IF VerifCF(m.lcCifre) IF m.lnParam > 1 tnTipPersoana = 1 ENDIF RETURN IIF(m.llRO, 'RO' + m.lcCifre, m.lcCifre) ENDIF RETURN '' OTHERWISE RETURN '' ENDCASE ENDFUNC *