*!* 07.09.2009 *!* marius.mutu *!* ROA.H *!* 04.08.2011 *!* marius.mutu *!* adaugare functia GetDataIreg *!* 01.04.2013 *!* marius.mutu *!* GET_SCHEMA_GRID - trateaza cazul 0.00 *!* 05.10.2016 *!* marius.mutu *!* Get_Ora - se intoarce dataora de pe server sau de pe calculatorul local in functie de settings.ini [general]tipdataora=server/local/nimic *!* 10.01.2018 *!* marius.mutu *!* VerificaCodFiscal: completare verificare ANAF cu stare TVA Incasare, Split TVA, Inactiv *!* 11.07.2018 *!* marius.mutu *!* + GetSemnatura - INTOCMIT/VERIFICAT/DIRECTOR/DIRECTOR ECONOMIC - listare balanta, registre tva, fisa cont, reg. jurnal *!* 03.10.2019 *!* marius.mutu *!* + Atasament2File *!* 10.01.2019 *!* marius.mutu *!* + VerificaFacturaClientiVanzari *!* 23.01.2020 *!* marius.mutu *!* File2Atasament - Citeste fisierul de pe disk si adauga atasament in baza de date atas_atasamente *!* 13.11.2020 *!* +xdir((): Get Files in Directory (including subdirectories) *!* +UpdatePageTotalGroup(): Functie pentru calculul _PAGETOTAL pentru grupuri care reseteaza pagina la 1 intr-un raport *!* 09.12.2020 *!* Atasament2File *!* Suprascriu fisierul din baza de date cu fisierul de pe disk doar daca dataora din baza de date > data fisierului de pe disk *!* 03.02.2021 *!* xdir - declarat variabile locale *!* la apelarea recursiva ramanea ultimul director parcurs, in loc sa se revina la directorul din iteratia corespunzatoare *!* 15.01.2024 *!* GetSemnatura - + parametru prefix *!* 03.09.2024 *!* ProcentTva2IdJtva - tratare procent TVA 0 si taxare inversa (eFactura) *!* 05.12.2024 *!* GetArticolEFByPartDenumire - caut si articolele fara id_articol, in caz ca sunt servicii, nu articole gestionabile ROA *!* 15.01.2025 *!* GetDocumentByContPartenerAct - se cauta comanda si in IREG_PARTENERI.EXPLICATIA *!* 17.07.2025 *!* ProcentTva2IdJtva - cote TVA 21% si 11% *!* 22.07.2025 *!* GetNamePermutations - limitare la 4 cuvinte si maxim 10 permutari #Include COMUN\ROA.H Define Class oexecutor As Custom nHandle = 0 cSql = '' 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. 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) This.nHandle = gnHandle Else This.nHandle = tnHandle Endif Endproc ******************************************* SFARSIT: INIT ******************************************* *--------------------------------------- * Intoarce .T. daca goConn.nHandle > 0 *--------------------------------------- FUNCTION IsConnected RETURN goConn.IsConnected() ENDFUNC && IsConnected ******************************************* INCEPUT:oExecuta ******************************************* Function oExecuta ( tcSql, tcCursor, tlProgress, tcTitluProgress, tnHandle, tlShowError, tlQuitOnError, tlReconnect ) Local lnSucces, llOk llOk = .T. *!* modificare 06.09.2012 *!* lnSucces = This.oExecute(tcSql, tcCursor, tlProgress, tcTitluProgress, tnHandle, tlShowError, tlQuitOnError, tlReconnect) Do Case Case Pcount() < 6 lnSucces = This.oExecute(Iif(Empty(tcSql), This.cSql, tcSql), ; Iif(Empty(tcCursor), This.cCursor, tcCursor), ; tlProgress, tcTitluProgress, ; Iif(Empty(tnHandle), This.nHandle, tnHandle)) Case Pcount() < 7 lnSucces = This.oExecute(Iif(Empty(tcSql), This.cSql, tcSql), ; Iif(Empty(tcCursor), This.cCursor, tcCursor), ; tlProgress, tcTitluProgress, ; Iif(Empty(tnHandle), This.nHandle, tnHandle), ; tlShowError) Case Pcount() < 8 lnSucces = This.oExecute(Iif(Empty(tcSql), This.cSql, tcSql), ; Iif(Empty(tcCursor), This.cCursor, tcCursor), ; tlProgress, tcTitluProgress, ; Iif(Empty(tnHandle), This.nHandle, tnHandle), ; tlShowError, tlQuitOnError) Otherwise lnSucces = This.oExecute(Iif(Empty(tcSql), This.cSql, tcSql), ; Iif(Empty(tcCursor), This.cCursor, tcCursor), ; tlProgress, tcTitluProgress, ; Iif(Empty(tnHandle), This.nHandle, tnHandle), ; tlShowError, tlQuitOnError, tlReconnect) Endcase *!* modificare 06.09.2012 ^ If lnSucces < 0 amessagebox(This.oPrelucrareEroare(), 16, "Eroare") llOk = .F. Endif Return llOk Endfunc ******************************************* SFARSIT:oExecuta ******************************************* * 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( tcSql, tcCursor, tlProgress, tcTitluProgress, tnHandle, tlShowError, tlQuitOnError, tlReconnect ) Local lnHandle, lcSql, lcCursor, llProgress, lnSucces, laEroare, lcEroare, llShowError, llQuitOnError, llReconnect && orice modificare aici trebuie facuta si in oExecuta && tlQuitOnError : Daca face QUIT la eroare (daca vreau QUIT dau .T.) (default .F.) && tlShowError : Daca arata mesajul de eroare (daca vreau sa il tratez in oexecute dau .T.) (default .F.) && tlReconnect : Daca incearca sa se reconecteze (default .T.) Local lcSeconds lcSeconds = Set("Seconds") Set Seconds On If .F. Local This As oexecutor Endif This.Oreset() If Type('goLog') = 'O' goLog.Log(tcSql, Program()) Endif Local lnTip lnTip = 0 *!* 29.06.2007 *!* marius.mutu *!* nu puneti upper(lcSql) - exista unele expresii in oracle care sunt case sensitive If Empty(tcSql) lcSql = This.cSql Else lcSql = tcSql Endif If Empty(tcCursor) lcCursor = This.cCursor Else lcCursor = tcCursor Endif If Empty(tnHandle) lnHandle = This.nHandle Else lnHandle = tnHandle Endif IF (m.lnHandle <= 0) This.nSucces = CT_INSUCCES This.cEroare = 'Neconectat' RETURN CT_INSUCCES ENDIF && DACA AM TRANZACTIE MANUALA NU FAC RECONNECT If SQLGetprop(lnHandle, "Transactions") = 2 && TRANZACTIE MANUALA This.lReconnect = .F. Else This.lReconnect = .T. Endif Do Case Case Pcount() < 6 llQuitOnError = This.lQuitOnError llReconnect = This.lReconnect llShowError = This.lShowError Case Pcount() < 7 llQuitOnError = This.lQuitOnError llReconnect = This.lReconnect *!* modificare 06.09.2012 Case Pcount() < 8 llReconnect = This.lReconnect *!* modificare 06.09.2012 ^ Otherwise llShowError = tlShowError llReconnect = tlReconnect llQuitOnError = tlQuitOnError Endcase lnSucces = This.nSucces llProgress = tlProgress && IIF(tlProgress or 'SELECT'$lcSql,.T.,.F.) lcTitluProgress = Iif(Empty(tcTitluProgress), "", Alltrim(tcTitluProgress)) Declare laEroare[1] lcEroare = '' lnTip = Iif('ROLLBACK' $ lcSql Or 'COMMIT' $ lcSql, 1, 0) && daca ROLLBACK SAU COMMIT TIP = 1, ALTFEL 0 Do Case Case lnTip = 0 *!* If llProgress *!* Local loTherm, lcTask, lnPercent, lnSeconds *!* If !Empty(lcTitluProgress) *!* lcTask = lcTitluProgress *!* Else *!* lcTask = "Se executa ... " *!* Endif *!* loTherm = Newobject("_thermometer","_therm","",lcTask) *!* lnPercent = 15 *!* loTherm.Show() *!* Endif *!* Do While .T. *!* If llProgress *!* lnPercent = lnPercent + 5 *!* If lnPercent > 90 *!* lnPercent = 15 *!* Endif *!* loTherm.Update(lnPercent, lcTask+" "+Trans(lnPercent)) *!* Endif *!* lnSucces = SQLExec(lnHandle,lcSql,lcCursor) *!* If lnSucces = 0 *!* * *!* Else *!* Exit *!* Endif *!* Enddo *!* If llProgress *!* loTherm.Complete() *!* Release loTherm *!* Endif If llProgress Local loTherm, lcTask, lnPercent, lnSeconds If !Empty(lcTitluProgress) lcTask = lcTitluProgress Else lcTask = "Se executa ... " Endif loTherm = Newobject("_thermometer", "_therm", "", lcTask) lnPercent = 15 loTherm.Show() Endif lnSucces = -1 Do While .T. Do While .T. If llProgress lnPercent = lnPercent + 5 If lnPercent > 90 lnPercent = 15 Endif loTherm.Update(lnPercent, lcTask + " " + Trans(lnPercent)) Endif lnSucces = SQLExec(lnHandle, lcSql, lcCursor) If lnSucces = 0 * Else Exit Endif Enddo If lnSucces > 0 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 Endif If lnSucces < 0 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] lnHandle = laEroare[6] llEroare = .T. Endif Do Case Case lnEroare1 <> 1526 && eroare <> ODBC lcTextEroare = Program() + Chr(13) + Alltrim(Str(lnEroare1)) + ' ' + laEroare[2] + crlf + crlf + GETCALLSTACK() If Type('goLog') = 'O' goLog.Log(lcTextEroare, Program()) Endif If llShowError amessagebox(lcTextEroare, 0, "Eroare") Endif If llQuitOnError Quit Retry Else Exit Endif Case lnEroare1 = 1526 && eroare ODBC Do Case Case llReconnect And Inlist(lnEroare2, 12152, 3113, 3114, 12560, 4068, 28, 12) && 12512 = TNS: UNABLE TO SEND BREAK MESSAGE; 3114 = NOT CONNECTED TO ORACLE; 12560 = PROTOCOL ADAPTER ERROR If Type('goLog') = 'O' lcLog = laEroare(3) + crlf + crlf + GETCALLSTACK() goLog.Log(lcLog, Program()) Endif Do While .T. lnRaspuns = amessagebox('Eroare de conectare.' + Chr(13) + lcTextEroare + Chr(13) + 'Doriti reconectare?', 4 + 32, 'Eroare') && retry = 4; cancel = 2 If lnRaspuns = 6 lnHandle = goConn.Connect(goConn.cHost, goConn.cUser, goConn.cPassword, llReconnect) *!* gnHandle = SQLConnect(gcHost,gcUserName,gcPassword) If lnHandle < 0 Declare laEroare2(1) Aerror(laEroare2) lcTextEroare = laEroare2(3) If Type('goLog') = 'O' goLog.Log(lcTextEroare, Program()) Endif Release laEroare2 Loop Else *!* goExecutor.nHandle = gnHandle Exit Endif Else Quit Retry Endif && lnRaspuns = 6 Enddo && .T. Loop && daca am iesit cu un handle valid intru din nou in loop si fac cursorfill Otherwise lcTextEroare = Program() + crlf + Alltrim(Str(lnEroare1)) + ' ' + crlf + Transform(laEroare[3]) + crlf + lcSql + crlf + crlf + GETCALLSTACK() If llShowError lnRaspuns = amessagebox('Eroare necunoscuta' + Chr(13) + lcTextEroare, 0, 'Eroare') && ok = 0 Endif If Type('goLog') = 'O' goLog.Log(lcTextEroare, Program()) Endif If llQuitOnError Quit Retry Else Exit Endif Endcase && INLIST(lnEroare2,12152,3114) Endcase Endif && lnSucces < 0 Enddo && .T. If llProgress loTherm.Complete() Release loTherm Endif Case lnTip = 1 If 'ROLLBACK' $ lcSql lnSucces = Sqlrollback(lnHandle) Else lnSucces = Sqlcommit(lnHandle) Endif Endcase If lnSucces < 0 Aerror(laEroare) If laEroare[1] <> 1526 lcEroare = laEroare[2] Else lcEroare = Alltrim(Transform(laEroare[1])) + crlf + + Alltrim(Transform(laEroare[3])) + crlf + lcSql + crlf + crlf + GETCALLSTACK() *!* 07.02.2008 This.cEroare = lcEroare lcEroare = This.oPrelucrareEroare() *!* 07.02.2008 ^ Endif If Type('goMyXMLHTTP') = 'O' lcLunaHTTP = Iif(Type('gnLuna') = 'N', Transform(gnLuna) + "/", "") + Iif(Type('GNAN') = 'N', Transform(gnAn), "") lcErrorHTTP = Sys(0) + ":" + Iif(Type('GCS') = 'C', " " + GCS, "") + ": " + lcLunaHTTP + Chr(13) + Chr(10) + lcEroare + ; Chr(13) + Chr(10) + Chr(13) + Chr(10) + GETCALLSTACK() lcUserName = gcUserNameApp lcProgram = Juststem(Sys(16, 0)) goMyXMLHTTP.postError(lcErrorHTTP, lcUserName, lcProgram) Endif If llShowError amessagebox(lcEroare, 0, "Eroare") Endif If llQuitOnError Quit Retry Endif Endif This.aEroare = laEroare This.nSucces = lnSucces This.cEroare = lcEroare This.nEroare = Iif(Alen(laEroare) >= 5, laEroare[5], 0) Set Seconds &lcSeconds *!* modificare ROAFACTURARE v 2.0.77 *!* *!* 07.09.2009 *!* *!* RETURN lnSucces *!* Return IIF(lnSucces = 1, CT_SUCCES, CT_INSUCCES) Return Iif(lnSucces >= 1, CT_SUCCES, CT_INSUCCES) *!* *!* 07.09.2009 ^ *!* modificare ROAFACTURARE v 2.0.77 ^ 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 > 0 tuRetValue = Evaluate(lcField) If Used(lcCursor) Use In (lcCursor) Endif Endif *!* 07.09.2009 *!* RETURN lnSucces Return Iif(lnSucces = 1, CT_SUCCES, CT_INSUCCES) *!* 07.09.2009 ^ Endfunc && oFunction2Value ******************************************* SFARSIT: oFunction2Value ******************************************* *!* salveaza rezultatul unui select in variabila data ca referinta *!* daca se intorc mai multe randuri - eroare *!* intoarce SUCCES = .T./.F. *!* afiseaza mesajul de eroare, daca este cazul *!* lnSucces = oSelecteaza2Value("Select sum(cantitate) from tabel where conditie", @pnReturnValue) Function oSelecteaza2Value Lparameters tcSql, tuRetValue * tlShowError, daca afiseaza mesaje de eroare Local lnSucces lnSucces = This.oSelect2Value(m.tcSql, @m.tuRetValue) If m.lnSucces = CT_INSUCCES amessagebox(This.oPrelucrareEroare(), 16, "Eroare") Endif Return (m.lnSucces = CT_SUCCES) Endfunc &&oSelect2Value ******************************************* 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 = tcSql lcCursor = Sys(2015) lnSucces = This.oExecute(lcSql, lcCursor) If lnSucces > 0 If Reccount(lcCursor) > 1 This.nSucces = -1 This.cEroare = 'Au rezultat mai multe valori. Se astepta o singura valoare.' lnSucces = -1 Else lcField = lcCursor + '.' + Field(1) tuRetValue = Evaluate(lcField) Endif If Used(lcCursor) Use In (lcCursor) Endif Endif Select (lcSelect) *!* 07.09.2009 *!* RETURN lnSucces Return Iif(lnSucces = 1, CT_SUCCES, CT_INSUCCES) *!* 07.09.2009 ^ Endfunc &&oSelect2Value ******************************************* SFARSIT: oFunction2Value ******************************************* *!* salveaza rezultatul unui select in variabila data ca referinta *!* daca se intorc mai multe randuri - eroare *!* intoarce SUCCES = T/F *!* llSucces = goExecutor.oSelecteaza2Object("Select id, denumire from tabel where conditie", @poObject) Function oSelecteaza2Object Lparameters tcSql, toRetValue Local lcSelect, lcSql, lcCursor, lcField, llSucces lcSelect = Select() lcSql = tcSql lcCursor = Sys(2015) llSucces = This.oExecuta(lcSql, lcCursor) If m.llSucces If Reccount(m.lcCursor) > 1 This.nSucces = -1 This.cEroare = 'Au rezultat mai multe valori. Se astepta o singura valoare.' llSucces = .F. Else Select (m.lcCursor) Scatter Name toRetValue Memo Endif Use In (Select(m.lcCursor)) Endif && llSucces Select (m.lcSelect) Return m.llSucces Endfunc &&oSelecteaza2Object ******************************************* SFARSIT: oSelecteaza2Object ******************************************* ******************************************* 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) 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 = '' nHandle = 0 cEroare = '' Declare aEroare[7] lShowError = .F. lReconnect = .F. && Daca llReconnect = .T. se apeleaza InitSesiune din oInit_Optiuni.prg FUNCTION IsConnected RETURN (This.nHandle > 0) ENDFUNC && IsConnected *** 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 If Pcount() < 3 Or Type('tcHost') # 'C' Or Type('tcUser') # 'C' Or Type('tcPassword') # 'C' * Else This.cHost = tcHost This.cUser = tcUser This.cPassword = tcPassword Endif lcHost = This.cHost lcUser = This.cUser lcPassword = This.cPassword If Pcount() < 4 Or Type('tlReconnect') # 'L' llReconnect = This.lReconnect Else llReconnect = tlReconnect Endif SQLSetprop(0, "DispLogin", 3) lcString = "dsn=" + Alltrim(lcHost) + ";Uid=" + Alltrim(lcUser) + ";Pwd=" + Alltrim(lcPassword) + ";" This.nHandle = Sqlstringconnect(lcString) If Type('gnHandle') = 'N' gnHandle = This.nHandle Endif If Type('goExecutor') = 'O' goExecutor.nHandle = This.nHandle Endif If This.nHandle > 0 lnSucces = 1 *** SETARI SESIUNE DUPA CONECTARE This.postConn() If llReconnect lnSucces = InitSesiune() && IN oInit_Optiuni.prg Endif Else lnSucces = -1 This.ProcessError() Endif Return This.nHandle Endproc && Connect *** END Connect =========================================================================================== *** Disconnect =========================================================================================== Procedure Disconnect Lparameters tnHandle Local lnSucces, lnHandle lnHandle = Iif(Empty(tnHandle) Or Type('tnHandle') # 'N', 0, tnHandle) lnSucces = SQLDisconnect(lnHandle) If lnSucces < 0 This.ProcessError() Endif *!* 07.09.2009 *!* RETURN lnSucces Return Iif(lnSucces = 1, CT_SUCCES, CT_INSUCCES) *!* 07.09.2009 ^ Endproc && *** END Disconnect =========================================================================================== *** ProcessError =========================================================================================== Procedure ProcessError Local laEroare, lnEroare1, lnEroare2, lcTextEroare, lcEroareConectare lcTextEroare = '' lcEroareConectare = '' Dimension laEroare[1] Aerror(laEroare) If Alen(laEroare) > 1 lnEroare1 = laEroare[1] lnEroare2 = laEroare[5] lcTextEroare = laEroare[3] lnHandle = laEroare[6] llEroare = .T. lcTextEroare = 'Conectarea nu a reusit ' + Chr(13) + Chr(10) + Alltrim(Transform(laEroare[1])) + ' ' + Chr(13) + Transform(laEroare[2]) + Chr(13) + Transform(laEroare[3]) This.cEroare = lcTextEroare This.aEroare = laEroare If Type('goLog') = 'O' goLog.Log(lcTextEroare, Program()) Endif If laEroare[1] = 1526 And Like('*ORA-20???:*', laEroare[2]) lnPozi = At("ORA-20", laEroare[2]) + 11 lnPozf = At("ORA", laEroare[2], 3) lcEroareConectare = Substr(laEroare[2], lnPozi, lnPozf - lnPozi) Else lcEroareConectare = lcTextEroare Endif If Empty(lcEroareConectare) lcEroareConectare = "Conectarea nu a reusit!" Endif amessagebox(lcEroareConectare, 0 + 48, "Atentie") Endif Return lcTextEroare Endproc && ProcessError *** END ProcessError =========================================================================================== *** postConn =========================================================================================== Procedure postConn *** PUNCT ZECIMAL lcSql = [ALTER SESSION SET NLS_NUMERIC_CHARACTERS = ".,"] lnSucces = goExecutor.oExecute(lcSql) If lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 16, 'Eroare') Endif Endproc && postConn *** END postConn =========================================================================================== Procedure BeginManualTransaction Local lnHandle, lnSucces, llSucces lnHandle = This.nHandle llSucces = .T. If SQLGetprop(lnHandle, "Transactions") = 1 && TRANZACTIE AUTOMATA lnSucces = SQLSetprop(m.lnHandle, "Transactions", 2) && TRANZACTIE MANUALA llSucces = (m.lnSucces = 1) Endif Return m.llSucces Endproc && BeginManualTransaction Procedure EndManualTransaction Lparameters tcMode *** tcMode: optional: COMMIT/ROLLBACK/EMPTY (DEFAULT) Local lnHandle, lcMode, lnSucces, llSucces lcMode = Iif(!Empty(m.tcMode), Upper(m.tcMode), '') lnHandle = This.nHandle llSucces = .T. If !Empty(m.lcMode) llSucces = goExecutor.oExecuta(m.lcMode) Endif If SQLGetprop(lnHandle, "Transactions") = 2 && TRANZACTIE MANUALA lnSucces = SQLSetprop(m.lnHandle, "Transactions", 1) && TRANZACTIE AUTOMATA llSucces = (m.lnSucces = 1) Endif Return m.llSucces Endproc && BeginManualTransaction Enddefine && oConn *** END oConn =========================================================================================== * PROCEDURE Get_Ora( tnTip ) * Date : 16/11/2004, 08:58:45 * author : marius.mutu * description: ****** PARAMETER BLOCK ************** * Parameters : 1 * Parameter 1: * ******************************************* INCEPUT:Get_Ora ******************************************* Procedure Get_Ora( tnTip ) * tnTip: 1 sau nimic = DATETIME ; 2 = CHARACTER Local lcRetVal, lnSucces Local lcCursor, lcSql, lcSelect, lcTipDataOra lcSelect = Select() If Pcount() = 0 Or Type('tnTip') <> 'N' lnTip = 1 Else lnTip = tnTip Endif lcTipDataOra = Lower(Nvl(goAPI.GetProfileString(m.gcSettingsFile, [general], "tipdataora"), '')) && local/server lcTipDataOra = Iif(!Inlist(m.lcTipDataOra, 'local', 'server', 'nimic'), 'server', m.lcTipDataOra) Do Case Case m.lcTipDataOra = 'server' &&preluare ora de pe oracle server: Store - 1 To lnSucces lcSql = [select to_char(SYSdate,'dd/mm/yyyy hh24:mi:ss') as dataora from dual] lcCursor = [dataora_cursor] lnSucces = goExecutor.oExecute(lcSql, lcCursor) If lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 16, , 'Eroare') lcRetVal = Ttoc(Datetime()) Else Select dataora_cursor lcRetVal = dataora_cursor.dataora Use In dataora_cursor Endif If lnTip = 1 lcRetVal = Ctot(lcRetVal) Endif Case m.lcTipDataOra = 'local' * local = ora de pe calculator lcRetVal = Iif(lnTip = 1, Datetime(), '* ' + Ttoc(Datetime())) Otherwise && nimic lcRetVal = Iif(lnTip = 1, Datetime(), '*') Endcase If !Empty(lcSelect) Select (lcSelect) Endif Return lcRetVal Endproc ******************************************* SFARSIT: Get_Ora ******************************************* *________________________________________________________ Function ULTIMAZI Parameters tcAn, tcLuna Local lcAn, lcLuna If Empty(tcAn) lcAn = pcAn Else lcAn = Alltrim(tcAn) Endif If Empty(tcLuna) lcLuna = pcNl Else lcLuna = Alltrim(tcLuna) Endif If Val(lcAn) = Year(Date()) And Val(lcLuna) = Month(Date()) Return Date() Endif lcData = '01/' + lcLuna + '/' + lcAn ldData = Gomonth(Ctod(lcData), 1) - 1 Return ldData **************************************************************** Function get_nivel_upf(tnid_util, tnid_prog, tnid_firma) Private pnid_util, pnid_prog, pnid_firma pnid_util = tnid_util pnid_prog = tnid_prog pnid_firma = tnid_firma Local lnnivel lcSql = [select ud.id_nivel,n.nivel from contafin_oracle.util_drept ud ] + ; [join contafin_oracle.nivel n on ud.id_nivel = n.id_nivel ] + ; [where ud.id_util = ?pnid_util and ud.id_prog = ?pnid_prog and ] + ; [ud.id_firma = ?pnid_firma] lcCursor = [crsUtilNivel] lnSucces = goExecutor.oExecute(lcSql, lcCursor) If lnSucces < 0 lcTitlu = [Eroare] lctip = [Avertizare] lcImagine = [exclam.ico] lcMesaj = goExecutor.cEroare ofrm_eroare = Createobject('frm_mesaj', lcTitlu, lcImagine, lctip, lcMesaj) ofrm_eroare.Show(1) Release ofrm_eroare Return Endif lnnivel = &lcCursor..nivel Return lnnivel Endfunc &&get_nivel_upf ******************************************************************************************************* Function enumefis Parameters tc_numefis Private pn_len, pl_return, pc_numefis, pc_char pn_len = 0 pc_char = '' pl_return = .T. pc_numefis = Alltrim(tc_numefis) pn_len = Len(pc_numefis) If pn_len = 0 pl_return = .F. Endif Do While pn_len > 0 pc_char = Substr(pc_numefis, pn_len, 1) If !Between(Asc(pc_char), 48, 57) And !Between(Asc(pc_char), 97, 122) And !Between(Asc(pc_char), 65, 90) And Asc(pc_char) <> 95 And Asc(pc_char) <> 46 pl_return = .F. Exit Endif pn_len = pn_len - 1 Enddo Return pl_return Endfunc && enumefis *********************************************************************************************** ******************************************* * PROCEDURE ImportTable * Date : 08/07/2005, 09:20:54 * author : marius.mutu * description: intoarce numele unui cursor cu datele importate dintr-un dbf ******************************************* Procedure ImportTable Local lcCursor lcCursor = "" loimport = Newobject("frm_import", "importdata") loimport.Show(1) If gnButon = 1 lcCursor = "crsReturn" Endif Return lcCursor Endproc *----------------------------------sfarsit procedura ImportTable---------------------------------- Function Lista_Campuri Lparameters tcAlias Local lcSelect, i, lcAlias, lcLista lcLista = [] lcSelect = Select() lcAlias = tcAlias Select (lcAlias) lnFields = Fcount() For i = 1 To lnFields lcField = Field(i) lcLista = lcLista + [,] + lcField Endfor If !Empty(lcLista) lcLista = Substr(lcLista, 2) Endif Select (lcSelect) Return lcLista Endfunc && Lista_Campuri ***--------------------------------------------------------------------- Procedure OPEN_DEFAULT_APP Parameters tcfilename, tcParams LOCAL cFileName, cAction, cParams Declare Integer ShellExecute In shell32.Dll ; Integer hndWin, ; String cAction, ; String cFileName, ; String cParams, ; String cDir, ; Integer nShowWin cFileName = tcfilename cAction = "open" cParams = IIF(!EMPTY(m.tcParams), m.tcParams, "") ShellExecute(0, cAction, cFileName, cParams, "", 1) Endproc && OPEN_DEFAULT_APP ***--------------------------------------------------------------------- Procedure GET_SCHEMA_GRID Lparameters toGrid, tcColumnList, tcHeaderList, tcSchema, tlSelect, tnType, tcFrom, tcWhere, tcOrder, tcOutputName Local lcSelect, llSelect, lcAlias, lcWhere, lcOrder, lcColumn, lcHeader, lnOccurs Local lnType, lcInto && tnType : 0 CURSOR, 1 TABLE, 2 ARRAY If Type('tnType') # 'N' lnType = 0 Else If !Between(tnType, 0, 2) lnType = 0 Else lnType = tnType Endif Endif Do Case Case lnType = 0 lcInto = ' INTO CURSOR ' Case lnType = 1 lcInto = ' INTO TABLE ' Other lnType = 1 lcInto = ' INTO ARRAY ' Endcase tcColumnList = '' tcHeaderList = '' tcSchema = '' lnNrCol = toGrid.ColumnCount Dimension myArray[lnNrCol, 3] With toGrid For lnCol = 1 To .ColumnCount lnColumn = .Columns(lnCol).ColumnOrder lcColumn = .Columns(lnCol).ControlSource llVisible = .Columns(lnCol).Visible lnWidth = .Columns(lnCol).Width If !llVisible Or lnWidth = 0 Or Empty(Alltrim(lcColumn)) Adel(myArray, lnCol) Loop Endif lnPos = At('.', lcColumn) lnOccurs = Occurs('.', m.lcColumn) If m.lnOccurs = 1 And m.lnPos > 0 lcColumn = Substr(lcColumn, lnPos + 1) Endif *tcColumnList = tcColumnList + lcColumn + ',' myArray[lnCol, 1] = lnColumn For lnobjcol = 1 To .Columns(lnCol).Objects.Count If Upper(.Columns(lnCol).Objects(lnobjcol).BaseClass) = 'HEADER' lcHeader = .Columns(lnCol).Objects(lnobjcol).Caption lcHeader = Strtran(Strtran(Strtran(Strtran(Strtran(Strtran(Strtran(Strtran(Strtran(lcHeader, Chr(32), '_'), '.', '_'), '/', '_'), '\', '_'), "&", "_"), "%", ""), "(", "_"), ")", "_"), "-", "_") lcHeader = Strtran(lcHeader, '=', '_') lcHeader = Strtran(lcHeader, ',', '_') lcHeader = Strtran(lcHeader, '+', '_') *tcHeaderList = tcHeaderList + lcHeader + ',' *tcSchema = tcSchema + lcColumn + [ as ] + lcHeader + [,] myArray[lnCol, 2] = lcColumn myArray[lnCol, 3] = lcHeader Exit Endif Endfor Endfor *!* tcColumnList = Substr(tcColumnList, 1, Len(tcColumnList)-1) *!* tcHeaderList = Substr(tcHeaderList , 1, Len(tcHeaderList)-1) *!* tcSchema = Substr(tcSchema , 1, Len(tcSchema)-1) Endwith For i = 1 To Alen(myArray, 1) l1 = myArray[i, 1] If Type('l1') # 'N' myArray[i, 1] = -1 Endif Endfor Asort(myArray) For i = 1 To Alen(myArray, 1) If myArray[i, 1] <> -1 tcColumnList = tcColumnList + Alltrim(myArray[i, 2]) + [,] tcHeaderList = tcHeaderList + Alltrim(myArray[i, 3]) + [,] tcSchema = tcSchema + Alltrim(myArray[i, 2]) + [ as ] + Alltrim(myArray[i, 3]) + [,] Endif Endfor tcColumnList = Substr(tcColumnList, 1, Len(tcColumnList) - 1) tcHeaderList = Substr(tcHeaderList, 1, Len(tcHeaderList) - 1) tcSchema = Substr(tcSchema, 1, Len(tcSchema) - 1) If tlSelect tcSchema = 'SELECT ' + tcSchema Endif If !Empty(tcFrom) tcSchema = tcSchema + ' FROM ' + Alltrim(tcFrom) Endif If !Empty(tcWhere) tcSchema = tcSchema + ' WHERE ' + Alltrim(tcWhere) Endif If !Empty(tcOrder) tcSchema = tcSchema + ' ORDER BY ' + Alltrim(tcOrder) Endif If !Empty(tcOutputName) tcSchema = tcSchema + lcInto + tcOutputName Endif Endproc && GET_SCHEMA_GRID ***--------------------------------- Procedure amessage Lparameters tcMessage, tnDialogBoxType, tcTitleBarText, tnTimeOut Local lnResponse lnResponse = 0 lcMessage = Iif(Empty(tcMessage), [], tcMessage) lnDialogBoxType = Iif(Empty(tnDialogBoxType), 0, tnDialogBoxType) lcTitleBarText = Iif(Empty(tcTitleBarText), [], tcTitleBarText) lnTimeOut = Iif(Empty(tnTimeOut), 0, tnTimeOut) If lnTimeOut # 0 lnResponse = amessagebox(lcMessage, lnDialogBoxType, lcTitleBarText, lnTimeOut) Else lnResponse = amessagebox(lcMessage, lnDialogBoxType, lcTitleBarText) Endif Return lnResponse Endproc && amessage ***--------------------------------- DEFINE CLASS oChatBotLaunch as Custom cMessage = '' FUNCTION Init LPARAMETERS tcMessage This.cMessage = m.tcMessage ENDFUNC FUNCTION Launch open_default_app('https://www.romfast.ro/chatbot_maria.html?message=' + ALLTRIM(This.cMessage)) ENDFUNC ENDDEFINE ***--------------------------------- Function amessagebox Lparameters tcMessage, tnDialogBoxType, tcTitle, tcFont, tnTimeOut, tnTimeoutValue Local loMessage, lnReturn, lcMessageboxForm PRIVATE oChatbot oChatBot = CREATEOBJECT("oChatBotLaunch", m.tcMessage) *!* *!* 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('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.AlwaysOnTop = .T. loMessage.Show(1) lnReturn = loMessage.IDOpcion Endif Return lnReturn Endfunc && amessagebox ***--------------------------------- Procedure export_xls Lparameters tcAlias, tcNumeFisier If Empty(tcNumeFisier) tcNumeFisier = 'Foaie_Excel' Endif Local lcSelect lcSelect = Select() If Used(tcAlias) lcDir = Addbs(gcTempPath) lcFile = Putfile('Nume fisier:', tcNumeFisier, 'XLS') If Empty(lcFile) && Esc pressed Return Endif Select (tcAlias) Export To (lcFile) Type Xl5 Select (lcSelect) OPEN_DEFAULT_APP(lcFile) Endif Endproc && export_xls *__________________________________________________________ && Folosesc un tabel (tabel,id) cu cate o linie pt fiecare tabel && aflu id-ul urmator si il scriu in tabela && returnez id-ul && EX1: LNEW_ID=NEW_ID("GRILA_SAL") --> urmatorul id din fara cautare in tabela originala && EX2: LNEW_ID=NEW_ID("GRILA_SAL","ID") --> urmatorul id din cu cautare in tabela originala dupa campul && ex3: LNEW_ID=NEW_ID("GRILA_SAL","ID",.T.) --> .T. INSEAMNA CA TABELUL ORIGINAL ESTE INDEXAT DUPA FAC SEEK IN LOC DE LOCATE Procedure NEW_ID Parameters TALIAS, TFIELD, TTAG *WAIT WINDOW TALIAS *ON error Errorh(ERROR(),PROGRAM(),LINENO()) LLLOOKUP = Iif(Type("tfield") = "C", .T., .F.) LLTAG = Iif(Type("TTAG") = "C", .T., .F.) TALIAS = Upper(Alltrim(TALIAS)) *** Save Stats LCOLDALIAS = Alias() && keep current work area LNOLDRECNO = Iif(!Eof(), Recno(), 0) && save record number LCSETDEL = Set("deleted") && lnmaxval = (10^pcidsize)-1 && wrap around after this val *** && PUN ORDINEA PE ID If LLLOOKUP And LLTAG Sele (TALIAS) Set Order To &TTAG Endif *** LCNEWID = 0 && our return result - NULL if failed Select IDS Locate For Upper(Alltrim(TABEL)) = TALIAS If !Found() If Flock() Append Blank Replace TABEL With TALIAS Unlock Endif Endif Set Deleted Off && acum sunt pe inregistrarea corecta *** lock counter table and update counter Select IDS If Rlock() *** Avoid use of Macros - Convert to mem var & update it LNCOUNTERVAL = NEW_ID *** VERIFY ID NUMBER - search 'til no match Do While .T. *** increase the counter - update field and var LNCOUNTERVAL = LNCOUNTERVAL + 1 *!* *** check for wraparound *!* IF lncounterval > lnmaxval *!* lncounterval = 1 *!* ENDIF Select (TALIAS) If LLLOOKUP If LLTAG LCAUT = "SEEK " + Allt(Str(LNCOUNTERVAL)) Else LCAUT = "LOCATE FOR " + Allt(TFIELD) + "=" + Allt(Str(LNCOUNTERVAL)) *** now see if it exists &LCAUT * LOCATE FOR &TFIELD=LNCOUNTERVAL If !Found() *** No match - DONE Exit Endif && !found() Endif && lltag Else Exit Endif && lllokup Enddo && done Sele IDS Replace NEW_ID With LNCOUNTERVAL LCNEWID = LNCOUNTERVAL Unlock In IDS Endif && rlock() *** Reset record number on original file If !Empty(LCOLDALIAS) Sele (LCOLDALIAS) If LNOLDRECNO # 0 Goto LNOLDRECNO Endif Endif Set Deleted &LCSETDEL Return LCNEWID Endproc && NEW_ID ***------------------------------------------------------------------------------------------------------- * Foloseste comment de la coloane si tooltiptext de la grid pt a salva recordsource si controlsource din grid inainte de reconstructie Procedure SAVE_GRID 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 ***-------------------------------------------------------------- Procedure RESTORE_GRID 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 ******************************************************************* Procedure snr_grid && switch_and_restore_grid Lparameters toGrid, tcRecordSourceNou Private pogrid If Param() = 0 Or Type('togrid')!= "O" Return .F. Endif pogrid = toGrid With pogrid .RecordSource = Iif(Empty(tcRecordSourceNou), .ToolTipText, tcRecordSourceNou) For m.nColumnIndex = 1 To .ColumnCount .Columns(m.nColumnIndex).ControlSource = Iif(!Empty(tcRecordSourceNou) And !Empty(.Columns(m.nColumnIndex).Tag), ; tcRecordSourceNou + [.] + Substr(.Columns(m.nColumnIndex).Tag, At([.], .Columns(m.nColumnIndex).Tag) + 1), ; .Columns(m.nColumnIndex).Tag) .Tag = "" Endfor .ToolTipText = "" Endwith Return .T. Endproc && snr_grid ******************************************************************* * 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 ******************** *** MENIU POPUP CREAT DINAMIC ******************** PROCEDURE XMENUP LPARAMETERS TCITEMS, TNBAR LOCAL NITEMCOUNT, AITEMS, X LOCAL loMenu, lnOption lnOption = 0 loMenu = NEWOBJECT("popmenu", "menutool.vcx") NITEMCOUNT = OCCURS( ';', TCITEMS ) + 1 DIMEN AITEMS[ m.nItemCount ] NLASTPOS = 1 FOR 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 NLASTPOS = AT( ';', m.TCITEMS, m.X ) + 1 loMenu.ADDITEM(AITEMS[ m.x ], X, 1) ENDFOR lnOption = loMenu.SHOW() RETURN m.lnOption ENDPROC && XMENUP *-------------------- Procedure GETCHOICE m.NSELECT = Bar() Deactivate Popup ( m.CPOPMENU ) Return &&&&&&&&&&&&&&&&&&&&&&&&&&&&&& MENIU &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& Procedure lista2array Parameters tcLISTA, taArray, tcSeparator && tcLista este un sir de caractere care contine elementele separate prin <;> default && tarray este vectorul care se completeaza - trebuie dat prin referinta && tcSeparator separatorul de elemente din tcLista - default este ";" - este optional && intoarce numarul de elemente gasite && ex: lnNr = lista2array("ana;are;mere",@alista,";") External Array taArray Local lcLista, lcSeparator, lnNRF, lcF1, i lnNRF = 0 lcLista = Allt(tcLISTA) If Parameters() < 3 Or Empty(tcSeparator) lcSeparator = ";" Else lcSeparator = Alltrim(tcSeparator) Endif If Right(lcLista, 1)!= lcSeparator lcLista = lcLista + lcSeparator Endif lnNRF = Occurs(lcSeparator, lcLista) If lnNRF > 0 Dimension taArray[lnNrf, 1] For i = 1 To lnNRF lcF1 = Left(lcLista, At(lcSeparator, lcLista) - 1) If i!= lnNRF lcLista = Substr(lcLista, At(lcSeparator, lcLista) + 1) Endif taArray[i] = lcF1 Endfor Else lnNRF = 0 Endif Return lnNRF Endproc && lista2array ***------------------------------------------------------------------------------------------- Procedure get_mask Parameters tnint, tndec Local lnint, lndec lnint = tnint lndec = tndec lnrest = Mod(lnint, 3) lcString = Replicate("9", lnrest) lnint_ramas = lnint - lnrest Do While lnint_ramas > 0 lcString = lcString + " " + Replicate("9", 3) lnint_ramas = lnint_ramas - 3 Enddo If lndec > 0 lcString = lcString + "." + Replicate("9", tndec) Endif Return lcString Endproc && get_mask ******************************************************************* Function formateaza Parameters tnValoare, tnNrCaractere, tnNrZecimale Local lcValoare lcValoare = Strtran(Alltrim(Transform(tnValoare, get_mask(tnNrCaractere, tnNrZecimale))), [.], [,]) Return lcValoare Endfunc && formateaza ******************************************************************* Function tradu Lparameters tcText Local lcText *!* lcText = CPCONVERT(CPCURRENT(1),1252,tcText) lcText = tcText If Type('glFontCharSet') <> 'U' If !Nvl(glFontCharSet, .F.) lcText = Strtran(Strtran(Strtran(Strtran(Strtran(lcText, Chr(227), [a]), Chr(238), [i]), Chr(226), [a]), Chr(186), [s]), Chr(254), [t]) lcText = Strtran(Strtran(Strtran(Strtran(Strtran(lcText, Chr(195), [A]), Chr(206), [I]), Chr(194), [A]), Chr(170), [S]), Chr(222), [T]) Endif Endif Return lcText Endfunc ******************************************************************* * PROCEDURE Get_Version( ) * Date : 17/11/2004, 16:34:20 * author : marius.mutu * description: ****** PARAMETER BLOCK ************** * Parameters : 0 * ******************************************* INCEPUT:Get_Version ******************************************* Procedure Get_Version(tlNoRevision, tlInfo, tcfilename) Local laVersion, lcVersion, lcFileName *-- Get Version Information *-- Added 4-1-98 BDC Local lcVersionText, lcFileName, llNoRevision, llInfo Dimension aVersion(12) If Empty(tcfilename) lcFileName = Sys(16, 0) Else lcFileName = tcfilename Endif llNoRevision = tlNoRevision llInfo = tlInfo *** EGL: 2002.1.2 17:06 - switched to AGETFILEVERSION(). If Val(Substr(Version(), 15)) >= 6 * The AGETFILEVERSION() function was introduced in VFP 6 *!* DECLARE STRING GetCommandLine IN Kernel32 *!* lcFileName = GetCommandLine() lcVersionText = "" *!* IF GetFileVersion(&lcFileName,@aVersion) = 0 If Agetfileversion(aVersion, lcFileName) > 0 If !llInfo * daca vreau doar numarul versiunii lcVersion = Allt(aVersion(4)) If llNoRevision * daca nu vreau si revizia lnPos = Rat('.', lcVersion, 1) Else lnPos = Len(lcVersion) Endif lcVersionText = Left(lcVersion, lnPos) Else * vreau toata informatia despre fisier If Not Empty(aVersion(1)) lcVersionText = Allt(aVersion(1)) Endif If Not Empty(aVersion(2)) lcVersionText = lcVersionText + Chr(10) + "Produs de: " + Allt(aVersion(2)) Endif If Not Empty(aVersion(3)) lcVersionText = lcVersionText + Chr(10) + "Descriere: " + Allt(aVersion(3)) Endif If Not Empty(aVersion(4)) lcVersionText = lcVersionText + Chr(10) + "Versiune fisier: " + Allt(aVersion(4)) Endif If Not Empty(aVersion(5)) lcVersionText = lcVersionText + Chr(10) + "Nume intern: " + Allt(aVersion(5)) Endif If Not Empty(aVersion(6)) lcVersionText = lcVersionText + Chr(10) + "Copyright: " + Allt(aVersion(6)) Endif If Not Empty(aVersion(7)) lcVersionText = lcVersionText + Chr(10) + "Marca inregistrata: " + Allt(aVersion(7)) Endif If Not Empty(aVersion(8)) lcVersionText = lcVersionText + Chr(10) + "Nume fisier: " + Allt(aVersion(8)) Endif If Not Empty(aVersion(9)) lcVersionText = lcVersionText + Chr(10) + "Private Build: " + Allt(aVersion(9)) Endif If Not Empty(aVersion(10)) lcVersionText = lcVersionText + Chr(10) + "Nume produs: " + Allt(aVersion(10)) Endif If Not Empty(aVersion(11)) lcVersionText = lcVersionText + Chr(10) + "Versiune produs: " + Allt(aVersion(11)) Endif If Not Empty(aVersion(12)) lcVersionText = lcVersionText + Chr(10) + "Special Build: " + Allt(aVersion(12)) Endif If Empty(lcVersionText) lcVersionText = "" Endif Endif Else lcVersionText = "" Endif Else lcVersionText = "" Endif Return lcVersionText Endproc ******************************************* SFARSIT: Get_Version ******************************************* * PROCEDURE Get_Hexa( tnDeca ) * Date : 18/11/2004, 17:56:48 * author : marius.mutu * description: transforma un Deca in Hexa ****** PARAMETER BLOCK ************** * Parameters : 1 * Parameter 1: Numarul in Deca * ******************************************* INCEPUT:Get_Hexa ******************************************* Procedure Get_Hexa( tnDeca ) Local laHexa, lnHexa, lnDeca If Empty(tnDeca) lnDeca = 0 Else lnDeca = tnDeca Endif Dimension laHexa[16] laHexa[1] = '0' laHexa[2] = '1' laHexa[3] = '2' laHexa[4] = '3' laHexa[5] = '4' laHexa[6] = '5' laHexa[7] = '6' laHexa[8] = '7' laHexa[9] = '8' laHexa[10] = '9' laHexa[11] = 'A' laHexa[12] = 'B' laHexa[13] = 'C' laHexa[14] = 'D' laHexa[15] = 'E' laHexa[16] = 'F' lnHexa = '' Do While lnDeca > 0 lnrest = Mod(lnDeca, 16) lcHexa = laHexa[lnRest + 1] lnDeca = Int(lnDeca / 16) lnHexa = lcHexa + lnHexa lnrest = Mod(lnDeca, 16) Enddo Return lnHexa Endproc ******************************************* SFARSIT: Get_Hexa ******************************************* && completeaza cu spatii si CRLF un mesaj a.i. pe fiecare linie sa fie lnLength caractere Function format_msg Parameters tcErrMsg, tnLength Local lnLength, lcLinie, lcMesaj, lnPoz, lnCate, i, j lcMesaj = "" If Empty(tnLength) lnLength = 50 && numarul de caractere pe linie Else lnLength = tnLength Endif i = 1 If At(Chr(13) + Chr(10), tcErrMsg, i) > 0 lnCate = At(Chr(13) + Chr(10), tcErrMsg, i) + 1 i = i + 1 Else lnCate = Min(lnLength, Rat(' ', Substr(tcErrMsg, 1, lnLength)) - 1) Endif lnPoz = 1 *!* lcLinie=Substr(tcErrMsg,1,lnCate) Do While lnPoz < Len(tcErrMsg) lcLinie = Substr(tcErrMsg, lnPoz, lnCate) If Right(lcLinie, 2) = Chr(13) + Chr(10) lcLinie = Alltrim(Substr(lcLinie, 1, Len(lcLinie) - 2)) Else lcLinie = Alltrim(lcLinie) Endif j = Int((lnLength - Len(lcLinie)) / 2) lcLinie = Iif(!Empty(lcLinie), Space(j) + lcLinie + Space(j), "") lcMesaj = lcMesaj + lcLinie + Chr(13) + Chr(10) lnPoz = lnPoz + lnCate If At(Chr(13) + Chr(10), tcErrMsg, i) > 0 lnCate = At(Chr(13) + Chr(10), tcErrMsg, i) + 2 - lnPoz i = i + 1 Else lcNextChar = Substr(tcErrMsg, lnPoz + lnLength, 1) lcLinieNoua = Substr(tcErrMsg, lnPoz, lnLength) If lcNextChar!= ' ' And Len(lcLinieNoua) >= lnLength lnCate = Min(lnLength, Rat(' ', lcLinieNoua) - 1) Else lnCate = lnLength Endif Endif Enddo Return lcMesaj Endfunc && format_msg ***--------------------------------------------------------------------------------------------- Procedure C_LUNA Parameters tnnrluna Do Case Case tnnrluna = 1 Return "IANUARIE" Case tnnrluna = 2 Return "FEBRUARIE" Case tnnrluna = 3 Return "MARTIE" Case tnnrluna = 4 Return "APRILIE" Case tnnrluna = 5 Return "MAI" Case tnnrluna = 6 Return "IUNIE" Case tnnrluna = 7 Return "IULIE" Case tnnrluna = 8 Return "AUGUST" Case tnnrluna = 9 Return "SEPTEMBRIE" Case tnnrluna = 10 Return "OCTOMBRIE" Case tnnrluna = 11 Return "NOIEMBRIE" Case tnnrluna = 12 Return "DECEMBRIE" Otherwise Return "" Endcase Endproc &&c_luna ***-------------------------------------------------------------------------------------- ***-------------------------------------------------------------------------------------- Procedure CLUNA3 Parameters tnnrluna Do Case Case tnnrluna = 1 Return "Ian" Case tnnrluna = 2 Return "Feb" Case tnnrluna = 3 Return "Mar" Case tnnrluna = 4 Return "Apr" Case tnnrluna = 5 Return "Mai" Case tnnrluna = 6 Return "Iun" Case tnnrluna = 7 Return "Iul" Case tnnrluna = 8 Return "Aug" Case tnnrluna = 9 Return "Sep" Case tnnrluna = 10 Return "Oct" Case tnnrluna = 11 Return "Noi" Case tnnrluna = 12 Return "Dec" Otherwise Return Space(3) Endcase Endproc &&cluna3 ***-------------------------------------------------------------------------------------- ***------------------------------------------------------------------------------------ Procedure cluna Parameters tcGrup, tcTipCumul, tcAn lcTipCumul = Upper(Alltrim(tcTipCumul)) lcAn = Alltrim(tcAn) lcgrup = Alltrim(tcGrup) lnGrup = Val(lcgrup) Do Case Case lcTipCumul = "T" lcret = "Trim. " + lcgrup + " " + lcAn Case lcTipCumul = "S" lcret = "Sem. " + lcgrup + " " + lcAn Case lcTipCumul = "A" lcret = "Anul " + lcAn Otherwise Do Case Case lnGrup = 1 lcret = "Ian " + lcAn Case lnGrup = 2 lcret = "Feb " + lcAn Case lnGrup = 3 lcret = "Mar " + lcAn Case lnGrup = 4 lcret = "Apr " + lcAn Case lnGrup = 5 lcret = "Mai " + lcAn Case lnGrup = 6 lcret = "Iun " + lcAn Case lnGrup = 7 lcret = "Iul " + lcAn Case lnGrup = 8 lcret = "Aug " + lcAn Case lnGrup = 9 lcret = "Sep " + lcAn Case lnGrup = 10 lcret = "Oct " + lcAn Case lnGrup = 11 lcret = "Noi " + lcAn Case lnGrup = 12 lcret = "Dec " + lcAn Otherwise lcret = lcAn Endcase Endcase Return lcret Endproc &&cluna ***------------------------------------------------------------------------------------ ***------------------------------------------------------------------------------------ Procedure get_trimestru Parameters tnNrTrim Do Case Case tnNrTrim = 1 Return "Trim. I" Case tnNrTrim = 2 Return "Trim. II" Case tnNrTrim = 3 Return "Trim. III" Case tnNrTrim = 4 Return "Trim. IV" Otherwise Return Space(7) Endcase Endproc && get_trimestru ***-------------------------------------------------------------------------------------- Procedure get_semestru Parameters tnNrSem Do Case Case tnNrSem = 1 Return "Sem. I" Case tnNrSem = 2 Return "Sem. II" Otherwise Return Space(7) Endcase Endproc && get_semestru ***-------------------------------------------------------------------------------------- Function Lista_Campuri Lparameters tcAlias Local lcSelect, i, lcAlias, lcLista lcLista = [] lcSelect = Select() lcAlias = tcAlias Select (lcAlias) lnFields = Fcount() For i = 1 To lnFields lcField = Field(i) lcLista = lcLista + [,] + lcField Endfor If !Empty(lcLista) lcLista = Substr(lcLista, 2) Endif Select (lcSelect) Return lcLista Endfunc && Lista_Campuri ***---------------------------------------- Procedure NRORD Parameters ALI Sele &ALI A = Reccount() If A = 0 Return Endif If A > 65000 Return 0 Endif Declare NROR(A) K = 0 Scan K = K + 1 NROR(K) = Recno() Endscan Return ******************** Function NRCRT NR = Ascan(NROR, Recno()) Return NR ********************** ***---------------------------------------- Function caps_first Lparameters tcMesaj Local lcMesaj If !Empty(tcMesaj) And Len(tcMesaj) > 1 lcMesaj = Upper(Substr(tcMesaj, 1, 1)) + Strtran(Lower(Substr(tcMesaj, 2)), [oracle], [Oracle]) Else lcMesaj = Upper(tcMesaj) Endif Return lcMesaj Endfunc && caps_first ***---------------------------------------- *!* FUNCTION ultima_zi_din_luna *!* PARAMETERS tcAnul, tcLuna *!* *!* LOCAL ldData *!* ldData = DATE(VAL(tcAnul),VAL(tcLuna), 1) *!* ldData = GOMONTH(ldData,1) *!* ldData = DATE(YEAR(ldData),MONTH(ldData), 1) - 1 *!* RETURN ldData *!* ENDFUNC Function ultima_zi_din_luna Parameters tcAnul, tcLuna Local ldData, lcAnul, lcLuna If Type('tcAnul') = 'N' lcAnul = Transform(tcAnul) Else lcAnul = tcAnul Endif If Type('tcLuna') = 'N' lcLuna = Transform(tcLuna) Else lcLuna = tcLuna Endif ldData = Date(Val(lcAnul), Val(lcLuna), 1) ldData = Gomonth(ldData, 1) ldData = Date(Year(ldData), Month(ldData), 1) - 1 Return ldData Endfunc ****************************************************************************** Procedure viz_prg_instalat If Used('v_programe_instalate') Use In v_programe_instalate Endif *!* lcSql = [select * from vdef_util_programe where id_util=]+Alltrim(Str(gnIdUtil))+; *!* [ order by ordine] lcSql = [{call contafin_oracle.pack_drepturi.programe_utilizator(] + Alltrim(Str(gnIdUtil)) + [)}] lcCursor = [v_programe_instalate] lnSucces = goExecutor.oExecute(lcSql, lcCursor) goExecutor.Oreset() Endproc ****************************************************************************** Procedure lansare_toolbar Do viz_prg_instalat In oproceduri_comune.prg If Used('v_programe_instalate') And Reccount('v_programe_instalate') > 0 If Used('v_programe_favorite') Use In v_programe_favorite Endif Select * From v_programe_instalate Where favorit = 1 And Upper(Alltrim(nume)) <> Iif(Type('gcNumeProgram') = 'U', '<>', gcNumeProgram) ; Order By ordine_favorit Into Cursor v_programe_favorite If Reccount('v_programe_favorite') > 0 otool = Createobject('toolset') With otool.tool1 Local i i = 0 Select v_programe_favorite Scan i = i + 1 *!* modificare 15.10.2007 *!* If Type('gcappname')='C' *!* If gcappname=Upper(Alltrim(nume)) *!* Loop *!* Endif *!* Endif *!* modificare 15.10.2007 ^ lnParametru_prog = parametru_prog && pt. programul de Contracte - clienti si furnizori lcParametru_prog = Alltrim(Str(Nvl(lnParametru_prog, 0))) lnIdProgram = id_program lcIdProgram = Alltrim(Str(lnIdProgram)) lcNumeProgram = Proper(Alltrim(explicatie)) lcImagine = Upper(Alltrim(nume)) + ".png" &&nume poza lcCaleImagine = gcappPath + 'grafice\' + lcImagine &&cale imagine If !File(lcCaleImagine) lcImagine = 'na.png' lcCaleImagine = gcappPath + 'grafice\na.png' Endif lnIdGrupProg = id_grup_prog lnIdGrupProgFav = 0 If Like([*.htm], Lower(Alltrim(nume))) Or Like([*.html], Lower(Alltrim(nume))) lcComandaProgram = dirgen + Iif(Empty(Director), Alltrim(nume), Alltrim(Director)) + [\] + ; Alltrim(nume) Else lcCaleProgram = dirgen + Iif(Empty(Director), Juststem(nume), Alltrim(Director)) + [\] + ; &&cale program Juststem(Alltrim(nume)) + [.exe] lcParametru = gcHost + [;] + gcuserName + [;] + gcPassword + [;] + Alltrim(Str(gnIdUtil)) + [;] + ; lcIdProgram + [;] + lcParametru_prog + [;] &¶metri lcComandaProgram = [run /n ] + lcCaleProgram + [ ] + lcParametru Endif lcImgNume = "img_" + lcIdProgram + "_" + lcParametru_prog If lnIdProgram > 0 .AddObject(lcImgNume, 'img_program') .&lcImgNume..comanda_program = lcComandaProgram &&adaug poza .&lcImgNume..Picture = lcImagine .&lcImgNume..ToolTipText = lcNumeProgram .&lcImgNume..Visible = .T. Endif Endscan .Dock(0) .Show Endwith Endif Endif If Used('v_programe_instalate') Use In v_programe_instalate Endif If Used('v_programe_favorite') Use In v_programe_favorite Endif Endproc ***--------------------------------------------------------------------------------------------------------------------------------------- ***--------------------------------------------------------------------------------------------------------------------------------------- Procedure ceretitlu_rap Parameters tcMesaj, tctitlu Local lcTitlu lcTitlu = tctitlu obj1 = Createobject("frm_cere_titlu") obj1.clb_tx_simplu1.lb_simplu1.Caption = tcMesaj obj1.clb_tx_simplu1.text_simplu1.ControlSource = 'lctitlu' obj1.Show(1) Return lcTitlu Endproc ***--------------------------------------------------------------------------------------------------------------------------------------- Procedure cursor2lista Lparameters tcCursor, tcColumn, tcSeparator, tcFilter && tcCursor - cursor && tcColumn - coloana din cursor care va constitui lista && tcSeparator separatorul de elemente din tcLista - default este ";" - este optional && tcFilter - optional = filtru pentru tabel && intoarce lista de valori separate prin separatori && ex: lcLista = cursor2lista("cursor","id",";") Local lcLista, lcSeparator, lcSelect, lcFilter lcLista = "" lcSeparator = Iif(!Empty(tcSeparator) And Type('tcSeparator') = 'C', tcSeparator, ";") lcFilter = Iif(Empty(m.tcFilter), '.T.', m.tcFilter) If Used(tcCursor) lcSelect = Select() lcColumn = tcCursor + "." + tcColumn If Type(lcColumn) # 'U' Select * From (tcCursor) Into Cursor crsListaTemp Select crsListaTemp Scan For &lcFilter lcLista = lcLista + Alltrim(Transform(Evaluate(tcColumn))) + lcSeparator Endscan Use In crsListaTemp If !Empty(lcLista) lcLista = Left(lcLista, Len(lcLista) - 1) Endif Endif Select (lcSelect) Endif Return lcLista Endproc && cursor2lista ***------------------------------------------------------------------------------------------- ***------------------------------------------------------------------------------------------- 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 ***------------------------------------------------------------------------------------------- && -------------------------- INCEPUT verific_cont ------------------------------ Procedure verific_cont Parameters tcCont, tlNoMessage Private pcCont pcCont = Alltrim(tcCont) && verificare contului cu Planul de Conturi lcSel = [SELECT cont from ] + GCS + [.vplcont_sintetic WHERE TRIM(cont) = ?pcCont and an = ?gnAn ] lcCursor = 'crs_verific' lnSucces = goExecutor.oExecute(lcSel, lcCursor) If lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 16, "Eroare") Endif If lnSucces > 0 If Reccount('crs_verific') = 0 lnSucces = -1 Endif Endif If lnSucces < 0 And !tlNoMessage amessagebox('Acest cont nu este definit in planul de conturi!', 0 + 48, 'Atentie') Endif Return lnSucces Endproc && -------------------------- SFARSIT verific_cont ------------------------------ * ===================== 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 * ===================== MyHash ==================================== * OBIECT EMULARE HASH * loHash = GetHash([cselect=>select id, name from test??cwhere=>id=pnId??corder=>name]) * ================================================================== Define Class MyHash 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 && 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(Strtran(lcPropertyValue, '=>', Chr(18)), 1, Chr(18)) lcValue = Getwordnum(Strtran(lcPropertyValue, '=>', Chr(18)), 2, Chr(18)) 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 get_zileluc( ) lnzileluc = 0 lcSql = [select zileluc from ] + GCS + [.sal_calendar where an=?gnan and luna=?gnluna] lcCursor = [v_zileluc] lnSucces = goExecutor.oExecute(lcSql, lcCursor) goExecutor.Oreset() If lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 16, "Eroare") Return Else Select v_zileluc lnzileluc = zileluc Endif Return lnzileluc ******************************************* * PROCEDURE param_listari( tcraport, tcTitlu, tcSemnaturi ) * Date : 07/28/05, 14:04:21 * author : liana.macinic * description: ****** PARAMETER BLOCK ************** * Parameters : 3 * Parameter 1: * Parameter 2: * Parameter 3: * ******************************************* Procedure param_listari( tcraport, tctitlu, tcSemnaturi, tlFaraTab) Store '' To tctitlu, tcSemnaturi Local lnIdRaport If Used('v_raport') Use In v_raport Endif lcSql = [select id_raport,titlu from ] + GCS + [.sal_nom_rapoarte where UPPER(raport) = '] + Upper(Alltrim(tcraport)) + ['] lcCursor = [v_raport] lnSucces = goExecutor.oExecute(lcSql, lcCursor) goExecutor.Oreset() If lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 16, "Eroare") Return Endif Select v_raport lnIdRaport = v_raport.id_raport tctitlu = v_raport.titlu Use If Used('v_date') Use In v_date Endif lcSql = [select semnatura,NUME from ] + GCS + [.sal_semnaturi_rap where id_raport = ] + Alltrim(Str(lnIdRaport)) + [ and sters = 0 order by ordine] lcCursor = [v_date] lnSucces = goExecutor.oExecute(lcSql, lcCursor) goExecutor.Oreset() If lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 16, "Eroare") Return Endif Local lcSemn, lcNumeRap, lcListaNumeRap Store '' To lcSemn, lcNumeRap, lcListaNumeRap Select v_date Scan Scatter Name lcDateRap Memo lcSemn = Alltrim(Nvl(lcDateRap.semnatura, "")) lcNumeRap = Alltrim(Nvl(lcDateRap.nume, '')) If Len(lcSemn) => Len(lcNumeRap) lcNumeRap = Padr(lcNumeRap, Len(lcSemn), " ") Else lcSemn = Padr(lcSemn, Len(lcNumeRap), " ") Endif If tlFaraTab tcSemnaturi = tcSemnaturi + lcSemn Else tcSemnaturi = tcSemnaturi + Chr(9) + Chr(9) + lcSemn Endif If tlFaraTab lcListaNumeRap = lcListaNumeRap + lcNumeRap Else lcListaNumeRap = lcListaNumeRap + + Chr(9) + Chr(9) + lcNumeRap Endif Endscan tcSemnaturi = tcSemnaturi + Chr(13) + lcListaNumeRap *!* SELECT v_date *!* SCAN *!* tcSemnaturi = tcSemnaturi+CHR(9)+CHR(9)+ALLTRIM(v_date.nume) *!* ENDSCAN *!* tcSemnaturi = tcSemnaturi+CHR(9)+CHR(9)+CHR(9)+CHR(9) Select v_date Use Endproc *----------------------------------sfarsit procedura param_listari---------------------------------- ** --------------------------------INCEPUT: facturi_duplicate ------------------------------ Procedure facturi_duplicate Parameters tcCont, tnId_Part, tcSerieAct, tnNract, tcMesajReturn Private pcCont, pnNract, pnId_part, pcSerieAct Local lcMesaj, MesajReturn lcMesaj = '' pcCont = Alltrim(tcCont) pnId_part = tnId_Part pnNract = tnNract pcSerieAct = Nvl(Iif(Empty(Alltrim(tcSerieAct)), Null, Alltrim(tcSerieAct)), '+_') lcMesajReturn = tcMesajReturn If !(Alltrim(Nvl(Alltrim(tcSerieAct), []) + ' ' + Allt(Str(pnNract))) $ lcMesajReturn) *!* modificare ROAFACTURARE v 2.0.46 If Inlist(Allt(pcCont), '4111', '401', '404', '418', '408', '461', '462') *!* If Inlist(Allt(pcCont),'4111','401','404') *!* modificare ROAFACTURARE v 2.0.46 ^ lnTotctva = 0 Do Case *!* modificare ROAFACTURARE v 2.0.46 *!* Case Allt(pcCont) = '4111' *!* lcSql = [select count(*) as nr_ireg, sum(debit) as debit from ireg_parteneri ]+; *!* [ where an=?gnAn and luna=?gnLuna and cont = ?pcCont and nract = ?pnNract] + ; *!* [ and NVL(serie_act,'+_') = ?pcSerieAct ]+; *!* [ and extract(year from dataireg)*12+extract(month from dataireg) = ?gnAn*12+?gnLuna ] *!* lcCursor = [crsFactDbl] *!* lnSucces = goExecutor.oExecute(lcSql,lcCursor) *!* goExecutor.Oreset() *!* If lnSucces < 0 *!* AMESSAGEBOX(goExecutor.cEroare,0+16,'Eroare') *!* Return *!* Endif *!* Select crsFactDbl *!* If nr_ireg > 0 *!* lnTotctva = debit *!* lcMesaj = 'Factura '+Alltrim(Alltrim(Nvl(tcSerieAct,[]))+' '+Allt(Str(pnNract))) + ", "+ Alltrim(Transform(lnTotctva, get_mask(14,GnPA)))+' lei, mai exista inregistrata in luna curenta.' *!* Endif Case Inlist(Allt(pcCont), '4111', '418', '461') lcSql = [select count(*) as nr_ireg, sum(debit) as debit,] + ; [TO_NUMBER(NVL(pack_sesiune.getoptiunefirma('NRLUNIVERIFICARENRDOC'),0)) as nrluni ] + ; [from ireg_parteneri ] + ; [where an*12+luna between ] + Alltrim(Str(gnAn)) + [*12+] + Alltrim(Str(gnLuna)) + ; [-TO_NUMBER(NVL(pack_sesiune.getoptiunefirma('NRLUNIVERIFICARENRDOC'),0)) ] + ; [and ] + Alltrim(Str(gnAn)) + [*12+] + Alltrim(Str(gnLuna)) + [ ] + ; [and cont = '] + Alltrim(pcCont) + [' and nract = ] + Alltrim(Str(pnNract, 14, 0)) + [ ] + ; [and NVL(serie_act,'+_') = '] + pcSerieAct + [' ] + ; [and extract(year from dataireg)*12+extract(month from dataireg) between ] + ; Alltrim(Str(gnAn)) + [*12+] + Alltrim(Str(gnLuna)) + ; [-TO_NUMBER(NVL(pack_sesiune.getoptiunefirma('NRLUNIVERIFICARENRDOC'),0)) ] + ; [and ] + Alltrim(Str(gnAn)) + [*12+] + Alltrim(Str(gnLuna)) + [ ] + gcCondSucursala lcCursor = [crsFactDbl] lnSucces = goExecutor.oExecute(lcSql, lcCursor) goExecutor.Oreset() If lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 16, 'Eroare') Return Endif Select crsFactDbl If nr_ireg > 0 lnTotctva = debit lcPerioadaVerificare = Dtoc(Gomonth(Date(gnAn, gnLuna, 1), (-1) * NrLuni)) + [ - ] + ; Dtoc(Gomonth(Date(gnAn, gnLuna, 1), 1) - 1) lcMesaj = Iif(INLIST(Alltrim(pcCont), '4111', '461'), 'Factura', 'Avizul') + ' ' + Alltrim(Alltrim(Nvl(tcSerieAct, [])) + ' ' + ; Allt(Str(pnNract, 20, 0))) + ", " + Alltrim(Transform(lnTotctva, get_mask(14, GnPc))) + ; ' lei, mai este inregistrat' + Iif(INLIST(Alltrim(pcCont), '4111', '461'), 'a', '') + ' in perioada ' + lcPerioadaVerificare + '.' Endif Release pnNrLuni *!* modificare ROAFACTURARE v 2.0.46 ^ Case Inlist(Allt(pcCont), '401', '404', '408', '462') lcSql = [select count(*) as nr_ireg, sum(credit) as credit,] + ; [TO_NUMBER(NVL(pack_sesiune.getoptiunefirma('NRLUNIVERIFICARENRDOC'),0)) as nrluni ] + ; [ from ireg_parteneri ] + ; [ where an*12+luna between ] + Alltrim(Str(gnAn)) + [*12+] + Alltrim(Str(gnLuna)) + ; [-TO_NUMBER(NVL(pack_sesiune.getoptiunefirma('NRLUNIVERIFICARENRDOC'),0)) ] + ; [ and ] + Alltrim(Str(gnAn)) + [*12+] + Alltrim(Str(gnLuna)) + ; [ and cont = '] + Alltrim(pcCont) + [' and nract = ] + Alltrim(Str(pnNract, 14, 0)) + ; [ and NVL(serie_act,'+_') = '] + pcSerieAct + [' ] + ; [and extract(year from dataireg)*12+extract(month from dataireg) between ] + ; Alltrim(Str(gnAn)) + [*12+] + Alltrim(Str(gnLuna)) + ; [-TO_NUMBER(NVL(pack_sesiune.getoptiunefirma('NRLUNIVERIFICARENRDOC'),0)) ] + ; [and ] + Alltrim(Str(gnAn)) + [*12+] + Alltrim(Str(gnLuna)) + ; [ and id_part = ] + Alltrim(Str(m.pnId_part)) + [ ] + gcCondSucursala lcCursor = [crsFactDbl] lnSucces = goExecutor.oExecute(lcSql, lcCursor) goExecutor.Oreset() If lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 16, 'Eroare') Return Endif Select crsFactDbl If nr_ireg > 0 lnTotctva = credit lcPerioadaVerificare = Dtoc(Gomonth(Date(gnAn, gnLuna, 1), (-1) * NrLuni)) + [ - ] + ; Dtoc(Gomonth(Date(gnAn, gnLuna, 1), 1) - 1) lcMesaj = 'Factura ' + Alltrim(Alltrim(Nvl(tcSerieAct, [])) + ' ' + Allt(Str(pnNract,20,0))) + ", " + Alltrim(Transform(lnTotctva, get_mask(14, GnPc))) + ' lei, mai exista inregistrata in perioada ' + lcPerioadaVerificare + '.' Endif *!* modificare v 2.0.132 *!* Case Allt(pcCont) = '404' *!* lcSql = [select count(*) as nr_ireg, sum(credit) as credit from vireg_parteneri ]+; *!* [ where an=?gnAn and luna=?gnLuna and cont = ?pcCont and nract = ?pnNract]+; *!* [ and NVL(serie_act,'+_') = ?pcSerieAct ]+; *!* [ and extract(year from dataireg)*12+extract(month from dataireg) = ?gnAn*12+?gnLuna ]+; *!* [ and id_part = ?pnId_part] *!* lcCursor = [crsFactDbl] *!* lnSucces = goExecutor.oExecute(lcSql,lcCursor) *!* goExecutor.Oreset() *!* If lnSucces < 0 *!* AMESSAGEBOX(goExecutor.cEroare,0+16,'Eroare') *!* Return *!* Endif *!* Select crsFactDbl *!* If nr_ireg > 0 *!* lnTotctva = credit *!* lcMesaj = 'Factura '+Alltrim(Alltrim(Nvl(tcSerieAct,[]))+' '+Allt(Str(pnNract)))+ ", "+ Alltrim(Transform(lnTotctva, get_mask(14,GnPA)))+' lei, mai exista inregistrata in luna curenta.' *!* Endif *!* modificare v 2.0.132 ^ Endcase Endif Endif Return lcMesaj Endproc && facturi_duplicate && ------------------------------SFARSIT: facturi_duplicate ------------------------------ ******************************************** *** Verifica un numar si serie (optional) de factura clienti in vanzari in luna curenta *** Intoarce .T. daca exista numarul de factura in luna curenta ******************************************** Function VerificaFacturaClientiVanzari Lparameters tnNrFactura, tcSerieFactura * tcSerieFactura (optional) Private pnNrFactura, pcSerieFactura, pnCount Local lcSql, llSucces, lcSelect, llExista lcSelect = Select() pnNrFactura = tnNrFactura pcSerieFactura = Iif(!Empty(Nvl(m.tcSerieFactura, '')), Alltrim(Transform(m.tcSerieFactura)), '') pnCount = 0 lcSql = [SELECT COUNT(*) as nr FROM vanzari WHERE numar_act = ?pnNrFactura ] + Iif(!Empty(m.pcSerieFactura), [AND serie_act = ?pcSerieFactura ], []) + [AND extract(year FROM data_act) = ?gnAn AND extract(month FROM data_act) = ?gnLuna and sters = 0] llSucces = goExecutor.oSelecteaza2Value(m.lcSql, @pnCount) llExista = Nvl(m.pnCount, 0) > 0 Select (m.lcSelect) Return m.llExista Endfunc && VerificaNumarFacturaVanzari ************************************ EncryptDecrypt **************************************** *!* EncryptDecrypt *!* EX: EncryptDecrypt("text to encrypt", "encrypt key", "encrypt") *!* EX: EncryptDecrypt("text to decrypt", "decrypt key", "decrypt") *!* EX: EncryptDecrypt("text to encrypt", "encrypt key", "encrypt","blowfish") Function EncryptDecrypt Lparameters tcText, tcPassword, tcMode, tcAlgorithm && tcMode : ENCRYPT/DECRYPT Local lcAlgorithm, lcReturn, lcString, lcPWD Local loException As Exception m.lcString = tcText m.lcPWD = tcPassword m.lcReturn = "" lcAlgorithm = "" If Type('tcAlgorithm') = 'C' lcAlgorithm = tcAlgorithm Endif If lcAlgorithm = "blowfish" If Upper(Alltrim(Transform(tcMode))) = "ENCRYPT" lcReturn = Encrypt(m.lcString, m.lcPWD, 4, 0) Else Try lcReturn = decrypt(m.lcString, Alltrim(m.lcPWD), 4, 0) Catch To loException If loException.ErrorNo = 2028 polog.Log("S-a incercat decriptarea unui text care nu a fost generat cu algoritmul de criptare selectat.", Program()) Else polog.Log(loException.Message, Program()) Endif Endtry Endif Endif *!* 18.03.2008 : am scos chr(0) de la sfarsitul textului decriptat If At(Chr(0), m.lcReturn) > 0 And Upper(Alltrim(Transform(tcMode))) != "ENCRYPT" m.lcReturn = Substr(m.lcReturn, 1, At(Chr(0), m.lcReturn) - 1) Endif *!* 18.03.2008 Return m.lcReturn Endfunc && EncryptDecrypt *!* Function EncryptDecrypt *!* Lparameters tcText, tcPassword, tcMode, tcAlgorithm *!* && tcMode : ENCRYPT/DECRYPT *!* *!* IF !'crypto'$LOWER(SET("Classlib")) *!* *!* SET CLASSLIB TO CRYPTO.VCX ADDITIVE *!* *!* ENDIF *!* Local loCryptor, llNewCryptFll, lcAlgorithm *!* loCryptor = Newobject("MyCrypt","crypto.vcx") *!* Local loException As Exception *!* Local lcReturn, lcString, lcPWD *!* m.lcString = tcText *!* m.lcPWD = tcPassword *!* m.lcReturn = "" *!* llNewCryptFll = .F. *!* If Type('gnewcryptfll') <> 'U' *!* llNewCryptFll = gnewcryptfll *!* Endif *!* lcAlgorithm = "" *!* If Type('tcAlgorithm') = 'C' *!* lcAlgorithm = tcAlgorithm *!* Endif *!* If !(lcAlgorithm = "blowfish" And llNewCryptFll) *!* If Upper(Alltrim(Transform(tcMode))) = "ENCRYPT" *!* loCryptor.EncryptSessionStreamString( m.lcString, m.lcPWD, @lcReturn) *!* Else *!* Try *!* loCryptor.EncryptSessionStreamString( m.lcString, m.lcPWD, @lcReturn) *!* Catch To loException *!* If loException.ErrorNo=2028 *!* polog.Log("S-a incercat decriptarea unui text care nu a fost generat cu algoritmul de criptare selectat.",Program()) *!* Else *!* polog.Log(loException.Message,Program()) *!* Endif *!* Endtry *!* Endif *!* Else *!* If Upper(Alltrim(Transform(tcMode))) = "ENCRYPT" *!* lcReturn=Encrypt(m.lcString, m.lcPWD,4,0) *!* Else *!* Try *!* lcReturn=decrypt(m.lcString, Alltrim(m.lcPWD),4,0) *!* Catch To loException *!* If loException.ErrorNo=2028 *!* polog.Log("S-a incercat decriptarea unui text care nu a fost generat cu algoritmul de criptare selectat.",Program()) *!* Else *!* polog.Log(loException.Message,Program()) *!* Endif *!* Endtry *!* Endif *!* Endif *!* Release oCryptor *!* *!* 18.03.2008 *!* *!* am scos chr(0) de la sfarsitul textului decriptat *!* If At(Chr(0),m.lcReturn) > 0 And Upper(Alltrim(Transform(tcMode))) != "ENCRYPT" *!* m.lcReturn = Substr(m.lcReturn, 1, At(Chr(0),m.lcReturn)-1) *!* Endif *!* *!* 18.03.2008 *!* Return m.lcReturn *!* Endfunc && EncryptDecrypt ************************************ EncryptDecrypt **************************************** Procedure lansare_help Do viz_prg_instalat In oproceduri_comune.prg If Used('v_programe_instalate') And Reccount('v_programe_instalate') > 0 If Used('v_help') Use In v_help Endif Select * From v_programe_instalate Where !Isnull(gruphelp) And nume == gcappname Into Cursor v_help If Used('v_programe_instalate') Use In v_programe_instalate Endif ohelp = Createobject('toolhelp') With ohelp.tool_help1 lcImgNume = 'HELP' .AddObject(lcImgNume, 'img_help') If Used('v_help') And Reccount('v_help') > 0 And !Empty(gcCaleHelp) Select v_help Local lcgrup, lcNume, lcIndex lcgrup = Nvl(Alltrim(v_help.gruphelp), '') lcNume = Nvl(Alltrim(v_help.numehelp), '') lcIndex = Nvl(Alltrim(v_help.indexhelp), '') lcComanda = dirgen + gcCaleHelp + '\' + lcgrup + '\' + lcNume + '\' + lcIndex If File(lcComanda) .&lcImgNume..Picture = '_active_help.ico' &&adaug poza .&lcImgNume..comanda_program = lcComanda Else .&lcImgNume..comanda_program = 'INACTIV' Endif Else .&lcImgNume..comanda_program = 'INACTIV' Endif .&lcImgNume..ToolTipText = 'Ajutor (F1)' .&lcImgNume..Visible = .T. *!* modificare 17.11.2011 .AddObject('stromfast', 'img_program') With .stromfast .Picture = 'romfast_suport.png' .comanda_program = 'romfast_suport.exe' .ToolTipText = 'ROMFAST suport tehnic (ALT+R)' .Visible = .T. Endwith *!* modificare 17.11.2011 ^ *!* modificare 04.04.2016 .AddObject('screenshot', 'img_program') With .screenshot .Picture = 'screenshot.png' .comanda_program = 'roascreenshot.exe' .ToolTipText = 'Captura ecran si email (ALT+S)' .Visible = .T. Endwith *!* modificare 17.11.2011 .AddObject('chatbot', 'img_program') With .chatbot .Picture = 'chatbot.png' .comanda_program = 'chatbot' .ToolTipText = 'Chatbot Suport Tehnic (ALT+C)' .Visible = .T. Endwith .Dock(0) .Show Endwith Endif If Used('v_help') Use In v_help Endif Endproc ***************************************************** Procedure lansare_help_meniu If Type('ohelp.tool_help1') <> 'O' Return Endif If !Empty(ohelp.tool_help1.Help.comanda_program) If ohelp.tool_help1.Help.comanda_program <> 'INACTIV' OPEN_DEFAULT_APP(ohelp.tool_help1.Help.comanda_program) Else amessagebox("Manualul de utilizare nu este configurat corect!", 0 + 48, "Atentie") Endif Else amessagebox("Manualul de utilizare nu este instalat!", 0 + 48, "Atentie") Endif Endproc ***************************************************** Function getUserDocPath Local lcAppPath, lcAppName, liAt, lcDirgen, lcUserDocPath lcAppPath = Addbs(shortpath(Justpath(Sys(16, 0)))) lcAppName = Allt(Uppe(Juststem(Sys(16, 0)))) liAt = Rat("\", lcAppPath, 2) lcDirgen = Addbs(Left(lcAppPath, liAt - 1)) lcUserDocPath = lcDirgen + 'USERDOCSS\' If !Directory(lcUserDocPath) Md (lcUserDocPath) Endif lcUserDocPath = lcUserDocPath + lcAppName + '\' If !Directory(lcUserDocPath) Md (lcUserDocPath) Endif lcUserDocPath = lcUserDocPath + GCS + '\' If !Directory(lcUserDocPath) Md (lcUserDocPath) Endif Return lcUserDocPath Endfunc ***************************************************** Procedure copiaza_structura_cursor Lparameters tcSursa, tcDestinatie If !Empty(tcSursa) And !Empty(tcDestinatie) If Used(tcSursa) Dimension laStructura(1, 18) If Used(tcDestinatie) Use In (tcDestinatie) Endif Afields(laStructura, tcSursa) Create Cursor (tcDestinatie) From Array laStructura Release laStructura Else amessagebox("Eroare interna 2 - copiaza structura cursor", 16, "Eroare") Endif Else amessagebox("Eroare interna 1 - copiaza structura cursor", 16, "Eroare") Endif Endproc && copiaza_structura_cursor ********************************************************************************************************* Function citeste_optiune_firma Lparameters tcOptiune, tlNumeProgram Local lcCursor, lcVarType, luReturnValue lcCursor = [crsoptiunefirma] If Used(lcCursor) Use In (lcCursor) Endif lcSql = [select varvalue,vartype from optiuni where varname = '] + Alltrim(tcOptiune) + ['] + ; Iif(tlNumeProgram, [ and program = '] + Alltrim(gcNumeProgram) + ['], []) lnSucces = goExecutor.oExecute(lcSql, lcCursor) If lnSucces < 0 amessagebox(goExecutor.cEroare, 16, "Eroare") luReturnValue = Null Else If Reccount(lcCursor) > 0 Select (lcCursor) lcVarType = Upper(Alltrim(&lcCursor..Vartype)) Do Case Case lcVarType = "CHARACTER" luReturnValue = Alltrim(&lcCursor..varvalue) Case lcVarType = "CURRENCY" luReturnValue = Ntom(Val(&lcCursor..varvalue)) Case lcVarType = "NUMERIC" luReturnValue = Val(&lcCursor..varvalue) Case lcVarType = "DATETIME" luReturnValue = Ctot(&lcCursor..varvalue) Case lcVarType = "DATE" luReturnValue = Ctod(&lcCursor..varvalue) Case lcVarType = "LOGICAL" luReturnValue = Iif(Inlist(Upper(Left(&lcCursor..varvalue, 1)), "T", "Y"), .T., .F.) Otherwise pcmsgbuff = "Tip de variabila globala invalid!" pcmsgbuff = pcmsgbuff + Chr(13) + Chr(13) + "Numele variabilei: " + lcvarname pcmsgbuff = pcmsgbuff + Chr(13) + "Tipul variabilei: " + lcVarType pcmsgbuff = pcmsgbuff + Chr(13) + Chr(13) + "Contactati suportul tehnic." = amessagebox(pcmsgbuff, 48) pcmsgbuff = "" luReturnValue = Null Endcase Else amessagebox("Nu a fost gasita optiunea '" + tcOptiune + "' !", 16, "Eroare") luReturnValue = Null Endif Use In (lcCursor) Endif Return luReturnValue Endfunc ********************************************************************************************************* Procedure debug_dezvoltare If Messagebox("Porniti debug?", 32 + 4 + 256, "Confirmare") = 6 Debug Suspend Endif Endproc && debug_dezvoltare ********************************************************************************************************* **************************** inceput nvl2Default ***************************************************** Procedure nvl2Default Lparameters tcTableAlias, tcCampuriNull * updatateaza cursorul si pune o valoare default pe toate coloanele, ; cu exceptia celor din tcCampuriNull * tcCampuriNull primeste lista de campuri separate prin ',' care nu vor fi modificate ; de ex: "camp1,camp2," Local lnNrCol, i, lcSql, lctip, lcCampuriNull lctip = [] lcSql = [update ] + tcTableAlias + [ set ] lcCampuriNull = Iif(Type("tcCampuriNull") = "L", [], tcCampuriNull) lcCampuriNull = Upper(Nvl(lcCampuriNull, [])) If Right(lcCampuriNull, 1) # "," And Len(lcCampuriNull) > 0 lcCampuriNull = lcCampuriNull + [,] Endif Select(tcTableAlias) lnNrCol = Afields(laCols) For i = 1 To lnNrCol If (laCols(i, 1) + [,]) $ lcCampuriNull Loop Endif && daca este in lista, nu il adaugam If laCols(i, 2) = "C" Or laCols(i, 2) = "M" Or laCols(i, 2) = "V" lctip = [''] && character, memo, varchar Endif If laCols(i, 2) = "B" Or laCols(i, 2) = "F" Or laCols(i, 2) = "I" Or laCols(i, 2) = "N" lctip = [0] && double, float, integer, numeric Endif If laCols(i, 2) = "L" lctip = [.f.] && logic Endif If laCols(i, 2) = "T" Or laCols(i, 2) = "D" lctip = [{}] Endif && date, datetime lcSql = lcSql + laCols(i, 1) + [ = NVL(] + laCols(i, 1) + [,] + lctip + [), ] Endfor lcSql = Left(lcSql, Rat(',', lcSql) - 1) &lcSql Go Top && nu facea update in xitems pe coloanele xinputmask, filtru de pe ultima linie Endproc && nvl2Default ^ ************************************************************************************************* Procedure versiune Lparameters lcvers External Array laVers Local lcVersiune, lnNr lcVersiune = [] lnNr = Alines(laVers, Nvl(lcvers, []), .T., ".") If lnNr > 0 For i = 1 To lnNr laVers(i) = Replicate("0", 3 - Len(Alltrim(Nvl(laVers(i), [])))) + laVers(i) lcVersiune = lcVersiune + laVers(i) + "." Endfor lcVersiune = Left(lcVersiune, Len(lcVersiune) - 1) Else lcVersiune = lcvers Endif Return lcVersiune Endproc && sfarsit versiune ^ ************************************************************************************************* ********************************************************************************************************* 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 ********************************************************************************************************* *************************** Function TooManyInstances(lnInstancesAllowed) *************************** #Define GW_CHILD 5 && 0x00000005 #Define GW_HWNDNEXT 2 && 0x00000002 #Define SW_MAXIMIZE 3 && 0x00000003 #Define SW_NORMAL 1 && 0x00000001 #Define WAIT_OBJECT_0 0 && 0x00000000 #Define RF_MESAJ 0xA123 Local lcUniqueProperty, lcUniqueSemaphore, lnhSemaphore, lnHwnd, llReturn If Pcount() = 0 lnInstancesAllowed = 1 && default Else lnInstancesAllowed = Max(lnInstancesAllowed, 1) &&At least one Endif Do DeclareAPIs lcUniqueSemaphore = Strtran(Justpath(Sys(16, 0)), "\", "") *!* lcUniqueSemaphore = "968360BF-C7AD-4B62-A045-0A06D597EF18" lcUniqueProperty = "E2429959-D873-4733-8182-7A3F14780A27" &&& *!* oTypeLib = CreateObject("scriptlet.typelib") *!* lcUniqueSemaphore = substr(oTypeLib.GUID, 2, 36) *!* oTypeLib1 = CreateObject("scriptlet.typelib") *!* lcUniqueProperty = substr(oTypeLib1.GUID, 2, 36) &&& lnhSemaphore = CreateSemaphore(0, lnInstancesAllowed, lnInstancesAllowed, lcUniqueSemaphore) If lnhSemaphore != 0 And WaitForSingleObject(lnhSemaphore, 0) != WAIT_OBJECT_0 Do DeclareMoreAPIs llReturn = .T. lnHwnd = GetWindow(GetDesktopWindow(), GW_CHILD) Do While lnHwnd != 0 && loop through all windows If GetProp(lnHwnd, lcUniqueProperty) = 1 && does window have our unique property? BringWindowToTop(lnHwnd) *!* modificare v 2.0.23 If IsIconic(lnHwnd) <> 0 SendMessage(lnHwnd, RF_MESAJ, 0, 0) Else *!* modificare v 2.0.23 ^ ShowWindow(lnHwnd, SW_NORMAL) *!* modificare v 2.0.23 Endif *!* modificare v 2.0.23 ^ llReturn = .T. Exit Endif lnHwnd = GetWindow(lnHwnd, GW_HWNDNEXT) Enddo CloseHandle(lnHwnd) CloseHandle(lnhSemaphore) Clear Dlls "BringWindowToTop", "GetDesktopWindow", ; "GetProp", "GetWindow", "ShowWindow", ; "CloseHandle", "SendMessage", "IsIconic" Else = SetProp(_vfp.HWnd, lcUniqueProperty, 1) _Screen.AddProperty("SemaphoreHandle", lnhSemaphore) llReturn = .F. Endif Clear Dlls "CreateSemaphore", "GetLastError", ; "SetProp" Return (llReturn) Endfunc ************************************************************************************************************************* *************************** Procedure DeclareAPIs() *************************** Declare Integer CloseHandle In Kernel32 Integer hObject Declare Integer CreateSemaphore In Kernel32 Integer lpSemaphoreAttributes, Integer lInitialCount, Integer lMaximumCount, String lpName Declare Integer SetProp In User32 Integer HWnd, String lpString, Integer hData Declare Integer WaitForSingleObject In Kernel32 Integer hHandle, Integer dwMilliseconds Endproc ************************************************************************************************************************* *************************** Procedure DeclareMoreAPIs() *************************** 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 *!* modificare v 2.0.23 Declare Integer SendMessage In User32 Integer HWnd, Integer Msg, Integer wParam, Integer Lparam Declare Integer IsIconic In User32 Integer HWnd *!* modificare v 2.0.23 ^ Endproc ************************************************************************************************************************* ************************************************************************************************** *!* INTOARCE VALOAREA NOTNULL DACA EXPRESIA NU ESTE NULL SAU VALOAREA NULL DACA EXPRESIA ESTE NULL ************************************************************************************************** Function nvl2 Lparameters tcExpression, tuValueIfNotNull, tuValueIfNull Local luReturn luReturn = tuValueIfNotNull If Isnull(tcExpression) luReturn = tuValueIfNull Endif Return luReturn Endfunc && nvl2 ************************************************************************************************************ Procedure alege_vizualizare_raport Lparameters tcCursorRaport, tcraport Private pnButon, pnOptiune If Reccount(tcCursorRaport) > 0 pnButon = 1 Do While pnButon = 1 pnOptiune = 1 ofrmaleg = Createobject('frm_aleg_vizualizare') ofrmaleg.Show(1) Do Case Case pnButon <> 1 Loop Case pnOptiune = 1 goExport.export2frx(tcCursorRaport, tcraport) Case pnOptiune = 2 goExport.export2xls(tcCursorRaport) && tcAlias, tcNumeFisier, tcListaColoane, tcFiltru Endcase Release ofrmaleg Enddo Else amessagebox("Nu exista inregistrari pentru listare!", 0 + 48, "Atentie") Endif Use In (tcCursorRaport) Release pnButon, pnOptiune Endproc ************************************************************************************************************ **************************** *!* Demonstrates the callback functionality **************************** *!* SET LIBRARY TO LOCFILE("vfpcompression.fll") *!* ZipCallback("MyUnzipCallBack()") && Start Event Handling - Any Function/Procedure/Method (in scope of course) *!* ?ZipOpen("MyZip.zip", "C:\", .F.) && create zip file *!* ?ZipFile("C:\MyFile.txt", .F.) && compress file into zip *!* ?ZipClose() && done zipping *!* ?UnzipQuick("C:\MyZip.zip", "C:\") && unzip contents of Test.zip to C:\ *!* ZipCallback("") && Stop Event Handling *!* SET LIBRARY TO Function MyUnzipCallBack Lparameters tnBytesTotal ***************************** *!* Variables below are created on the fly *!* by the FLL when the ZipCallback feature is used *!* Depends on the value of nZipEvent *!* cZipObjectName && Name of Zip, File, or Folder being processed *!* Events that fire MyCallback *!* 0 = Open Zip *!* 1 = Start Zip/Unzip of File *!* 2 = Read/Write File (nZipBytes will contain value of bytes read for event) *!* 3 - End Zip/Unzip of File *!* 4 - Folder Opened *!* 5 - Close Zip If nZipEvent = 2 *!* Number of Bytes read (Event 3) If !Empty(m.tnBytesTotal) Wait Window cZipObjectName + ' ' + Transform(Int(m.nZipBytes / m.tnBytesTotal * 100)) + '% ...' Nowait Else Wait Window cZipObjectName + ' ' + Transform(m.nZipBytes) + ' bytes read' Nowait Endif Endif Endfunc && MyUnzipCallBack ************************************************************************************************************ *** Callback from the vfpconnection FLL - can be used to track operation progress Procedure MyProgressHandler Lparameters tcFile Local lnProgress, lcFile lnProgress = 0 lcFile = Iif(Empty(m.tcFile) Or Type('tcFile') <> 'C', '', m.tcFile) If m.nConnectTotalBytes > 0 m.lnProgress = Int(m.nConnectBytesSoFar / m.nConnectTotalBytes * 100) Endif Wait Window m.lcFile + ' ' + Transform(m.lnProgress) + '% ...' Nowait Endproc && MyProgressHandler ************************************************************************************************************ Procedure apeleaza_calc Do Case Case File('C:\WINDOWS\CALC.EXE') Run /N C:\Windows\Calc.Exe Case File('C:\WINDOWS\SYSTEM32\CALC.EXE') Run /N C:\Windows\SYSTEM32\Calc.Exe Case File('C:\WINnt\system32\CALC.EXE') Run /N C:\WINnt\SYSTEM32\Calc.Exe Otherwise lcMesaj = 'Aplicatia "Calculator" nu este instalata pe acest sistem!' amessagebox(lcMesaj, 0 + 48, Iif(!Empty(Nvl(gcNumeProgram, [])), gcNumeProgram, "Atentie")) Endcase Endproc ************************************************************************* Procedure apeleaza_notepad Do Case Case File('C:\WINDOWS\NOTEPAD.EXE') Run /N C:\Windows\NOTEPAD.Exe Case File('C:\WINnt\system32\NOTEPAD.EXE') Run /N C:\WINnt\SYSTEM32\NOTEPAD.Exe Otherwise lcMesaj = 'Aplicatia "Notepad" nu este instalata pe acest sistem!' amessagebox(lcMesaj, 0 + 48, Iif(!Empty(Nvl(gcNumeProgram, [])), gcNumeProgram, "Atentie")) Endcase Endproc ************************************************************************* Procedure arata_modificari Do Form frm_changelog Endproc ************************************************************************* Procedure arata_versiune Do Form frm_about Endproc ************************************************************************* Procedure arata_manual lansare_help_meniu() Endproc ************************************************************************* Function aInputBox Lparameters tcPrompt, tcTitle, txDefaultValue, tnLeft, tnTop, ; tcFormat, tcInputMask, tcPasswordChar Private pcReturnValue pcReturnValue = txDefaultValue Local oInputBox oInputBox = Createobject("aInputBox", tcPrompt, tcTitle, ; txDefaultValue, tnLeft, tnTop, ; tcFormat, tcInputMask, tcPasswordChar) oInputBox.Show() Return pcReturnValue Endfunc && aInputBox ************************************************** Define Class aInputBox As Form Height = 113 Width = 318 DoCreate = .T. AutoCenter = .T. Caption = "Input Box" ControlBox = .F. WindowType = 1 Name = "frmInputBox" *-- empty value to return if Cancel is chosen; data type depends on data type of txValueIn xemptyvalue = .F. *-- the default value (if any) xdefaultvalue = .F. *-- the return value xreturnvalue = .F. Add Object lblinputbox As Label With ; FontName = "Arial", ; FontSize = 10, ; FontCharSet = 238, ; Alignment = 1, ; Caption = "Introduceti valoarea ", ; Height = 20, ; Left = 6, ; Top = 26, ; Width = 190, ; TabIndex = 1, ; Name = "lblInputBox" Add Object txtinputbox As TextBox With ; FontName = "Arial", ; FontSize = 10, ; Century = 1, ; Height = 24, ; Left = 202, ; SelectOnEntry = .T., ; TabIndex = 2, ; Top = 22, ; Width = 110, ; Name = "txtInputBox" Add Object cmdok As CommandButton With ; Top = 72, ; Left = 84, ; Height = 24, ; Width = 72, ; Caption = "Confirma", ; FontCharSet = 238, ; Default = .T., ; TabIndex = 3, ; Name = "cmdOK" Add Object cmdcancel As CommandButton With ; Top = 72, ; Left = 172, ; Height = 24, ; Width = 72, ; Cancel = .T., ; Caption = "Renunta", ; FontCharSet = 238, ; TabIndex = 4, ; Name = "cmdCancel" Procedure Unload With Thisform If Type(".xReturnValue") = "C" .xreturnvalue = Rtrim( .xreturnvalue) Endif pcReturnValue = .xreturnvalue Endwith Endproc Procedure Init Lparameters tcPrompt, tcTitle, txDefaultValue, tnLeft, tnTop, ; tcFormat, tcInputMask, tcPasswordChar If Type("tcPrompt") <> "C" tcPrompt = "Introduceti valoarea " Endif If Type("tcTitle") <> "C" tcTitle = "Input Box" Endif If !( Type("txDefaultValue") $ "CDNY") * Valid input data types are C, D, N, and Y txDefaultValue = "" && default to character data type Endif If Type("tcFormat") <> "C" tcFormat = "" Endif If Type("tcInputMask") <> "C" tcInputMask = "" Endif If Type("tcPasswordChar") <> "C" tcPasswordChar = "" Endif If Len( Alltrim( tcPasswordChar)) > 1 tcPasswordChar = Left( tcPasswordChar, 1) Endif Local llAutoCenter If Pcount() < 5 && Top and Left parameters were not passed tnLeft = 0 tnTop = 0 Else && Top and left parameters were passed but may not be numeric If Type("tnTop") = "N" And Type("tnLeft") = "N" && both are numeric llAutoCenter = .F. Else && one or both is not numeric, so AutoCenter the form tnLeft = 0 tnTop = 0 llAutoCenter = .T. Endif Endif With Thisform .lblinputbox.Caption = Alltrim( tcPrompt) .Caption = Alltrim( tcTitle) .xdefaultvalue = txDefaultValue .xreturnvalue = .xdefaultvalue .txtinputbox.Value = .xdefaultvalue .txtinputbox.Format = Alltrim( tcFormat) .txtinputbox.InputMask = Alltrim( tcInputMask) .txtinputbox.PasswordChar = tcPasswordChar .Top = tnTop .Left = tnLeft .AutoCenter = llAutoCenter && Set AutoCenter last so it overrides Top and Left if .T. Do Case Case Type("txDefaultValue") = "D" .xemptyvalue = {} Case Type("txDefaultValue") = "N" .xemptyvalue = 0 Case Type("txDefaultValue") = "Y" .xemptyvalue = $ 0 Otherwise .xemptyvalue = "" Endcase Endwith Endproc Procedure cmdok.Click With Thisform .xreturnvalue = .txtinputbox.Value .Release() Endwith Endproc Procedure cmdcancel.Click * * If Cancel was chosen, return the empty value of the correct data type. * With Thisform .xreturnvalue = .xemptyvalue .Release() Endwith Endproc Enddefine * *-- EndDefine: aInputBox ************************************************** ************************************************** *** intoarce ziua curenta daca luna contabila este egala cu luna calendaristica *** intoarce ultima zi din luna contabila daca luna contabila nu este egala cu luna calendaristica ************************************************** Function GetDataIreg Local ldData ldData = Ttod(Get_Ora()) If Month(ldData) <> gnLuna Or Year(ldData) <> gnAn ldData = ULTIMAZI() Endif Return m.ldData Endfunc && GetDataIreg ************************************************** ************************************************** *** primeste tnNrluni = an*12+luna *** intoarce anul si luna ca parametri prin referinta *** ex: NrLuni2AnLuna(lnNrLuni, @lnAn, @lnLuna) ************************************************** Procedure NrLuni2AnLuna Lparameters tnNrLuni, tnAn, tnLuna tnLuna = INT(Mod(m.tnNrLuni, 12)) tnAn = Int(m.tnNrLuni / 12) If tnLuna = 0 tnLuna = 12 tnAn = m.tnAn - 1 Endif Endproc && NrLuni2AnLuna ************************************************** *** salveaza un cursor intr-un fisier XML in gcTempPath *** intoarce calea fisierului xml daca s-a salvat cu succes ************************************************** Function SaveCursor2XML Lparameters tcAlias, tcXMLName *** tcAlias: alias-ul cursorului (ex: tact) *** tcXMLName: numele fisierului XML fara cale si extensie (ex: notafarapredefinire) Local lcAlias, lcXMLFile, lcXMLName, lnBytes lcAlias = Iif(Empty(tcAlias), Alias(), m.tcAlias) lcXMLName = Iif(Empty(tcXMLName), m.lcAlias, m.tcXMLName) lcXMLFile = gcTempPath + Juststem(lcXMLName) + '.xml' lnBytes = 0 If Used(m.lcAlias) lnBytes = Cursortoxml(m.lcAlias, m.lcXMLFile, 1, 2 + 512, 0, "1") Endif Return Iif(m.lnBytes > 0, m.lcXMLFile, '') Endfunc && SaveCursor2XML ************************************************** *** transforma un xml salvat anterior in gcTempPath intr-un cursor *** intoarce numele cursorului creat (alias), daca s-a gasit fisierul XML ************************************************** Function RestoreXML2Cursor Lparameters tcAlias, tcXMLName *** tcAlias: alias-ul cursorului (ex: tact) *** tcXMLName: numele fisierului XML fara cale si extensie (ex: notafarapredefinire) Local lcAlias, lcXMLFile, lcXMLName, lnBytes lcAlias = Iif(Empty(tcAlias), Sys(2015), m.tcAlias) lcXMLName = Iif(Empty(tcXMLName), m.lcAlias, m.tcXMLName) lcXMLFile = gcTempPath + Juststem(lcXMLName) + '.xml' If File(m.lcXMLFile) Xmltocursor(m.lcXMLFile, m.lcAlias, 512) Endif Return Iif(Used(m.lcAlias), m.lcAlias, '') Endfunc && RestoreXML2Cursor ************************************************** *** verifica daca exista fisierul xml salvat prin SaveCursor2XML *** intoarce ************************************************** Function ExistsXML Lparameters tcXMLName *** tcXMLName: numele fisierului XML fara cale si extensie (ex: notafarapredefinire) Local lcXMLFile, lcXMLName lcXMLName = Iif(Empty(tcXMLName), m.lcAlias, m.tcXMLName) lcXMLFile = gcTempPath + Juststem(lcXMLName) + '.xml' Return Iif(File(m.lcXMLFile), m.lcXMLFile, '') Endfunc && ExistsXML ************************************************** *** verifica daca exista fisierul xml salvat prin SaveCursor2XML *** intoarce ************************************************** Define Class BackupXML As Custom cBackupSet = "" && numele backupset-ului (un fisier xml in care se salveaza informatii despre fisierele xml, variabile etc. pentru acel backupset) cBackupSetPath = "" && calea unde se salveaza backupset-ul (gcTempPath) cBackupSetFile = "" && calea completa a fisierului backupset gcTempPath\backupset.xml cBackupSetAlias = "" lBackupSetExists = .F. && Se initializeaza in Init-ul clasei si la salvarea backupset-ului lBackupSetLoaded = .F. Procedure Init Lparameters tcBackupSet, tcBackupPath Local lcBackupPath, lcBackupSet lcBackupSet = m.tcBackupSet If Type('tcBackupPath') <> 'C' Or Empty(tcBackupPath) lcBackupPath = m.gcTempPath Else lcBackupPath = m.tcBackupPath Endif If !(Empty(m.lcBackupSet) Or Empty(m.lcBackupPath)) This.cBackupSetFile = Addbs(m.lcBackupPath) + Juststem(m.lcBackupSet) + '.xml' Endif Endproc && Init Procedure cBackupSetFile_ASSIGN Lparameters tcBackupSetFile This.cBackupSetFile = m.tcBackupSetFile If !Empty(m.tcBackupSetFile) This.cBackupSetPath = Addbs(Justpath(m.tcBackupSetFile)) This.cBackupSet = Juststem(m.tcBackupSetFile) This.lBackupSetExists = File(This.cBackupSetFile) This.LoadBackupSet() Endif Endproc && cBackupSetFile_ASSIGN Protected Procedure LoadBackupSet Local lcBackupSetAlias, lcBackupSetFile, lcSelect lcSelect = Select() lcBackupSetFile = This.cBackupSetFile lcBackupSetAlias = This.cBackupSet If File(m.lcBackupSetFile) Xmltocursor(m.lcBackupSetFile, m.lcBackupSetAlias, 512) *!* modificare ROACONT v 2.2.15 : pentru fisierele care aveau structura type/name/filename If Type(lcBackupSetAlias + ".filename") <> "U" Alter Table &lcBackupSetAlias Add Column Value M Null Alter Table &lcBackupSetAlias Add Column valuetype C Replace Value With filename All Replace valuetype With "" All Alter Table &lcBackupSetAlias Drop Column filename Endif *!* modificare ROACONT v 2.2.15 ^ Else Create Cursor &lcBackupSetAlias (Type v(20), Name v(100), Value M Null, valuetype C) Endif This.lBackupSetLoaded = Used(m.lcBackupSetAlias) Select (m.lcSelect) Endproc && LoadBackupSet ************************************************** *** ************************************************** Function ReadValue Lparameters tcNumeVariabila Local lcSelect, lcValue, lcValueType, luValue lcSelect = Select() Select (This.cBackupSet) Locate For Alltrim(Type) = 'VARIABLE' And Upper(Alltrim(Name)) = Upper(Alltrim(tcNumeVariabila)) If Found() lcValue = Value lcValueType = Upper(Alltrim(valuetype)) Do Case Case lcValueType $ "CM" luValue = m.lcValue Case lcValueType $ "NIF" luValue = Val(m.lcValue) Case lcValueType = "T" luValue = Ctot(m.lcValue) Case lcValueType = "D" luValue = Ctod(m.lcValue) Case lcValueType = "L" luValue = Iif(m.lcValue = "1" Or Upper(m.lcValue) = "T" Or Upper(m.lcValue) = '.T.' Or Upper(m.lcValue) = 'YES', .T., .F.) Otherwise luValue = m.lcValue Endcase Else luValue = Null Endif Select (lcSelect) Return luValue Endfunc ************************************************** *** intoarce .T. daca exista fisierul backupset xml ************************************************** Function ExistsBackupSet Return This.lBackupSetExists Endfunc && ExistsBackupSet ************************************************** *** deschide backupset-ul si creeaza cursoarele si variabilele din definitia lui *** intoarce .T. daca exista fisierul backupset ************************************************** Function RestoreBackupSet Lparameters tcBackupSetFile *** tcBackupSetFile: calea completa a fisierului backupset XML, inclusiv extensie Local lcBackupSetFile, llRestored, lcSelect Local lcAlias, lcFile, loRec Local lcName, lcType, lcValue, lcValueType, lcVariable, luValue llRestored = .F. lcSelect = Select() If !Empty(m.tcBackupSetFile) This.cBackupSetFile = tcBackupSetFile Endif If !This.lBackupSetLoaded Return m.llRestored Endif lcBackupSetFile = This.cBackupSetFile Select (This.cBackupSet) Scan Scatter Name loRec Memo lcType = Upper(Alltrim(loRec.Type)) lcName = loRec.Name lcValue = loRec.Value lcValueType = Upper(Alltrim(loRec.valuetype)) Do Case *** recreare cursoare din xml-uri Case m.lcType = 'TABLE' lcFile = Addbs(Justpath(lcBackupSetFile)) + Juststem(Alltrim(m.lcValue)) + '.xml' lcAlias = Alltrim(m.lcName) If File(m.lcFile) Xmltocursor(m.lcFile, m.lcAlias, 512) Endif *** reinitializare variabile Case loRec.Type = 'VARIABLE' lcVariable = lcName Do Case Case lcValueType $ "CM" luValue = m.lcValue Case lcValueType $ "NIF" luValue = Val(m.lcValue) Case lcValueType = "T" luValue = Ctot(m.lcValue) Case lcValueType = "D" luValue = Ctod(m.lcValue) Case lcValueType = "L" luValue = Iif(m.lcValue = "1" Or Upper(m.lcValue) = "T" Or Upper(m.lcValue) = '.T.' Or Upper(m.lcValue) = 'YES', .T., .F.) Otherwise luValue = m.lcValue Endcase &lcVariable = luValue && pcText = "abc" Endcase Endscan && m.lcBackupSetAlias llRestored = .T. Select(m.lcSelect) Return m.llRestored Endfunc && RestoreBackupSet *********************************** *** Saves all the private variables in the parameter list in the BackupSet *********************************** Procedure SavePrivateVariables Lparameters tcPrivateVariables lnVariables = Getwordcount(m.tcPrivateVariables, ",") For lnVariable = 1 To m.lnVariables lcVariable = Alltrim(Getwordnum(m.tcPrivateVariables, m.lnVariable, ",")) If !Empty(m.lcVariable) This.SaveBackupSet(m.lcVariable, "VARIABLE", &lcVariable) Endif Endfor Endproc && SavePrivateVariables ************************************************** *** salveaza un cursor sau toate cursoarele din definitia backupset-ului in fisiere XML in gcTempPath *** intoarce calea fisierului xml daca s-a salvat cu succes ************************************************** Procedure SaveBackupSet Lparameters tcName, tcType, tuValue *** tcName: numele cursorului sau variabilei (ex: crsAct, pcText) Daca este gol, se salveaza toate alias-urile *** daca este completat, se adauga in definitia backupset-ului *** tcType: TABLE/VARIABLE *** tuValue: (optional) valoarea variabilei. Valoarea se salveaza direct in xml definitie backupset *** tcValueType: (optional) tipul variabilei (C/N/D/T) pentru This.RestoreBackupset Local lcFile, lcName, lcType, lcWhere, llSaved, lnBytes, loRec, lnRecno, lcFilter lcName = "" llSaved = .F. If !This.lBackupSetLoaded Return m.llSaved Endif If !Empty(tcName) lcName = Alltrim(Transform(m.tcName)) lcType = Iif(!Empty(m.tcType), m.tcType, "TABLE") This.UpdateBackupSet(m.lcName, m.lcType, m.tuValue) && variabilele se salveaza direct in definitia backupset-ului Endif Select (This.cBackupSet) lcWhere = [.T.] If !Empty(m.lcName) lcWhere = [name = "] + m.lcName + ["] Endif *** SALVARE CURSOARE IN XML Scan For &lcWhere Scatter Name loRec Memo lcFile = Addbs(This.cBackupSetPath) + Alltrim(loRec.Value) && (c:\temp\backupsettest_actactan.xml) lcName = Alltrim(loRec.Name) Do Case Case loRec.Type = 'TABLE' If Used(m.lcName) lnRecno = Iif(Eof(m.lcName), 0, Recno(m.lcName)) lcFilter = Filter(m.lcName) Set Filter To In (m.lcName) lnBytes = Cursortoxml(m.lcName, m.lcFile, 1, 2 + 512, 0, "1") If !Empty(m.lcFilter) lcFilterExpr = "set filter to " + m.lcFilter + " in " + m.lcName &lcFilterExpr Endif If m.lnRecno > 0 Goto m.lnRecno In (m.lcName) Endif Endif Otherwise *** Endcase Endscan && m.lcBackupSetAlias llSaved = .T. Return m.llSaved Endfunc && SaveBackupSet Procedure DeleteBackupSet Local lcFile, loRec, lcSelect lcSelect = Select() If !File(This.cBackupSetFile) Return Endif *** sterg fisierele componenta backupset Select (This.cBackupSet) Scan For Upper(Alltrim(Type)) = 'TABLE' Scatter Name loRec Memo lcFile = Addbs(This.cBackupSetPath) + Alltrim(loRec.Value) && (c:\temp\backupsettest_actactan.xml) If File(m.lcFile) Delete File (m.lcFile) Endif Endscan *** sterg inregistrarile din cursorul backupset Delete All *** sterg fisierul backupset Delete File (This.cBackupSetFile) Endproc && DeleteBackupSet ************************************************************************* *** actualizeaza definitia backupset-ului cu tabelele sau variabilele noi *** UpdateBackupSet("crsAct", "TABLE") *** UpdateBackupSet("pcText", "VARIABLE", m.pcText, "C") ************************************************************************* Procedure UpdateBackupSet Lparameters tcName, tcType, tuValue *** tcName: numele cursorului sau variabilei (ex: crsAct, pcText) *** tcType: TABLE/VARIABLE *** tuValue: (optional) valoarea variabilei. Valoarea se salveaza direct in xml definitie backupset Local lcFileName, lcName, lcType, lnBytes, lcSelect, lcValue, lcValueType If !This.lBackupSetLoaded Return .F. Endif lcSelect = Select() lcName = Iif(!Empty(m.tcName), Alltrim(Transform(m.tcName)), "") lcType = Iif(!Empty(m.tcType), m.tcType, "TABLE") lcValue = Transform(m.tuValue) lcValueType = Iif(Pcount() >= 3, Type('tuValue'), "") Do Case Case m.lcType = "TABLE" lcValue = This.cBackupSet + "_" + m.lcName + ".xml" Otherwise * Endcase If !Empty(m.lcName) Select (This.cBackupSet) Locate For Name = Alltrim(tcName) If !Found() Insert Into (This.cBackupSet) (Type, Name, Value, valuetype) Values (m.lcType, m.lcName, m.lcValue, m.lcValueType) Else Replace Type With m.lcType, Value With m.lcValue, valuetype With m.lcValueType Endif lnBytes = Cursortoxml(This.cBackupSet, This.cBackupSetFile, 1, 2 + 512, 0, "1") Endif Select (m.lcSelect) Endproc && UpdateBackupSet Procedure Destroy Local lcSelect lcSelect = Select() Use In (Select(This.cBackupSet)) Select (m.lcSelect) Endproc && Destroy Enddefine && BackupXML Procedure romfast_suport Local lcFile, lcPath, llOpen lcFile = "romfast_suport.exe" lcPath = Addbs(m.gcBasePath) llOpen = .T. Return DownloadSupportFile(m.lcFile, m.lcPath, m.llOpen) Endproc && romfast_suport Procedure DownloadSupportFile Lparameters tcFile, tcDownloadPath, tlOpen, tlNewVersion *** tlOpen: .T. daca se doreste deschiderea fisierului descarcat *** tlNewVersion: OUT - .T. daca exista o versiune noua pe server Local loUpdater As "Updater" Local lcCheckSum, lcDownloadFile, lcDownloadPath, lcErrorMessage, lcFile, lcProgressProcedure, lcURL Local llCheckVersion, llOpen, llReturn, loUpdateRec, llError Local lcDownloadFileTemp llError = .F. Wait Window "Se cauta versiuni noi ale fisierului " + Justfname(m.tcFile) + " pe romfast.ro" Nowait lcFile = Alltrim(m.tcFile) && "romfast_suport.exe" lcDownloadPath = Addbs(m.tcDownloadPath) llOpen = m.tlOpen lcDownloadFile = m.lcDownloadPath + m.lcFile && d:\roa\romfast_suport.exe llCheckVersion = .F. loUpdater = Createobject("Updater", "", m.llCheckVersion) If Type("loUpdater") = "O" loUpdateRec = loUpdater.CheckNewVersion(m.lcFile, .T.) tlNewVersion = loUpdateRec.NewVersion If loUpdateRec.NewVersion Or !File(m.lcDownloadFile) lcURL = Alltrim(loUpdateRec.fisier) lcCheckSum = Alltrim(loUpdateRec.checksum) lcProgressProcedure = "" lcErrorMessage = "" lcDownloadFileTemp = loUpdater.cDownloadPath + m.lcFile && d:\contafin\_update\romfast_suport.exe llReturn = loUpdater.DownloadFile(m.lcURL, m.lcDownloadFileTemp, m.lcProgressProcedure, @m.lcErrorMessage, m.lcCheckSum) If !loUpdater.lError loUpdater.UpdateVersion(m.loUpdateRec) If File(m.lcDownloadFileTemp) Copy File (m.lcDownloadFileTemp) To (m.lcDownloadFile) Delete File (m.lcDownloadFileTemp) Endif Endif If !Empty(m.lcErrorMessage) amessagebox(m.lcErrorMessage, 0 + 48, _Screen.Caption) Endif Endif Else llReturn = .F. Endif If m.llOpen And File(m.lcDownloadFile) OPEN_DEFAULT_APP(m.lcDownloadFile) Endif Return m.llReturn Endproc && DownloadSupportFile Define Class Updater As Custom cLicenta = "" && pentru CONTAFIN cErrorMessage = "" lError = .F. cDownloadPath = "" cFileVersionUrl = "" cDownloadFileVersion = "" Procedure Init Lparameters tcFileVersionUrl, tlCheckVersion, tcVersionType *** tcFileVersionUrl: URL fisier versiuni.xml (DEFAULT http://...contafin.xml) *** tlCheckVersion: .T. = se verifica versiunile programelor din versiuni.xml *** tcVersionType: CONTAFIN (DEFAULT); SUPORT Local lcCheie, lcConnectTimeout, lcDownloadFileVersion, lcFileLicenta, lcFileVersionUrl Local lcLibraryPath, lcLicenta, lcResponseTimeout, lcSettingsFile, lcVersionFileName, lcVersionType Local llReturn, loEx lcLicenta = "" lcFileLicenta = m.gcBasePath + 'licente.cnt' If File(m.lcFileLicenta) m.lcLicenta = Alltrim(Filetostr(m.lcFileLicenta)) This.cLicenta = m.lcLicenta Endif lcLibraryPath = m.gcBasePath + Iif("ROA" $ Upper(gcBasePath), "COMUNROA", "COMUNCONTAFIN") + "\vfpconnection.fll" && CONTAFIN(ROA)\COMUNCONTAFIN(COMUNROA)\vfpconnection.fll lcSettingsFile = m.gcBasePath + "settings.ini" && CONTAFIN(ROA)\settings.ini If File(m.lcLibraryPath) Try If !'vfpconnection' $ Set("Library") Set Library To (lcLibraryPath) Additive Endif lcConnectTimeout = goAPI.GetProfileString(m.lcSettingsFile, "update", "ConnectTimeout") && timeout conectare in secunde / default 20 lcConnectTimeout = Nvl(lcConnectTimeout, '') lcResponseTimeout = goAPI.GetProfileString(m.lcSettingsFile, "update", "ResponseTimeout") && timeout raspuns in secunde / default 60 lcResponseTimeout = Nvl(lcResponseTimeout, '') If Empty(m.lcConnectTimeout) goAPI.WriteProfileString(m.lcSettingsFile, "update", "ConnectTimeout", "20") && frecventa verificarii lcConnectTimeout = "20" Endif If Empty(m.lcResponseTimeout) goAPI.WriteProfileString(m.lcSettingsFile, "update", "ResponseTimeout", "60") && frecventa verificarii lcResponseTimeout = "60" Endif SetConnectTimeout(Val(lcConnectTimeout)) && Default is 10 seconds SetResponseTimeout(Val(lcResponseTimeout)) && Default is 10 seconds This.cDownloadPath = m.gcBasePath + '_UPDATE\' && D:\CONTAFIN\_UPDATE\ If !Directory(This.cDownloadPath) Md (This.cDownloadPath) Endif lcDownloadFileVersion = This.cDownloadPath + "versiune.xml" This.cDownloadFileVersion = lcDownloadFileVersion lcLicenta = "" lcFileLicenta = m.gcBasePath + 'licente.cnt' If File(m.lcFileLicenta) m.lcLicenta = Alltrim(Filetostr(m.lcFileLicenta)) This.cLicenta = m.lcLicenta Endif ********************************************************** *** Citesc fileversionurl din CONTAFIN(ROA)\SETTINGS.INI ********************************************************** *** FileVersionUrl = http://83.103.197.79:3002/contafinupdate/default.aspx/update/download/|licenta|/contafin_local.xml *** FileVersionUrl = http://10.0.20.122:81/contafinupdate/default.aspx/update/download/|licenta|/contafin_local.xml lcVersionType = Upper(Alltrim(Transform(m.tcVersionType))) lcCheie = Iif(lcVersionType = 'CONTAFIN', 'fileversionurl', 'suportversionurl') lcVersionFileName = Iif(lcVersionType = 'CONTAFIN', 'contafin', 'suport') If !Empty(m.tcFileVersionUrl) lcFileVersionUrl = m.tcFileVersionUrl Else lcFileVersionUrl = goAPI.GetProfileString(m.lcSettingsFile, [update], m.lcCheie) lcFileVersionUrl = Nvl(m.lcFileVersionUrl, '') If Empty(m.lcFileVersionUrl) *!* 13.05.2014 cand s-a introdus taxa la dyndns, am pus ip-ul fix *!* lcFileVersionUrl = [http://] + IIF(_vfp.StartMode = 0, [10.0.20.122:81] , [romfast.dyndns.biz:3002]) + [/contafinupdate/default.aspx/update/download/|licenta|/] + ; *!* m.lcVersionFileName + [.xml] lcFileVersionUrl = [http://] + Iif(_vfp.StartMode = 0, [10.0.20.122:81], [83.103.197.79:3002]) + [/contafinupdate/default.aspx/update/download/|licenta|/] + ; M.lcVersionFileName + [.xml] *!* 13.05.2014 ^ goAPI.WriteProfileString(m.lcSettingsFile, [update], m.lcCheie, m.lcFileVersionUrl ) Else *!* 13.05.2014 cand s-a introdus taxa la dyndns, am pus ip-ul fix If [romfast.dyndns.biz] $ lcFileVersionUrl lcFileVersionUrl = Strtran(lcFileVersionUrl, [romfast.dyndns.biz], [83.103.197.79]) goAPI.WriteProfileString(m.lcSettingsFile, [update], m.lcCheie, m.lcFileVersionUrl ) Endif *!* 13.05.2014 ^ Endif Endif This.cFileVersionUrl = m.lcFileVersionUrl *!* DESCARCARE FISIER VERSIUNE If File(m.lcDownloadFileVersion) Delete File (m.lcDownloadFileVersion) Endif llReturn = This.DownloadVersionFile(m.tlCheckVersion) Catch To loEx This.lError = .T. This.cErrorMessage = loEx.Message amessagebox(This.cErrorMessage, 0 + 16, _Screen.Caption) Endtry Else This.lError = .T. This.cErrorMessage = "Nu exista fisierul " + m.lcLibraryPath + "!" amessagebox(This.cErrorMessage, 0 + 16, _Screen.Caption) Endif Endproc && Init *!* verificare versiune diferita Procedure CheckNewVersion Lparameters tcAppName, tlCheckVersion Local lcSelect, lcAppName Local loReturn lcSelect = Select() lcAppName = Upper(Juststem(Alltrim(m.tcAppName))) If Used('crsXML') If m.tlCheckVersion This.CheckVersion(m.lcAppName) Endif Select crsXMl Locate For Upper(Alltrim(Program)) = lcAppName If Found() Scatter Name loReturn AddProperty(loReturn, "newversion", Alltrim(versiune) <> Alltrim(versiuneact)) Else Scatter Name loReturn Blank AddProperty(loReturn, "newversion", .F.) Endif Else loReturn = Createobject("custom") loReturn.AddProperty("newversion", .F.) Endif Select (lcSelect) Return m.loReturn Endproc && CheckNewVersion Procedure DownloadVersionFile Lparameters tlCheckVersion Local llReturn, lcFileVersionUrl, lcDownloadFileVersion, lcTextXML Local loEx As Exception lcFileVersionUrl = This.cFileVersionUrl lcDownloadFileVersion = This.cDownloadFileVersion ****** DOWNLOAD FISIER CU ULTIMELE VERSIUNI ALE PROGRAMELOR EX:CONTAFIN.XML ******** ^ llReturn = This.DownloadFile(m.lcFileVersionUrl, m.lcDownloadFileVersion) llReturn = m.llReturn And File(m.lcDownloadFileVersion) If This.lError Messagebox(This.cErrorMessage, 0 + 64, _Screen.Caption) Endif ****** DOWNLOAD FISIER CU ULTIMELE VERSIUNI ALE PROGRAMELOR EX:CONTAFIN.XML ******** ^ Create Cursor crsXMl (Program C(200), fisier C(200), Log C(200), checksum C(100), versiune C(200), versiuneact C(100), ales N(1), Terminat N(1)) If m.llReturn lcTextXML = Filetostr(m.lcDownloadFileVersion) If Left(m.lcTextXML, 5) <> '= 4 lcVersiune = aFiles(4) Endif Replace versiuneact With m.lcVersiune Else && verific daca exista versiune.txt (in cazul _alfa care nu are executabil) If File(lcFileVersiuneText) lcVersiune = Alltrim(Filetostr(m.lcFileVersiuneText)) Replace versiuneact With m.lcVersiune Else lcVersiune = goAPI.GetProfileString(m.lcSettingsFile, [versiuni], m.lcProgram) Replace versiuneact With Nvl(m.lcVersiune, '') Endif Endif Endscan *!* scanez cursorul cu ultimele versiuni ale programelor ^ Select (m.lcSelect) Endproc && CheckVersion Procedure UpdateVersion Lparameters toUpdateRec If Type('toUpdateRec') = 'O' And Type('toUpdateRec.versiune') <> 'U' lcProgram = Alltrim(toUpdateRec.Program) lcVersiune = Alltrim(toUpdateRec.versiune) lcSettingsFile = m.gcBasePath + "settings.ini" && D:\CONTAFIN\settings.ini goAPI.WriteProfileString(m.lcSettingsFile, [versiuni], m.lcProgram, m.lcVersiune) Endif Endproc && UpdateVersion Procedure DownloadFile Lparameters tcUrl, tcDownloadFile, tcProgressProcedure, tcErrorMessage, tcCheckSum Local lcURL, llReturn, lcDownloadFile, lcProgressProcedure, lcText, lcCheckSum, llDownload Local lcCheckSumFile lcText = 'Nu s-a putut actualiza fisierul ' + Justfname(m.tcDownloadFile) + ' de pe serverul ROMFAST. Verificati conexiunea internet si/sau setarile de actualizare!' If Empty(tcCheckSum) Or Type('tcCheckSum') <> 'C' lcCheckSum = "" Else lcCheckSum = tcCheckSum Endif goLog.WriteLog("DOWNLOAD START; " + Alltrim(m.tcUrl) + " | " + Alltrim(m.tcDownloadFile), Program()) lcURL = Alltrim(m.tcUrl) lcURL = This.ReplaceLicentaTag(m.lcURL) lcDownloadFile = Alltrim(m.tcDownloadFile) lcProgressProcedure = Iif(Type('tcProgressProcedure') <> 'C', '', tcProgressProcedure) && daca am checksumul ca parametru, exista fisierul si checksumurile sunt egale nu mai downloadez llDownload = .T. If File(m.lcDownloadFile) && verific daca exista fisierul deja downloadat TODO: trebuie verificat hashul If !Empty(m.lcCheckSum) lcCheckSumFile = This.CalculateCheckSum(m.lcDownloadFile) If m.lcCheckSum == m.lcCheckSumFile && checksumurile sunt egale llDownload = .F. goLog.WriteLog("FISIERUL " + Alltrim(m.tcDownloadFile) + " EXISTA DEJA IN DIRECTORUL DE DOWNLOAD SI ARE ACELASI CHECKSUM CA CEL DE PE SERVER.", Program()) Else goLog.WriteLog("FISIERUL " + Alltrim(m.tcDownloadFile) + " EXISTA DEJA IN DIRECTORUL DE DOWNLOAD, DAR NU ARE ACELASI CHECKSUM CA CEL DE PE SERVER.", Program()) Endif Endif Endif llReturn = .F. Do Case Case !llDownload llReturn = .T. Case Upper(Left(lcURL, 4)) = "FTP:" m.llReturn = FTPGet(lcURL, m.lcDownloadFile, lcProgressProcedure) Case Upper(Left(lcURL, 5)) = "HTTP:" OR Upper(Left(lcURL, 6)) = "HTTPS:" m.llReturn = HTTPDownloadFile(lcURL, m.lcDownloadFile) Otherwise If Upper(Left(lcURL, 7)) != "FILE://" lcURL = "File://" + lcURL Endif m.llReturn = FileGet(lcURL, m.lcDownloadFile, lcProgressProcedure) Endcase *!* verific ca exista fisierul llReturn = m.llReturn And File(m.lcDownloadFile) *!* verific continutul fisierului If m.llReturn lcText = Filetostr(m.lcDownloadFile) llReturn = Left(Lower(m.lcText), 3) <> 'err' And Left(Lower(m.lcText), 6) <> '' Endif *!* verific checksum daca fisierul a fost downloadat If llReturn And llDownload And !Empty(lcCheckSum) lcCheckSumFile = This.CalculateCheckSum(m.lcDownloadFile) If m.lcCheckSum <> m.lcCheckSumFile m.lcText = 'Checksumul fisierului ' + m.lcDownloadFile + ' nu corespunde cu checksumul fisierului de pe server.' llReturn = .F. Endif Endif If !llReturn tcErrorMessage = Left(m.lcText, 100) This.cErrorMessage = tcErrorMessage This.lError = .T. Else This.cErrorMessage = "" This.lError = .F. Endif goLog.WriteLog("DOWNLOAD END; " + + Alltrim(m.tcUrl) + " | " + Alltrim(m.tcDownloadFile) + Iif(m.llReturn, " SUCCES", " " + Left(lcText, 100) + " EROARE"), Program()) Return m.llReturn Endproc && DownloadFile *!* *!* UPDATE STATUS FORMULAR *!* APELAT DIN THIS.UPDATEFILE *!* Procedure UpdateStatus Lparameters tcStatusVariable, tcStatus Local lcStatusVariable, lcStatus, lcUpdateStatus lcStatusVariable = Iif(!Empty(tcStatusVariable) And Type('tcStatusVariable') = 'C', tcStatusVariable, '') lcStatus = Iif(!Empty(tcStatus) And Type('tcStatus') = 'C', tcStatus, '') If !Empty(lcStatusVariable) lcUpdateStatus = lcStatusVariable + [ = "] + lcStatus + ["] &lcUpdateStatus If Right(Upper(lcStatusVariable), 8) = '.CAPTION' lcStatusObject = Left(lcStatusVariable, Len(lcStatusVariable) - 8) loStatusObject = Evaluate(lcStatusObject) If Pemstatus(loStatusObject, "refresh", 5) loStatusObject.Refresh() Endif Endif Endif Endproc && UpdateStatus Procedure ProgressHandler Lparameters tcFile Local lnProgress, lcFile lnProgress = 0 lcFile = Iif(Empty(m.tcFile) Or Type('tcFile') <> 'C', '', m.tcFile) If m.nConnectTotalBytes > 0 m.lnProgress = Int(m.nConnectBytesSoFar / m.nConnectTotalBytes * 100) Endif Wait Window m.lcFile + ' ' + Transform(m.lnProgress) + '% ...' Nowait Endproc && ProgressHandler Function CalculateCheckSum Lparameters tcFile Local lcCheckSum, lcText lcCheckSum = "" If File(tcFile) lcText = Filetostr( m.tcFile) lcCheckSum = Sys(2007, m.lcText, 0, 1) Endif Return m.lcCheckSum Endfunc && CalculateCheckSum Function ReplaceLicentaTag Lparameters tcText Local lcText, lcReturn lcText = Iif(Empty(tcText) Or Type('tcText') <> 'C', "", tcText) lcReturn = Iif(!Empty(This.cLicenta), Strtran(m.lcText, '|licenta|', This.cLicenta, 1, 1, 1), m.lcText) && inlocuiesc |licenta| Return m.lcReturn Endfunc && ReplaceLicentaTag Procedure Destroy Local lcSelect lcSelect = Select() If File(This.cDownloadFileVersion) Erase (This.cDownloadFileVersion) Endif Use In (Select('crsXML')) Select (lcSelect) Endproc && Destroy Enddefine && Updater PROCEDURE verificare_iban Lparameters tcXMLIBAN *** tcXMLIBAN: un xml cu codurile IBAN care trebuie verificate, 2 sau 3 coloane: "denumire", "cod_fiscal", "iban" If Left(Lower(tcXMLIBAN), 5) = " 'O' Or Isnull(toDate) Return m.lnRaspuns Endif If Pemstatus(toDate, 'cod_fiscal', 5 ) lcCodFiscal = Alltrim(NVL(toDate.cod_fiscal,'')) Endif If Pemstatus(toDate, 'denumire', 5 ) lcDenumire = Alltrim(NVL(toDate.denumire,'')) Endif If Pemstatus(toDate, 'data', 5 ) ldData = NVL(toDate.Data, {}) Endif If Pemstatus(toDate, 'cod_judet', 5 ) lcCodJudet = Alltrim(NVL(toDate.cod_judet,'')) Endif If Pemstatus(toDate, 'cod_auto', 5 ) lcCodAuto = Alltrim(NVL(toDate.cod_auto, '')) Endif If Pemstatus(toDate, 'mesaj_intrebare', 5 ) lcMesajIntrebare = Alltrim(toDate.mesaj_intrebare) Endif If Pemstatus(toDate, 'optiuni_meniu_ante', 5 ) lcOptiuniMeniuAnte = Alltrim(toDate.optiuni_meniu_ante) Endif If Pemstatus(toDate, 'tip_verificare', 5 ) lcTipVerificare = Alltrim(toDate.tip_verificare) Endif If Empty(m.lcCodFiscal) Return m.lnRaspuns Endif If Empty(m.lcTipVerificare) lcMenu = GetMeniuVerificareCodFiscal(m.lcCodFiscal, m.lcOptiuniMeniuAnte) lnOptiune = XMENU(m.lcMenu) lnOptiuneVerificare = m.lnOptiune If !Empty(m.lcOptiuniMeniuAnte) lnOptiuneVerificare = m.lnOptiuneVerificare - Occurs(';', m.lcOptiuniMeniuAnte) Endif lcTipVerificare = GetOptiuneVerificareCodFiscal(m.lnOptiuneVerificare) Else lnOptiune = 1 lnOptiuneVerificare = 1 Endif If Empty(m.lnOptiune) Return m.lnRaspuns Endif Do Case Case m.lcTipVerificare = 'ISTORIC' Do verificare_parteneri_istoric With m.lcCodFiscal && In proceduri_comune.prg Case m.lcTipVerificare = 'RTVAI_AUTO_COD' loPartenerX = Createobject("empty") loPartener = Createobject("empty") AddProperty(loPartenerX, "cod_fiscal", m.lcCodFiscal) AddProperty(loPartenerX, "denumire", m.lcDenumire) AddProperty(loPartenerX, "dataact", m.ldData) llValid = VERIFICA_RTVAI(loPartenerX, @loPartener) If !m.llValid amessagebox('Codul ' + m.lcCodFiscal + ' este invalid!', 0 + 48, _Screen.Caption) Else If Pemstatus(loPartener, "leinRtvai", 5) If loPartener.leinRtvai amessagebox('Partenerul ' + m.lcDenumire + ' cu codul fiscal: ' + m.lcCodFiscal + crlf + ' este in sistemul TVA la incasare!', 0 + 48, _Screen.Caption) Else amessagebox('Partenerul ' + m.lcDenumire + ' cu codul fiscal: ' + m.lcCodFiscal + crlf + ' NU este in sistemul TVA la incasare!', 0 + 48, _Screen.Caption) Endif Endif ENDIF Case m.lcTipVerificare = 'VIES_AUTO' loPartenerX = Createobject("empty") loPartener = Createobject("empty") AddProperty(loPartenerX, "cod_fiscal", m.lcCodFiscal) AddProperty(loPartenerX, "denumire", m.lcDenumire) AddProperty(loPartenerX, "dataact", m.ldData) llValid = verifica_partener(m.lcTipVerificare, loPartenerX, @loPartener) If !m.llValid amessagebox('Codul ' + m.lcCodFiscal + ' este invalid!', 0 + 48, _Screen.Caption) ELSE llPlatitorTVAVIES = loPartener.PlatitorTVA llVIES = loPartener.VIES lcText = 'VERIFICARE CIF: ' + m.lcCodFiscal + ' ' + m.lcDenumire + crlf + crlf + ; Alltrim(NVL(loPartener.firma,'')) + crlf + ; Alltrim(NVL(loPartener.adresa,'')) + crlf + ; Iif(m.llVIES, 'S-a interogat baza de date VIES: ' + Iif(m.llPlatitorTVAVIES, 'PLATITOR TVA VIES', 'NEPLATITOR TVA VIES'), 'Nu s-a interogat baza de date VIES!') AMESSAGEBOX(m.lcText, 0+64, _Screen.Caption) ENDIF Otherwise loPartenerX = Createobject("empty") loPartener = Createobject("empty") AddProperty(loPartenerX, "cod_fiscal", m.lcCodFiscal) AddProperty(loPartenerX, "denumire", m.lcDenumire) AddProperty(loPartenerX, "dataact", m.ldData) llValid = verifica_partener(m.lcTipVerificare, loPartenerX, @loPartener) If !m.llValid amessagebox('Codul ' + m.lcCodFiscal + ' este invalid!', 0 + 48, _Screen.Caption) ELSE If Pemstatus(loPartener, "platitortvamfin", 5) lnRaspuns = verifica_partener_show_info(loPartener, m.lcCodFiscal, m.lcDenumire, m.lcMesajIntrebare) ENDIF Endif Endcase Return m.lnRaspuns && raspunsul la intrebarea 'Doriti sa completati datele partenerului?' in formularul Adaugare partener Endproc && VerificaCodFiscal **************************************************************** *** Verificare manuala platitor TVA pe mfinante.ro / registru inactivi anaf.ro / registru tva incasare anaf.ro *** Lanseaza browserul cu adresa mfinante.ro, anaf.ro **************************************************************** Procedure VERIFICA_MANUAL_MFINANAF Lparameters tcTip, tcCodFiscal, tcDenumire, tcCodJudet *** tcTIP: MFIN/MFINCOD/MFINNUME/ANAF *** tcCodFiscal: MFIN - se face verificarea dupa cod fiscal daca este completat, altfel verificare dupa nume, judet Local lcCodAuto, lcCodFiscal, lcDenumire, lcTipVerificare, lcURL, lcAtributFiscal lcCodFiscal = UPPER(Alltrim(Transform(m.tcCodFiscal))) lcDenumire = Alltrim(Transform(m.tcDenumire)) lcCodJudet = Alltrim(Transform(m.tcCodJudet)) lcURL = "" lcAtributFiscal = '' If Isalpha(m.lcCodFiscal) lcAtributFiscal = lcAtributFiscal + LEFT(m.lcCodFiscal,1) lcCodFiscal = Alltrim(Substr(m.lcCodFiscal, 2)) If Isalpha(lcCodFiscal) lcAtributFiscal = lcAtributFiscal + LEFT(m.lcCodFiscal,1) lcCodFiscal = Alltrim(Substr(m.lcCodFiscal, 2)) Endif Endif lctip = Iif(!Empty(m.tcTip), Upper(Alltrim(m.tcTip)), "MFIN") Do Case Case "MFIN" $ m.lctip lcTipVerificare = Iif("NUME" $ m.lctip, "NUME", "COD") If m.lcTipVerificare = "COD" lcURL = "https://www.mfinante.gov.ro/apps/infocodfiscal.html?cod=" + m.lcCodFiscal Else lcURL = "https://www.mfinante.gov.ro/apps/numeCod.html?judet=" + m.lcCodJudet + "&name=" + m.lcDenumire + "&submit=VIZUALIZARE" Endif Case "ANAF" $ m.lctip Text To lcURL Noshow Textmerge https://www.anaf.ro/inactivi?codFiscal=<>&judet=<>&inputdenumire=<> Endtext Case "RTVAI" $ m.lctip Text To lcURL Noshow Textmerge https://www.anaf.ro/IncasareTva/cautCodTvaIncasare.do?codFiscal=<> Endtext Case "VIES" $ m.lctip Text To lcURL Noshow Textmerge https://ec.europa.eu/taxation_customs/vies/viesquer.do?iso=<>&vat=<>&ms=<> ENDTEXT Endcase If !Empty(m.lcURL) OPEN_DEFAULT_APP(m.lcURL) Endif Endproc && VERIFICA_MANUAL_MFINANAF ************************************************************ *** VERIFICA DACA PARTENERUL ESTE IN REGISTRUL TVA INCASARE ************************************************************ Procedure VERIFICA_RTVAI Lparameters toPartener, toPartenerOut * toPartener datele partenerului: cod_fiscal,denumire,dataact * toPartenerOut (OUT): denumire,leInRTVAI din AgentiRtvai Local lcCodFiscal, lcDenumire, ldDataAct, llIsCIF, llValid, lcSql, llSucces Local loVerificare As "verificarecod" Private pcDenumire, pdData, pnCodFiscal, pnRTVAI If Type('toPartener') = 'O' lcCodFiscal = Iif(Pemstatus(toPartener, "cod_fiscal", 5), Alltrim(toPartener.cod_fiscal), '') lcDenumire = Iif(Pemstatus(toPartener, "denumire", 5), Alltrim(Upper(toPartener.denumire)), '') ldDataAct = Iif(Pemstatus(toPartener, "dataact", 5), toPartener.dataact, {}) Else lcCodFiscal = Transform(toPartener) Endif loVerificare = Createobject("verificarecod") && validare.prg llIsCIF = loVerificare.IsCIF(m.lcCodFiscal) *!* VERIFIC VALIDITATEA CODULUI If m.llIsCIF llValid = loVerificare.Validare('CIF', m.lcCodFiscal) *!* Else *!* llValid = loVerificare.Validare('CNP', m.lcCodFiscal) Endif If !Pemstatus(toPartenerOut, "leinRtvai", 5) AddProperty(toPartenerOut, "leinRtvai", .F.) Endif If !Pemstatus(toPartenerOut, "denumire", 5) AddProperty(toPartenerOut, "denumire", "") Endif If m.llIsCIF AND m.llValid If Empty(m.ldDataAct) ldDataAct = Date(m.gnAn, m.gnLuna, 1) Endif If Isalpha(m.lcCodFiscal) lcCodFiscal = Alltrim(Substr(m.lcCodFiscal, 2)) If Isalpha(lcCodFiscal) lcCodFiscal = Alltrim(Substr(m.lcCodFiscal, 2)) Endif Endif pnCodFiscal = Int(Val(m.lcCodFiscal)) pdData = ldDataAct pcDenumire = '' pnRTVAI = 0 lcSql = [begin pack_roartvai.PartenerInRTVAI(?pnCodFiscal, ?pdData, ?@pcDenumire, ?@pnRTVAI); end;] llSucces = goExecutor.oExecuta(m.lcSql) If m.llSucces toPartenerOut.leinRtvai = (m.pnRTVAI = 1) toPartenerOut.denumire = Alltrim(Nvl(pcDenumire, '')) Endif Endif && m.llValid Return m.llValid Endproc && VERIFICA_RTVAI ************************************************************ *** Intoarce .T. daca codul fiscal exista in REGISTRUL TVA INCASARE la data ************************************************************ Function VERIFICA_RTVAI_DATA Lparameters tcCodFiscal, tdDataAct, tcDenumire * tcCodFiscal: codul fiscal de verificat in RTVAI * tdDataAct: data documentului (optional) / 1 ale lunii curente, daca nu este dat * tcDenumire: OUT denumirea din RTVAI, daca exista Private pcDenumire, pdData, pnCodFiscal, pnRTVAI Local lcCodFiscal, lcDenumire, lcSql, ldDataAct, leinRtvai, llSucces leinRtvai = .F. tcDenumire = '' lcCodFiscal = Iif(Type('tcCodFiscal') = 'C', Alltrim(Nvl(m.tcCodFiscal, '')), '') ldDataAct = Iif(!Empty(m.tdDataAct), m.tdDataAct, Date(m.gnAn, m.gnLuna, 1)) If Empty(m.lcCodFiscal) Return m.leinRtvai Endif If Isalpha(m.lcCodFiscal) lcCodFiscal = Alltrim(Substr(m.lcCodFiscal, 2)) If Isalpha(lcCodFiscal) lcCodFiscal = Alltrim(Substr(m.lcCodFiscal, 2)) Endif Endif pnCodFiscal = Int(Val(m.lcCodFiscal)) pdData = ldDataAct pcDenumire = '' pnRTVAI = 0 lcSql = [begin pack_roartvai.PartenerInRTVAI(?pnCodFiscal, ?pdData, ?@pcDenumire, ?@pnRTVAI); end;] llSucces = goExecutor.oExecuta(m.lcSql) If m.llSucces leinRtvai = (m.pnRTVAI = 1) tcDenumire = Alltrim(Nvl(m.pcDenumire, '')) Endif Return m.leinRtvai Endfunc && VERIFICA_RTVAI_DATA ********************************************* *** inlocuieste caracterele speciale dintr-un text xml *** ex: "&" devine "&" Function XmlSpecialCharacters Lparameters tcText Local lcText lcText = tcText lcText = Strtran(m.lcText, '&', '&') lcText = Strtran(m.lcText, '"', '"') lcText = Strtran(m.lcText, ['], ''') lcText = Strtran(m.lcText, '<', '<') lcText = Strtran(m.lcText, '>', '>') Return lcText Endfunc && XmlSpecialCharacters ********************************************* *** curata caracterele care nu sunt permise in nume de fisiere Windows *** inlocuiesc cu tcReplaceCharacter Function WindowsSpecialCharacters Lparameters tcText, tcReplaceCharacter * tcReplaceCharacter: caracterul cu care se inlocuiesc caracterele nepermise in numele fisierelor. Optional, default: '' Local lcText, lcRC lcRC= IIF(!EMPTY(m.tcReplaceCharacter) and TYPE('tcReplaceCharacter') = 'C' and AT(m.tcReplaceCharacter, [/\?%*:|"<>.,;=]) = 0, m.tcReplaceCharacter, '') lcText = STRTRAN(STRTRAN(STRTRAN(STRTRAN(STRTRAN(STRTRAN(STRTRAN(STRTRAN(Strtran(TRANSFORM(m.tcText), [<], m.lcRC,1,10), [>], m.lcRC,1,10), [:], m.lcRC,1,10), ["], m.lcRC,1,10), ; [/], m.lcRC,1,10), [\], m.lcRC,1,10), [|], m.lcRC,1,10), [?], m.lcRC,1,10), [*], m.lcRC,1,10) Return lcText Endfunc && WindowsSpecialCharacters ********************************************* *** face conversia de la Double Byte la UTF8 *** curata textul de diacritice, spatii, CR/LF, *** lcMesaj = RemoveCharactersDB(lcMesaj, .T.) ********************************************* FUNCTION RemoveCharactersDB Lparameters tcText, tlDiacritics, tlSpaces, tlCR LOCAL lcText lcText = STRCONV(tcText, 9) && conversie la UTF-8 lcText = RemoveCharacters(tcText, tlDiacritics, tlSpaces, tlCR) RETURN m.lcText ENDFUNC ********************************************* *** curata textul de diacritice, spatii, CR/LF ********************************************* Function RemoveCharacters Lparameters tcText, tlDiacritics, tlSpaces, tlCR *** tcText: textul initial *** tlDiacritics: inlocuieste diacriticele *** tlSpaces: sterge spatiile *** tlCR: sterge CR si LF Local lcText lcText = IIF(TYPE('tcText') = 'C', Nvl(m.tcText, ''), '') IF EMPTY(m.lcText) RETURN '' ENDIF If m.tlDiacritics lcText = STRTRAN(STRTRAN(Strtran(Nvl(m.lcText, ''), Chr(197) + CHR(162), 'T', 1,100,1), Chr(197) + CHR(63), 'S', 1,100,1), Chr(196) + CHR(63), 'A', 1,100,1) lcText = Strtran(Nvl(m.lcText, ''), Chr(195) + CHR(63), 'I', 1,100,1) lcText = Strtran(Strtran(Strtran(Strtran(Strtran(Nvl(m.lcText, ''), Chr(170), 'S', 1,100,1), Chr(222), 'T', 1,100,1), Chr(226), 'A', 1,100,1), Chr(227), 'A', 1,100,1), Chr(238), 'I', 1,100,1) lcText = STRTRAN(Strtran(Strtran(Strtran(Nvl(m.lcText, ''), Chr(206), 'I', 1,100,1), Chr(194), 'A', 1,100,1), Chr(195), 'A', 1,100,1), Chr(196), 'A', 1,100,1) lcText = STRTRAN(m.lcText, CHR(2), '',1,100,1) && caracter neprintabil * Inlocuiri pentru diacritice - minuscule lcText = STRTRAN(lcText, "A„?", "a") && a lcText = STRTRAN(lcText, "Ac??", "a") && ā lcText = STRTRAN(lcText, "A^?", "t") && ? lcText = STRTRAN(lcText, "AfA®", "i") && ī lcText = STRTRAN(lcText, "A„", "a") && a (alta varianta) lcText = STRTRAN(lcText, "Až", "s") && ? * Inlocuiri pentru diacritice - majuscule lcText = STRTRAN(lcText, "A‚", "A") && A lcText = STRTRAN(lcText, "A®", "I") && I lcText = STRTRAN(lcText, "Až", "S") && ? lcText = STRTRAN(lcText, "Ac", "T") && ? lcText = STRTRAN(lcText, "Ă", "A") && A ENDIF If m.tlSpaces lcText = Strtran(m.lcText, ' ', '', 1, 100, 1) Endif If m.tlCR lcText = Strtran(Strtran(m.lcText, Chr(13), ''), Chr(10), '') Endif Return m.lcText Endfunc **************************************************** Function OracleSpecialCharacters Lparameters tcText Local lcText lcText = tcText lcText = Strtran(m.lcText, "'", "''") Return lcText Endfunc && OracleSpecialCharacters **************************************************** *** Citeste din optiuni utilizator ordinea coloanelor dintr-un grid de tipul ferestre_cere_date.vcx > ct_grid_search *** ointroduceri.prg > lans_nir_bon > grid nomenclator articole *** ointroduceri.prg > achizitie_import > fereastra cautare repere pentru adaugare *** Intoarce obiectul loSelectie(titlu_col M, nume_col M, ordine C(50), width_col M, pornire N(2)) *** Pentru salvarea ordinii coloanelor din grid, criteriului de sortare se apeleaza SCRIE_SELECTII_OPTIUNI_UTILIZATOR() **************************************************** Procedure CITESTE_SELECTII_OPTIUNI_UTILIZATOR Lparameters tcOptiune, tcListaColoaneGrid, tcCursor, tcSearchColumn, tuSearchValue *!* CITESTE_SELECTII_OPTIUNI_UTILIZATOR("GEST_SELECTII", ost.nume_col, "crsGestSelectiiUtilizator", "id_sel", oSet.id_selSt) *!* tcOptiune: "GEST_SELECTII" *!* tcListaColoaneGrid: lista coloanelor din grid: "codmat;denumire;um;serie;cantitate;pret;cant_bax;um2;grupa;subgrupa;cgest;cont;acont;datain;codmatf;lot;adata_expirare;nrord_rez;part_rez" *!* tcCursor: "crsGestSelectiiUtilizator" (default = "crsSelectiiUtilizator") *!* tcSearchColumn (optional): "ID_SEL" (daca in cursorul xml sunt mai multe inregistrari si doresc o anume inregistrare) *!* tuSearchValue (optional): 1 (valoarea pentru tcSearchColumn) *!* RETURN: loSelectie (titlu_col, nume_col, ordine, width_col, pornire) Local lcCursor, lcListaColoaneCursor, lcListaColoaneGrid, lcOptiune, lcSchemaCursor, lcSearchColumn Local lcSelectii, lcSirOrdonatCursor, lcSirOrdonatGrid, loSelectie, luSearchValue lcOptiune = Upper(Alltrim(tcOptiune)) lcListaColoaneGrid = m.tcListaColoaneGrid lcCursor = Iif(!Empty(m.tcCursor), m.tcCursor, "crsSelectiiUtilizator") lcSearchColumn = "" luSearchValue = "" If !Empty(tcSearchColumn) And !Empty(tuSearchValue) And Type('tcSearchColumn') = 'C' lcSearchColumn = Upper(Alltrim(tcSearchColumn)) luSearchValue = tuSearchValue Endif lcSchemaCursor = "titlu_col M, nume_col M, ordine C(50), width_col M, pornire N(2)" If !Empty(m.lcSearchColumn) lcSchemaCursor = lcSearchColumn + " " + Type('tuSearchValue') + "(" + Len(tuSearchValue) + ")," + m.lcSchemaCursor Endif Create Cursor (m.lcCursor) (&lcSchemaCursor) Select (m.lcCursor) Scatter Name loSelectie Memo Blank lcSelectii = citeste_optiune_utilizator(m.lcOptiune) If !Empty(m.lcSelectii) Xmltocursor(m.lcSelectii, m.lcCursor) Select (m.lcCursor) If !Empty(m.lcSearchColumn) Locate For &lcSearchColumn = luSearchValue If Found() Scatter Name loSelectie Memo Endif Else Go Top Scatter Name loSelectie Memo Endif **-- compara daca am aceleasi coloane (control source) pe server si in tabelul din proiect (gest_selectii) Create Cursor crsListaCursor (element C(100)) Create Cursor crsListaGrid (element C(100)) lcListaColoaneCursor = loSelectie.nume_col lista2cursor(lcListaColoaneCursor, "crsListaCursor", "element", ";") lista2cursor(lcListaColoaneGrid, "crsListaGrid", "element", ";") Select * From crsListaCursor ; Order By element ; Into Cursor crsListaCursorOrd Select * From crsListaGrid ; Order By element ; Into Cursor crsListaGridOrd lcSirOrdonatCursor = cursor2lista("crsListaCursorOrd", "element", ";") lcSirOrdonatGrid = cursor2lista("crsListaGridOrd", "element", ";") Use In (Select('crsListaCursor')) Use In (Select('crsListaGrid')) Use In (Select('crsListaCursorOrd')) Use In (Select('crsListaGridOrd')) If lcSirOrdonatCursor <> lcSirOrdonatGrid Select (m.lcCursor) Scatter Name loSelectie Memo Blank Endif Endif Return loSelectie Endproc && CITESTE_SELECTII_OPTIUNI_UTILIZATOR ************************************************************************************************ *** NIR.INAINTE_DE_DO_TERMIN *** SCRIE_SELECTII_OPTIUNI_UTILIZATOR("GEST_SELECTII", toCtGridSearch, ["crsGestSelectiiUtilizator", "id_sel", oSet.id_selSt]) *** tcOptiune: "GEST_SELECTII" *** toCtGridSearch: referinta la containerul cu grid de tipul ct_grid_search *** tcDescriere (optional): descriere optiune *** tcCursor (optional): "crsGestSelectiiUtilizator" (default = "crsSelectiiUtilizator") *** tcSearchColumn (optional): "ID_SEL" (daca in cursorul xml sunt mai multe inregistrari si doresc sa modific o anume inregistrare) *** tuSearchValue (optional): 1 (valoarea pentru tcSearchColumn) ************************************************************************************************ Procedure SCRIE_SELECTII_OPTIUNI_UTILIZATOR Lparameters tcOptiune, toCtGridSearch, tcDescriere, tcCursor, tcSearchColumn, tuSearchValue Local lcDescriere, lcSearchColumn, luSearchValue Local loCtGridSearch, lcOptiune, lcCursor, lcSelect Local lcColOrd, lcControlSource, lcControlSource2, lcCursorXML, lcHeader, lcHeader2, lcNumeCol Local lcOrd, lcOrdine, lcTitluCol, lcWidthCol, lcWidthColumn, lcWidthColumn2, llNrOrd, lnColOrd Local lnNrCols, lnPornire, loSelectie, i lcSelect = Select() loCtGridSearch = toCtGridSearch lcOptiune = Upper(Alltrim(tcOptiune)) lcCursor = Iif(!Empty(m.tcCursor), m.tcCursor, "crsSelectiiUtilizator") lcDescriere = Iif(!Empty(m.tcDescriere), Alltrim(m.tcDescriere), Program(1)) lcSearchColumn = Iif(!Empty(m.tcSearchColumn), Alltrim(m.tcSearchColumn), "") luSearchValue = Iif(!Empty(m.luSearchValue), m.luSearchValue, "") Create Cursor crsGrid (ordine N(3), ctrSource C(100), titlu C(100), widthCol C(100)) lnNrCols = loCtGridSearch._GRID1.ColumnCount llNrOrd = loCtGridSearch.lNumerotare lnPornire = Val(loCtGridSearch.cb_tx_cautare1.criteriu.Value) For i = 1 To lnNrCols If llNrOrd And i <> 1 && ce se intampla daca nu e llNrOrd ?????? lcColOrd = [loCtGridSearch._grID1.column] + Alltrim(Str(i)) + [.columnorder] lnColOrd = &lcColOrd *!* modificare v 2.1.19 *!* lcHeader = [this.ct_grid_search1._grid1.column] + Alltrim(Str(I))+ [.grh]+Alltrim(Str(I))+[.]+[Caption] lcHeader = [loCtGridSearch._GRID1.column] + Alltrim(Str(i)) + [.grh] + Alltrim(Str(i)) If Type(lcHeader) = 'O' lcHeader = lcHeader + [.Caption] Else *!* daca nu se poate ordona dupa coloana respectiva, atunci am Header1 in loc de grhI lcHeader = [loCtGridSearch._GRID1.column] + Alltrim(Str(i)) + [.header1.Caption] Endif *!* modificare v 2.1.19 ^ lcHeader2 = &lcHeader lcControlSource = [loCtGridSearch._grid1.column] + Alltrim(Str(i)) + [.ControlSource] lcControlSource2 = &lcControlSource lcWidthColumn = [loCtGridSearch._grid1.column] + Alltrim(Str(i)) + [.width] lcWidthColumn2 = Alltrim(Str(&lcWidthColumn)) Insert Into crsGrid (ordine, titlu, ctrSource, widthCol) Values (lnColOrd, lcHeader2, lcControlSource2, lcWidthColumn2) Endif Endfor Select * From crsGrid Order By ordine Into Cursor crsGridOrd Use In (Select('crsGrid')) lcTitluCol = "" lcNumeCol = "" lcWidthCol = "" Select crsGridOrd Scan lcTitluCol = lcTitluCol + Alltrim(titlu) + "," lcNumeCol = lcNumeCol + Alltrim(ctrSource) + ";" lcWidthCol = lcWidthCol + Alltrim(widthCol) + ";" Select crsGridOrd Endscan lcTitluCol = Substr(lcTitluCol, 1, Len(lcTitluCol) - 1) lcNumeCol = Substr(lcNumeCol, 1, Len(lcNumeCol) - 1) lcWidthCol = Substr(lcWidthCol, 1, Len(lcWidthCol) - 1) lcOrd = [loCtGridSearch.corder] lcOrdine = &lcOrd Select (m.lcCursor) Scatter Name loSelectie Memo Blank With loSelectie .titlu_Col = m.lcTitluCol .nume_col = m.lcNumeCol .ordine = m.lcOrdine .width_Col = m.lcWidthCol .pornire = m.lnPornire Endwith If !Empty(m.lcSearchColumn) loSelectie.&lcSearchColumn = luSearchValue && loSelectii.id_sel = oSet.id_selSt Locate For &lcSearchColumn = luSearchValue If Found() Delete Endif Else Go Top Delete Endif Insert Into (m.lcCursor) From Name loSelectie lcCursorXML = '' Cursortoxml(m.lcCursor, "lcCursorXML", 2, 0 + 2 + 8, 0, "1") scrie_optiune_utilizator(m.lcOptiune, lcCursorXML, "Ordinea coloanelor in tabelul din stanga in formularele de nir, bon, etc.") Select (m.lcSelect) Endproc && SCRIE_SELECTII_OPTIUNI_UTILIZATOR *---------------------------------------------------------------------- * Function....: ExportToXMLExcel * Author......: Core concepts presented at SW Fox 2009 by Cristof Wollenhaupt * : Enhancements 11/21/2009 by Stein Goering * Abstract....: Exports the current cursor to Excel (XMLSS format), optionally creates file * Returns.....: XML string, or number of bytes written if file is specified * Parameters..: Path and Filename of Excel file (optional) * Notes.......: *---------------------------------------------------------------------- #If .F. * Example of usage Create Cursor Sample (cData C(30), nData N(9, 3), tData D, iData i, lData L) Insert Into Sample Values("MadFox Rocks!", 0, {}, 5, .F.) Insert Into Sample Values("abcdefghijklmnopqrstuvwxyz123", 34.987, Datetime(), -32760, .T.) Insert Into Sample Values("1.23", 56, Datetime(), 6, .F.) Browse If ExportToXMLExcel("Sample.xls") = 0 Wait Window [Problem writing file] Endif #Endif Function ExportToXMLExcel(lcFileName) Local lcWorksheet, lcPoint, lcData, lcRow, lnField, luValue, lcFieldName, lcType, lnWidth, lcColDef, lnCols Local lcHeading, lnRows, lcStyles *-------------------------------------------------------------------------------------- * Set up environment *-------------------------------------------------------------------------------------- lcPoint = Set("Point") Set Point To "." *-------------------------------------------------------------------------------------- * Create the style string *-------------------------------------------------------------------------------------- Set Textmerge Delimiters Text To lcStyles Noshow Pretext 3 Endtext *-------------------------------------------------------------------------------------- * Assemble the column width and heading strings *-------------------------------------------------------------------------------------- lcHeading = "" lcColDef = [] Dimension laFields[1] lnCols = Afields(laFields) For lnField = 1 To lnCols lcFieldName = Proper(Strtran(laFields[m.lnField, 1], [_], [ ])) lcHeading = m.lcHeading + ; [] + Strconv(lcFieldName, 9) + [] lcType = laFields[m.lnField, 2] lnWidth = Icase(lcType = [C], laFields[m.lnField, 3] * 4.5, lcType = [N], laFields[m.lnField, 3] * 5, lcType = [I], 40, lcType = [D], 60, lcType = [T], 90, lcType = [L], 25, 50) lnWidth = Max(lnWidth, Len(lcFieldName) * 6) && Make sure col is wide enough to show the heading Text To lcColDef Additive Textmerge Noshow Pretext 3 Endtext Endfor lcHeading = m.lcHeading + "" *-------------------------------------------------------------------------------------- * Assemble the content string *-------------------------------------------------------------------------------------- lcData = "" lnRows = 1 Scan lcRow = "" For lnField = 1 To lnCols luValue = Evaluate(Field(m.lnField)) lcType = laFields[m.lnField, 2] Do Case Case lcType == "C" luValue = Alltrim(Nvl(m.luValue, "")) lcRow = m.lcRow + ; [] + Strconv(m.luValue, 9) + [] Case lcType == "L" luValue = Iif(m.luValue, [True], [False]) lcRow = m.lcRow + ; [] + Strconv(m.luValue, 9) + [] Case lcType == "N" lcRow = m.lcRow + ; [] + Transform(Nvl(m.luValue, 0)) + ; [] Case lcType == "I" lcRow = m.lcRow + ; [] + Transform(Nvl(m.luValue, 0)) + ; [] Case lcType == "D" If Empty(m.luValue) lcRow = m.lcRow + ; [] Else lcRow = m.lcRow + ; [] + Ttoc(Evl(m.luValue, Dtot(Date(1899, 1, 1))), 3) + ; [] Endif Case lcType == "T" If Empty(m.luValue) lcRow = m.lcRow + ; [] Else lcRow = m.lcRow + ; [] + Ttoc(Evl(m.luValue, Dtot(Date(1899, 1, 1))), 3) + ; [] Endif Otherwise Assert .F. Message "Type not supported" Endcase lnRows = lnRows + 1 Endfor lcRow = m.lcRow + "" lcData = m.lcData + m.lcRow Endscan *-------------------------------------------------------------------------------------- * Merge the results into the template *-------------------------------------------------------------------------------------- Text To m.lcWorksheet Textmerge Noshow Pretext 3 <> <> <> <>
Endtext *-------------------------------------------------------------------------------------- * Restore environment *-------------------------------------------------------------------------------------- Set Point To m.lcPoint If !Empty(lcFileName) Return Strtofile(m.lcWorksheet, lcFileName) Else Return m.lcWorksheet Endif Endfunc && ExportToXMLExcel *-------------------------------------------------------------------------------------- * calculeaza procentul de tva din tva/pret *-------------------------------------------------------------------------------------- Function TVA2PROCTVA Lparameters tnTVA, tnPret Local lnProcTVA lnProcTVA = 1 If tnPret = 0 Or tnTVA = 0 lnProcTVA = 1 Else lnProcTVA = Round(tnTVA/tnPret, 2) DO CASE CASE gnAn*12+gnLuna >= 2025*12+8 DO CASE CASE Between(lnProcTVA, 0.10, 0.12) lnProcTVA = 1.11 CASE Between(lnProcTVA, 0.20, 0.22) lnProcTVA = 1.21 OTHERWISE lnProcTVA = 1.21 ENDCASE CASE BETWEEN(gnAn*12+gnLuna, 2024*12+1, 2025*12+7) DO CASE CASE Between(lnProcTVA, 0.08, 0.11) lnProcTVA = 1.09 CASE Between(lnProcTVA, 0.18, 0.20) lnProcTVA = 1.19 CASE Between(lnProcTVA, 0.04, 0.06) lnProcTVA = 1.05 OTHERWISE lnProcTVA = 1.19 ENDCASE OTHERWISE lnProcTVA = GetCoeficientTvaStandard() ENDCASE ENDIF Return lnProcTVA Endfunc && TVA2PROCTVA *!* roagest v 2.0.24 ^ *!* INTOARCE IDJTVA PENTRU COTA STANDARD IN FUNCTIE DE LUNA *!* 07/2010 S-A MODIFICAT TVA 24% FUNCTION GetIdJtvaStandard(tcTip, tnProcTVA) *!* tcRegistru: JC/JV *!* tcTip: VANZARE/VANZARE_TI *!* ACHIZITIE/ACHIZITIE_CAPITAL/ACHIZITIE_VANZARE/ACHIZITIE_MATERII/ *!* ACHIZITIE_TI/ACHIZITIE_TI_CAPITAL/ACHIZITIE_TI_VANZARE/ACHIZITIE_TI_MATERII LOCAL lcTip, lnIdJtvaStandard, lnIdVanzareNepl Local lnIdVanzare, lnIdVanzareTI, lnIdAchizitieCapital, lnIdAchizitieVanzare, lnIdAchizitieMaterii Local lnIdAchizitieTICapital, lnIdAchizitieTIVanzare, lnIdAchizitieTIMaterii, lnIdAchizitie, lnIdAchizitieTI lcTip = IIF(EMPTY(tcTip) OR TYPE('tcTip') <> 'C', 'VANZARE', UPPER(ALLTRIM(m.tcTip))) lnProcTVA = IIF(TYPE('tnProcTVA') = 'N', m.tnProcTVA, GetProcTvaStandard()) lnIdVanzareNepl = 8 lnIdAchizitieNepl = 113 DO CASE CASE m.gnAn * 12 + m.gnLuna >= 2025 * 12 + 8 * 21% lnIdVanzare = IIF(lnProcTVA = 21, 35, IIF(lnProcTVA = 11, 39, 35)) lnIdVanzareTI = 5 lnIdAchizitieCapital = IIF(lnProcTVA = 21, 208, IIF(lnProcTVA = 11, 212, 208)) lnIdAchizitieVanzare = IIF(lnProcTVA = 21, 208, IIF(lnProcTVA = 11, 212, 208)) lnIdAchizitieMaterii = IIF(lnProcTVA = 21, 208, IIF(lnProcTVA = 11, 212, 208)) lnIdAchizitieTICapital = IIF(lnProcTVA = 21, 216, IIF(lnProcTVA = 11, 212, 218)) lnIdAchizitieTIVanzare = IIF(lnProcTVA = 21, 216, IIF(lnProcTVA = 11, 212, 218)) lnIdAchizitieTIMaterii = IIF(lnProcTVA = 21, 216, IIF(lnProcTVA = 11, 212, 218)) CASE m.gnAn * 12 + m.gnLuna <= 2010 * 12 + 6 * 19% lnIdVanzare = 1 lnIdVanzareTI = 5 lnIdAchizitieCapital = 101 lnIdAchizitieVanzare = 103 lnIdAchizitieMaterii = 105 lnIdAchizitieTICapital = 137 lnIdAchizitieTIVanzare = 139 lnIdAchizitieTIMaterii = 141 OTHERWISE lnIdVanzare = IIF(lnProcTVA = 24, 15, IIF(lnProcTVA = 20, 27, IIF(lnProcTVA = 19, 1, IIF(lnProcTVA = 9, 3, 13)))) lnIdVanzareTI = 5 lnIdAchizitieCapital = IIF(lnProcTVA = 24, 156, IIF(lnProcTVA = 20, 176, IIF(lnProcTVA = 19, 101, IIF(lnProcTVA = 9, 107, 176)))) lnIdAchizitieVanzare = IIF(lnProcTVA = 24, 156, IIF(lnProcTVA = 20, 176, IIF(lnProcTVA = 19, 103, IIF(lnProcTVA = 9, 109, 176)))) lnIdAchizitieMaterii = IIF(lnProcTVA = 24, 156, IIF(lnProcTVA = 20, 176, IIF(lnProcTVA = 19, 105, IIF(lnProcTVA = 9, 111, 176)))) lnIdAchizitieTICapital = IIF(lnProcTVA = 24, 162, IIF(lnProcTVA = 20, 186, IIF(lnProcTVA = 19, 137, IIF(lnProcTVA = 9, 143, 186)))) lnIdAchizitieTIVanzare = IIF(lnProcTVA = 24, 162, IIF(lnProcTVA = 20, 186, IIF(lnProcTVA = 19, 139, IIF(lnProcTVA = 9, 143, 186)))) lnIdAchizitieTIMaterii = IIF(lnProcTVA = 24, 162, IIF(lnProcTVA = 20, 186, IIF(lnProcTVA = 29, 141, IIF(lnProcTVA = 9, 145, 186)))) ENDCASE lnIdAchizitie = lnIdAchizitieMaterii lnIdAchizitieTI = lnIdAchizitieTIMaterii lnIdJtvaStandard = lnIdVanzare DO CASE CASE 'VANZARE'$lcTip AND m.gnNEPLATITOARE_TVA = 1 lnIdJtvaStandard = m.lnIdVanzareNepl CASE 'ACHZITIE'$lcTip AND m.gnNEPLATITOARE_TVA = 1 lnIdJtvaStandard = m.lnIdAchizitieNepl CASE lcTip = 'VANZARE' lnIdJtvaStandard = m.lnIdVanzare CASE lcTip = 'VANZARE_TI' lnIdJtvaStandard = lnIdVanzareTI CASE lcTip = 'ACHIZITIE' lnIdJtvaStandard = m.lnIdAchizitie CASE lcTip = 'ACHIZITIE_CAPITAL' lnIdJtvaStandard = lnIdAchizitieCapital CASE lcTip = 'ACHIZITIE_VANZARE' lnIdJtvaStandard = lnIdAchizitieVanzare CASE lcTip = 'ACHIZITIE_MATERII' lnIdJtvaStandard = lnIdAchizitieMaterii CASE lcTip = 'ACHIZITIE_TI' lnIdJtvaStandard = lnIdAchizitieTI CASE lcTip = 'ACHIZITIE_TI_CAPITAL' lnIdJtvaStandard = lnIdAchizitieTICapital CASE lcTip = 'ACHIZITIE_TI_VANZARE' lnIdJtvaStandard = lnIdAchizitieTIVanzare CASE lcTip = 'ACHIZITIE_MATERII' lnIdJtvaStandard = lnIdAchizitieTIMaterii ENDCASE RETURN lnIdJtvaStandard ENDFUNC *********************************************************************** *!* INTOARCE PROCENTUL DE TVA STANDARD IN FUNCTIE DE LUNA 24 *!* 07/2010 S-A MODIFICAT TVA 24% *!* 01/2016 S-A MODIFICAT TVA 20% *!* 01/2017 S-A MODIFICAT TVA 19%, 9%, 5% *!* 08/2025 S-A MODIFICAT TVA 21% , 11% FUNCTION GetProcTvaStandard LOCAL lnAn, lnLuna, lnProcTva lnAn = m.gnAn lnLuna = m.gnLuna lnProcTva = 21 DO CASE CASE m.lnAn * 12 + m.lnLuna >= 2025 * 12 + 8 lnProcTva = 21 CASE BETWEEN(m.lnAn * 12 + m.lnLuna, 2007*12+1, 2010 * 12 + 7) lnProcTva = 19 CASE BETWEEN(m.lnAn * 12 + m.lnLuna, 2010*12+8, 2015 * 12 + 12) lnProcTva = 24 CASE BETWEEN(m.lnAn * 12 + m.lnLuna, 2016*12+1, 2016 * 12 + 12) lnProcTva = 20 CASE BETWEEN(m.lnAn * 12 + m.lnLuna, 2017*12+1, 2025 * 12 + 7) lnProcTva = 19 ENDCASE RETURN m.lnProcTva ENDFUNC *********************************************************************** *!* INTOARCE COEFICIENTUL DE TVA STANDARD IN FUNCTIE DE LUNA 1.24 *!* 07/2010 S-A MODIFICAT TVA 24% FUNCTION GetCoeficientTvaStandard LOCAL lnAn, lnLuna, lnProcTva lnAn = m.gnAn lnLuna = m.gnLuna lnProcTva = 1.21 DO CASE CASE m.lnAn * 12 + m.lnLuna >= 2025 * 12 + 8 lnProcTva = 1.21 CASE BETWEEN(m.lnAn * 12 + m.lnLuna, 2007*12+1, 2010 * 12 + 7) lnProcTva = 1.19 CASE BETWEEN(m.lnAn * 12 + m.lnLuna, 2010*12+8, 2015 * 12 + 12) lnProcTva = 1.24 CASE BETWEEN(m.lnAn * 12 + m.lnLuna, 2016*12+1, 2016 * 12 + 12) lnProcTva = 1.20 CASE BETWEEN(m.lnAn * 12 + m.lnLuna, 2017*12+1, 2025 * 12 + 7) lnProcTva = 1.19 ENDCASE RETURN m.lnProcTva ENDFUNC *********************************************************************************** *** Primeste un procent TVA si intoarce IdJTVA standard *********************************************************************************** FUNCTION ProcentTva2IdJtva LPARAMETERS tnProcentTVA, tcTipJ, tlTaxareInversa, tnTvaIncasare * tnProcentTVA : procent TVA 0/5/9/19/11/21 * tlTaxareInvesa : .T. daca este taxare inversa * tnTvaIncasare : 1 daca este TVA incasare * tcTipJ : Tip Jurnal JV/JC Local lcTipJ, lnIdJtva, lnIdJtvaNeex lnIdJtva = 0 lcTipJ = IIF(INLIST(UPPER(m.tcTipJ), 'JV', 'JC'), UPPER(m.tcTipJ), 'JV') DO CASE CASE m.tnProcentTVA = 21 AND tcTipJ = 'JV' lnIdJtva = IIF(!m.tlTaxareInversa, 35, 5) CASE m.tnProcentTVA = 11 AND tcTipJ = 'JV' lnIdJtva = IIF(!m.tlTaxareInversa, 39, 5) CASE m.tnProcentTVA = 19 AND tcTipJ = 'JV' lnIdJtva = IIF(!m.tlTaxareInversa, 1, 5) CASE m.tnProcentTVA = 9 AND tcTipJ = 'JV' lnIdJtva = IIF(!m.tlTaxareInversa, 3, 5) CASE m.tnProcentTVA = 5 AND tcTipJ = 'JV' lnIdJtva = IIF(!m.tlTaxareInversa, 13, 5) CASE m.tnProcentTVA = 0 AND tcTipJ = 'JV' lnIdJtva = IIF(!m.tlTaxareInversa, 8, 5) && ALTE LIVR. SCUTITE CU DREPT DE DEDUCERE CASE m.tnProcentTVA = 21 AND tcTipJ = 'JC' lnIdJtva = IIF(!m.tlTaxareInversa, 208, 216) CASE m.tnProcentTVA = 11 AND tcTipJ = 'JC' lnIdJtva = IIF(!m.tlTaxareInversa, 212, 218) CASE m.tnProcentTVA = 19 AND tcTipJ = 'JC' lnIdJtva = IIF(!m.tlTaxareInversa, 105, 141) CASE m.tnProcentTVA = 9 AND tcTipJ = 'JC' lnIdJtva = IIF(!m.tlTaxareInversa, 111, 145) CASE m.tnProcentTVA = 5 AND tcTipJ = 'JC' lnIdJtva = IIF(!m.tlTaxareInversa, 154, 154) CASE m.tnProcentTVA = 0 AND tcTipJ = 'JC' lnIdJtva = IIF(!m.tlTaxareInversa, 113, 216) && ACH. INT. SCUTITE/NEIMPOZABILE ENDCASE IF m.tnTvaIncasare = 1 AND !EMPTY(m.lnIdJtva) lnIdJtvaNeex = getIdJtvaColoana(m.lnIdJtva, m.tnTvaIncasare) If m.lnIdJtvaNeex <> 0 lnIdJtva = m.lnIdJtvaNeex Endif ENDIF RETURN m.lnIdJtva ENDFUNC *********************************************************************************** *** Apeleaza getIdJtvaColoana si intoarce un obiect din vjtva_coloane *********************************************************************************** Function GeJtvaColoana Lparameters tnIdJtva, tnTvaIncasare, tcTipJ Local loRec getIdJtvaColoana(tnIdJtva, tnTvaIncasare, tcTipJ, @loRec) Return loRec Endfunc *********************************************************************************** *** baza. id_jtva_coloana exigibil/neexigibil corespunzator id_jtva_coloana selectat *********************************************************************************** Function getIdJtvaColoana Lparameters tnIdJtva, tnTvaIncasare, tcTipJ, toRec *** tnTVAIncasare = 0 > tnIdJtva este neexigibil *** tcTipJ: JC, JV (default) *** toRec (OUT) obiect din vjtva_coloane corespunzator IdJtva Local lnIdJtva, lcAlias, lcCursor, llCursorJTvaColoane, lcTipJ If !Empty(m.tcTipJ) lcTipJ = Upper(m.tcTipJ) Else lcTipJ = [JV] Endif llCursorJTvaColoane = .T. lcAlias = Select() lcCursor = [crsjtvacoltemp] lnIdJtva = tnIdJtva If !Used('jtva_coloane') llCursorJTvaColoane = .F. update_jtva_coloane(m.lcTipJ) Endif *copiaza_structura_cursor([jtva_coloane],lcCursor) Select * From jtva_coloane Into Cursor (lcCursor) Select (lcCursor) Scatter Name toRec Blank Memo Locate For id_jtva_coloana = tnIdJtva If Found() If !Empty(tnTvaIncasare) lnIdJtva = Nvl(id_jtva_neex, id_jtva_coloana) Else lnIdJtva = Nvl(id_jtva_ex, id_jtva_coloana) Endif Locate For id_jtva_coloana = m.lnIdJtva If Found() Scatter Name toRec Memo Endif Endif Use In (Select(lcCursor)) If !llCursorJTvaColoane Use In jtva_coloane Endif Select (lcAlias) Return lnIdJtva Endfunc *********************************************************************************** *** Apeleaza getIdTva si intoarce un obiect din vjtva_coloane *********************************************************************************** Function GeTvaColoana Lparameters tnIdJtva, tnTvaIncasare, tcTipJ Local loRec getIdTva(tnIdJtva, tnTvaIncasare, tcTipJ, @loRec) Return loRec Endfunc *********************************************************************************** *** tva.id_tva exigibil/neexigibil corespunzator id_tva selectat *********************************************************************************** Function getIdTva Lparameters tnIdTva, tnTvaIncasare, tcTipJ, toRec *** tnTVAIncasare = 0 > tnIdTva este neexigibil *** tcTipJ: JC, JV *** toRec (OUT) obiect din vjtva_coloane corespunzator IdJtva Local lnIdTva, lnIdJTvaColoana, lcAlias, lcCursor, llCursorJTvaColoane, lcTipJ If !Empty(m.tcTipJ) lcTipJ = Upper(m.tcTipJ) Else lcTipJ = [JV] Endif llCursorJTvaColoane = .T. lcAlias = Select() lcCursor = [crsjtvacoltemp] lnIdTva = tnIdTva If !Used('jtva_coloane') llCursorJTvaColoane = .F. update_jtva_coloane(m.lcTipJ) Endif *copiaza_structura_cursor([jtva_coloane],lcCursor) Select * From jtva_coloane Into Cursor (lcCursor) Select (lcCursor) Scatter Name toRec Blank Memo Locate For id_tva = tnIdTva If Found() If !Empty(tnTvaIncasare) lnIdJTvaColoana = Nvl(id_jtva_neex, id_jtva_coloana) Else lnIdJTvaColoana = Nvl(id_jtva_ex, id_jtva_coloana) Endif Locate For id_jtva_coloana = lnIdJTvaColoana If Found() lnIdTva = Nvl(id_tva, id_jtva_coloana) Locate For id_jtva_coloana = m.lnIdTva If Found() Scatter Name toRec Memo Endif Endif Endif Use In (Select(lcCursor)) If !llCursorJTvaColoane Use In jtva_coloane Endif Select (lcAlias) Return lnIdTva Endfunc ************************************ *** creeaza cursorul cIsJTVACE la prima apelare a functiei si intoarce .T. daca tnIdJTVA este achizitie CE ************************************ Function IsJCJtvaCE Lparameters tnIdJtva Local llSucces, llReturn, lcSelect llReturn = .F. lcSelect = Select() If !Used('cIsJTVACE') llSucces = goExecutor.oExecuta([SELECT id_jtva_coloana as id_jtva FROM jtva_coloane WHERE denumire like 'TVA%' and denumire like '%CE%'], 'cIsJTVACE') Endif If Used('cIsJTVACE') Select cIsJTVACE Locate For id_jtva = m.tnIdJtva llReturn = Found() Endif Select (m.lcSelect) Return m.llReturn Endfunc *********************** *** Intoarce jtva_coloane.taxcode aferent unui id_jtva_coloana, Partener FUNCTION GetTaxCodeIdPart LPARAMETERS tnAn, tnLuna, tdDataAct, tnIdJTVA, tnIdPart, tlN50, tlN100, tlNeexigibil * tnAn = anul curent * tnLuna = luna curenta * tdDataAct = data documentului, pentru facturi de regularizare inregistrate cu data din alta luna decat luna curenta * tnIdJTVA = explicatia TVA * tnIdPart = id partener pentru verificare furnizor TVA Incasare * tlN50 = operatia are limitare deducere 50% (Taxa SAFT tip: Achizitie deductibil 50%) * tlN100 = operatia are limitare deducere 100% (Taxa SAFT tip: Achizitie nedeductibil) * tlNeexigibil = factura nesosita/neintocmita 408/418 * tlN50, tlN100 nu se mai folosesc * baza facturii cu limitare deducere are codul ach. deductibile 100%, * iar linia 6xx = 4426 limitare deducere are codul "ach. nedeductibile 50% cota TVA 19/9/5%" * in loc de baza facturii "ach. nedeductibile 50%" Local loPartenerRTVAI As "empty" Local loPartenerRTVAIX As "empty" Local lcCodFiscal, lcNumePart, lcSelect, ldDataAct, llFurnizorRTVAI, llJC, llRegularizare Local llUsedJtvaColoane, lnIdPart, lnTaxCode lcSelect = SELECT() lnTaxCode = CAST(null as N(6)) IF !(TYPE('gl406') = 'L' AND m.gl406) RETURN m.lnTaxCode ENDIF lnIdPart = NVL(m.tnIdPart,0) llFurnizorRTVAI = .F. ldDataAct = IIF(!EMPTY(m.tdDataAct), m.tdDataAct, DATE(m.tnAn, m.tnLuna, 1)) llRegularizare = YEAR(m.ldDataAct) * 12 + MONTH(m.ldDataAct) < m.tnAn*12+m.tnLuna llUsedJtvaColoane = Used('jtva_coloane') If !m.llUsedJtvaColoane update_jtva_coloane() ENDIF llJC = .F. IF SEEK(m.tnIdJTVA,'jtva_coloane','id_jtva') llJC = (jtva_coloane.jc = 1) ENDIF If m.llJC AND !EMPTY(m.lnIdPart) lnIdPart = Nvl(m.tnIdPart,0) lcNumePart = "" lcCodFiscal = GetCodFiscalPartenerById(m.lnIdPart) loPartenerRTVAIX = Createobject("empty") loPartenerRTVAI = Createobject("empty") AddProperty(loPartenerRTVAIX, "cod_fiscal", m.lcCodFiscal) AddProperty(loPartenerRTVAIX, "denumire", m.lcNumePart) AddProperty(loPartenerRTVAIX, "dataact", m.ldDataAct) VERIFICA_RTVAI(loPartenerRTVAIX, @loPartenerRTVAI) llFurnizorRTVAI = loPartenerRTVAI.leinRtvai Endif IF !m.llUsedJtvaColoane USE IN (SELECT('jtva_coloane')) ENDIF lnTaxCode = GetTaxCode(m.tnAn, m.tnLuna, m.tdDataAct, m.tnIdJTVA, m.llFurnizorRTVAI, tlN50, tlN100, tlNeexigibil) SELECT (m.lcSelect) RETURN m.lnTaxCode ENDFUNC && GetTaxCodeIdPart *********************** *** Intoarce jtva_coloane.taxcode aferent unui id_jtva_coloana, furnizor tva incasare FUNCTION GetTaxCode LPARAMETERS tnAn, tnLuna, tdDataAct, tnIdJTVA, tlFurnizorRTVAI, tlN50, tlN100, tlNeexigibil * tnAn = anul curent * tnLuna = luna curenta * tdDataAct = data documentului, pentru facturi de regularizare inregistrate cu data din alta luna decat luna curenta * tnIdJTVA = explicatia TVA * tlFurnizoriRTVAI = furnizor TVA Incasare * tlN50 = inregistrarea corespunde explicatiei TVA Limitare deducere 50% (Taxa SAFT tip: Achizitie nedeductibil 50%) * tlN100 = inregistrarea corespunde explicatiei TVA Limitare deducere 100% (Taxa SAFT tip: Achizitie nedeductibil) * tlNeexigibil = factura nesosita/neintocmita 408/418 * tlN50, tlN100 se folosesc doar pentru nota contabila cu explicatie TVA Limitare deducere TVA, in pereche cu Explicatie TVA Ach. 19/9/5%, astfel incat sa intoarca codul Ach neded. 50%/100% 19/9/5% * baza facturii cu limitare deducere are codul ach. deductibile 100%, * iar linia 6xx = 4426 limitare deducere are codul "ach. nedeductibile 50% cota TVA 19/9/5%" * tlN50, tlN100 sunt .T. doar pentru linia 6xx = 4426 limitare deducere TVA LOCAL lcSelect, llJtvaColoane, loTVA Local llFurnizorRTVAI, llRegularizare, llUsedJtvaColoane, lnTaxCode, ldDataAct lcSelect = SELECT() lnTaxCode = CAST(null as N(6)) IF !(TYPE('gl406') = 'L' AND m.gl406) RETURN m.lnTaxCode ENDIF llFurnizorRTVAI = m.tlFurnizorRTVAI ldDataAct = IIF(!EMPTY(m.tdDataAct), m.tdDataAct, DATE(m.tnAn, m.tnLuna, 1)) llRegularizare = YEAR(m.ldDataAct) * 12 + MONTH(m.ldDataAct) < m.tnAn*12+m.tnLuna llUsedJtvaColoane = USED("jtva_coloane_taxcode") * Generez jtva_coloane_taxcode la prima utilizare si il las deschis If !m.llUsedJtvaColoane update_jtva_coloane("", "jtva_coloane_taxcode", 6) ENDIF IF SEEK(m.tnIdJTVA, "jtva_coloane_taxcode", "id_jtva") SELECT jtva_coloane_taxcode SCATTER NAME loTVA WITH loTVA * codul taxa regularizare are prioritate fata de ach. furnizor tva incasare lnTaxCode = .taxcode DO CASE CASE m.tlNeexigibil AND !EMPTY(NVL(.taxcode_neexigibil,0)) lnTaxCode = .taxcode_neexigibil CASE m.tlN50 AND m.llFurnizorRTVAI AND !EMPTY(NVL(.taxcode_n50_tvai,0)) lnTaxCode = .taxcode_n50_tvai CASE m.tlN50 lnTaxCode = .taxcode_n50 CASE m.tlN100 AND m.llFurnizorRTVAI AND !EMPTY(NVL(.taxcode_n100,0)) lnTaxCode = .taxcode_n100 CASE m.tlN100 lnTaxCode = .taxcode_n100 CASE m.llRegularizare AND !EMPTY(NVL(.taxcode_regularizare,0)) lnTaxCode = .taxcode_regularizare CASE m.llFurnizorRTVAI AND !EMPTY(NVL(.taxcode_tvai,0)) lnTaxCode = .taxcode_tvai ENDCASE ENDWITH ENDIF SELECT (m.lcSelect) RETURN m.lnTaxCode ENDFUNC && GetTaxCode *********************** *** Intoarce cod mecanism plata SAFT aferent unui fel document FUNCTION GetPaymentCode LPARAMETERS tnIdFdoc LOCAL lcSelect, lnIdFdoc Local llUsedFdoc, lnPaymentCode lcSelect = SELECT() lnPaymentCode = NULL lnIdFdoc = NVL(m.tnIdFdoc,0) llUsedFdoc = Used('crsFdoc') If !m.llUsedFdoc update_fdoc() ENDIF select paymentcode FROM crsFdoc WHERE id_fdoc = m.lnIdFdoc INTO CURSOR crsFdocTemp SELECT crsFdocTemp GO TOP lnPaymentCode = ALLTRIM(NVL(paymentcode,'')) IF !m.llUsedFdoc USE IN (SELECT('crsFdoc')) ENDIF USE IN (SELECT('crsFdocTemp')) SELECT (m.lcSelect) RETURN m.lnPaymentCode ENDFUNC && GetPaymentCode ******************************************************************************** *** concateneaza valorile dintr-o coloana de pe mai multe randuri *** tcAlias = cursorul din care se face concatenarea *** tcAggColumn = coloana care se concateneaza *** tlDontIgnoreEmptyValues Default .F., .T = concateneaza si valorile empty(tcAggColumn) *** tcSeparator = separatorul valorilor concatenate. Default = [,] *** tcFilterColumn1..tcFilterColumn20 = coloana pentru filtrare/grupare *** tcFilterValue1..tcFilterValue20 = valoarea coloanei pentru filtrare/grupare *** intoare un sir de caractere *** ex: *!* CREATE CURSOR crsInfo (nract I, dataact D, info c(10), suma n(16,2)) *!* INSERT INTO crsInfo(nract, dataact, info, suma) values(1, DATE(), 'a',1.00) *!* INSERT INTO crsInfo(nract, dataact, info, suma) values(1, DATE(), 'b',1.00) *!* INSERT INTO crsInfo(nract, dataact, info, suma) values(1, DATE(), 'c',1.00) *!* INSERT INTO crsInfo(nract, dataact, info, suma) values(2, DATE(), 'd',1.00) *!* INSERT INTO crsInfo(nract, dataact, info, suma) values(2, DATE(), 'e',1.00) *!* INSERT INTO crsInfo(nract, dataact, info, suma) values(2, DATE(), 'f',1.00) *!* INSERT INTO crsInfo(nract, dataact, info, suma) values(2, DATE(), 'g',1.00) *!* INSERT INTO crsInfo(nract, dataact, info, suma) values(3, DATE(), 'a',1.00) *!* INSERT INTO crsInfo(nract, dataact, info, suma) values(3, DATE()-1, 'x',1.00) *!* SELECT nract, dataact, SUM(suma) as suma, ; *!* StringAgg('crsInfo', 'info', .F., [ ], [nract], nract, [dataact], dataact) as infoagg ; *!* FROM crsinfo ; *!* group by nract, dataact ; *!* INTO CURSOR crsRezultat ******************************************************************************** Function StringAgg Lparameters tcAlias, tcAggColumn, tlDontIgnoreEmptyValues, tcSeparator, ; tcFilterColumn1, tcFilterValue1, tcFilterColumn2, tcFilterValue2, tcFilterColumn3, tcFilterValue3, tcFilterColumn4, tcFilterValue4, ; tcFilterColumn5, tcFilterValue5, tcFilterColumn6, tcFilterValue6, tcFilterColumn7, tcFilterValue7, tcFilterColumn8, tcFilterValue8, ; tcFilterColumn9, tcFilterValue9, tcFilterColumn10, tcFilterValue10, tcFilterColumn11, tcFilterValue11, tcFilterColumn12, tcFilterValue12, ; tcFilterColumn13, tcFilterValue13, tcFilterColumn14, tcFilterValue14, tcFilterColumn15, tcFilterValue15, tcFilterColumn16, tcFilterValue16, ; tcFilterColumn17, tcFilterValue17, tcFilterColumn18, tcFilterValue18, tcFilterColumn19, tcFilterValue19, tcFilterColumn20, tcFilterValue20 Local lcCursor, lcRezultat, lcSelect, lcSql, lcSeparator, loEx As Exception Local lcFilter, lcFilterColumn, lcFilterColumnEval, lcFilterValue, i lcRezultat = "" lcSeparator = Iif(Type('tcSeparator') = 'C', tcSeparator, [,]) lcSelect = Select() lcCursor = Sys(2015) lcFilter = "" For i = 1 To 20 lcFilterColumn = 'tcFilterColumn' + Alltrim(Str(i)) && tcFilterColumn1 If Type(lcFilterColumn) <> 'C' Exit Endif lcFilterColumnEval = Evaluate(m.lcFilterColumn) && [nract] lcFilterValue = 'tcFilterValue' + Alltrim(Str(i)) && tcFilterValue1 lcFilter = lcFilter + Iif(Type(m.lcFilterColumn) = 'C' And !Empty(lcFilterColumnEval), m.lcFilterColumnEval + [ = ] + lcFilterValue, "") + [ and ] Endfor If !Empty(m.lcFilter) lcFilter = Left(m.lcFilter, Len(m.lcFilter) - 5) Endif lcFilter = Iif(!tlDontIgnoreEmptyValues, [!EMPTY(] + m.tcAggColumn + [)], []) + Iif(!Empty(m.lcFilter), [ and ], []) + m.lcFilter lcSql = [SELECT distinct ] + tcAggColumn + [ as aggcolumn] + ; [ FROM ] + m.tcAlias + ; Iif(!Empty(m.lcFilter), [ WHERE ] + m.lcFilter, []) + ; [ INTO CURSOR ] + m.lcCursor &lcSql Select (m.lcCursor) Scan lcRezultat = m.lcRezultat + Alltrim(Transform(aggcolumn)) + lcSeparator Endscan Use In (Select(m.lcCursor)) If !Empty(m.lcRezultat) lcRezultat = Left(m.lcRezultat, Len(m.lcRezultat) - Len(m.lcSeparator)) Endif Select (m.lcSelect) Return m.lcRezultat Endfunc && StringAgg Function GetReportFooter Lparameters tnPageTotal Local lcReportFooter, llRaportDataOra, lcDataOra llRaportDataOra = Iif(Type('glRaportDataOra') = 'L', m.glRaportDataOra, .T.) lcDataOra = Iif(Type('pcDataOra') = 'U', Get_Ora(2), m.pcDataOra) lcReportFooter = m.gcCopyRight + " - Pagina " + Allt(Str(_Pageno)) + "/" + Allt(Str(m.tnPageTotal)) + Iif(m.llRaportDataOra, " " + m.lcDataOra, "") Return m.lcReportFooter Endfunc ********************************************************************************************************* Procedure creeaza_backup_cursoare Lparameters tcOriginal Local lcBackup lcBackup = [bckp] + tcOriginal sterge_backup_cursoare(tcOriginal) copiaza_structura_cursor(tcOriginal, lcBackup) Select * From (tcOriginal) Into Cursor (lcBackup) Release lcBackup Endproc && creeaza_backup_cursoare ********************************************************************************************************* Procedure repune_backup_cursoare Lparameters tcOriginal Local lcBackup lcBackup = [bckp] + tcOriginal If Used(lcBackup) Select (tcOriginal) lnRecno = Recno() Select * From (lcBackup) Into Cursor (tcOriginal) Readwrite Use In (lcBackup) Select (tcOriginal) If Reccount(tcOriginal) > 0 Go Min(lnRecno, Reccount(tcOriginal)) Else Go Top Endif Endif Release lcBackup Endproc && repune_backup_cursoare ********************************************************************************************************* Procedure sterge_backup_cursoare Lparameters tcOriginal Local lcBackup lcBackup = [bckp] + tcOriginal If Used(lcBackup) Use In (lcBackup) Endif Release lcBackup Endproc && sterge_backup_cursoare ********************************************************************************************************* Define Class oCursoareProcedura As Custom cNumeProcedura = [] Dimension aCursoareDeschiseI(1, 1) Dimension aExceptiiCursoare(1) Procedure Init Lparameters tcNumeProcedura This.cNumeProcedura = tcNumeProcedura Aused(This.aCursoareDeschiseI) Endproc Function getNumeProcedura Return This.cNumeProcedura Endfunc Procedure setListaExceptii Lparameters tcListaExceptii Local Array laTemp(1) lista2array(Upper(tcListaExceptii), @laTemp, [,]) Acopy(laTemp, This.aExceptiiCursoare) Endproc Procedure inchideCursoare Local Array laCursoareDeschiseF[1, 1] Local lnIndex *!* cursoarele de la inceput *!* CREATE CURSOR crs(nume c(200),nr n(10)) *!* SELECT crs *!* APPEND FROM array This.aCursoareDeschiseI *!* BROWSE *!* cursoarele de la final *!* CREATE CURSOR crs2(nume c(200),nr n(10)) *!* SELECT crs2 *!* Aused(laCursoareDeschiseF) *!* APPEND FROM array laCursoareDeschiseF *!* BROWSE For lnIndex = 1 To Aused(laCursoareDeschiseF) If Ascan(This.aCursoareDeschiseI, laCursoareDeschiseF[lnIndex, 1]) = 0 And ; Ascan(This.aExceptiiCursoare, laCursoareDeschiseF[lnIndex, 1]) = 0 Use In (laCursoareDeschiseF[lnIndex, 1]) Endif Endfor *!* exceptii *!* CREATE CURSOR crs3(nume c(200),nr n(10)) *!* SELECT crs3 *!* APPEND FROM array This.aExceptiiCursoare *!* BROWSE *!* cursoare ramase *!* CREATE CURSOR crs4(nume c(200),nr n(10)) *!* SELECT crs4 *!* Aused(laCursoareDeschiseF) *!* APPEND FROM array laCursoareDeschiseF *!* BROWSE Endproc Enddefine ********************************************************************************************************* Define Class oLogCursoare As Custom && cursor in care tin numele tuturor cursoarelor deschise oDetaliiProc = Null lGlobal = .F. Procedure Init Lparameters tlGlobal This.oDetaliiProc = Createobject("collection") This.lGlobal = tlGlobal If !This.lGlobal This.salveaza(Program(Program(-1) - 1)) Endif Endproc Procedure seteazaExceptii Lparameters tcListaExceptii *!* lista exceptii contine numele cursoarelor care nu se inchid la iesirea din procedura Local lnIndex lnIndex = This.cautaIndex(Iif(This.lGlobal, Program(Program(-1) - 1), "")) This.oDetaliiProc.Item[lnIndex].setListaExceptii(tcListaExceptii) Endproc Function cautaIndex Lparameters tcNumeProcedura Local lnIndexCautat, lnIndex If !Empty(tcNumeProcedura) && sau If This.lGlobal For lnIndex = 1 To This.oDetaliiProc.Count If This.oDetaliiProc.Item[lnIndex].getNumeProcedura() == tcNumeProcedura lnIndexCautat = lnIndex Exit Endif Endfor Else lnIndexCautat = 1 Endif Return lnIndexCautat Endfunc Procedure salveaza *!* daca obiectul de tip oLogCursoare a fost definit global, atunci se apeleaza fara parametru, *!* la inceputul fiecarei proceduri pentru care se doreste sa se tina istoricul cursoarelor deschise Lparameters tcNumeProcedura This.oDetaliiProc.Add(Createobject("oCursoareProcedura", Evl(tcNumeProcedura, Program(Program(-1) - 1)))) Endproc Procedure inchideCursor Lparameters tcNumeCursor If Used(tcNumeCursor) Use In (tcNumeCursor) Endif Endproc Procedure inchideCursoare *!* daca obiectul de tip oLogCursoare a fost definit global, atunci se apeleaza *!* inainte de fiecare RETURN din procedura respectiva Local lcSelect, lnIndex lcSelect = Select() lnIndex = This.cautaIndex(Iif(This.lGlobal, Program(Program(-1) - 1), "")) With This.oDetaliiProc .Item[lnIndex].inchideCursoare() .Remove(lnIndex) Endwith If Used(lcSelect) Select (lcSelect) Endif Endproc Procedure Destroy If !This.lGlobal This.inchideCursoare() Endif Endproc Enddefine ********************************************************************************************************* ******************************************* *** Completare analitice pe baza de grupuri in Gestiune.NIR.inainte_de_do_termin, Contabilitate.actbaza2007.adunadate ******************************************* Procedure completare_gruputil_analitice *!* completez analiticele lipsa din tabelul config_gruputil_analitice lnSucces = Update_GrupUtilAnalitice() && in updateserver.prg If lnSucces > 0 Select crsGrupUtilAnalitice Scan Scatter Name loRec Memo Update actactan Set ascd = loRec.acont Where Empty(Nvl(ascd, '')) And Upper(Alltrim(scd)) = Upper(Alltrim(loRec.Cont)) Update actactan Set ascc = loRec.acont Where Empty(Nvl(ascc, '')) And Upper(Alltrim(scc)) = Upper(Alltrim(loRec.Cont)) Endscan Use In (Select('crsGrupUtilAnalitice')) Endif Endproc && completare_gruputil_analitice ******************************************* *** Completare analitice pe baza de explicatii tva in Gestiune.NIR.inainte_de_do_termin, Contabilitate.actbaza2007.adunadate, ROAFACTURARE, ROACOMENZI, ROACONTRACTE pack_facturare *** bun pentru analitice pe baza de cote TVA la 4426, 4428 (vezi AUTOHAUS, ABCVAL) ******************************************* Procedure completare_tva_analitice lnSucces = Update_TVAAnalitice() && in updateserver.prg If lnSucces > 0 Select crsTVAAnalitice Scan Scatter Name loRec Memo Update actactan Set ascd = loRec.acont Where Empty(Nvl(ascd, '')) And Upper(Alltrim(scd)) = Upper(Alltrim(loRec.Cont)) And id_jtva_coloana = loRec.id_jtva_coloana Update actactan Set ascc = loRec.acont Where Empty(Nvl(ascc, '')) And Upper(Alltrim(scc)) = Upper(Alltrim(loRec.Cont)) And id_jtva_coloana = loRec.id_jtva_coloana Endscan Use In (Select('crsTVAAnalitice')) Endif Endproc && completare_tva_analitice *** Completare taxname in actactan (frm_introd_compact.la_iesire) PROCEDURE completare_taxname LOCAL lcSelect lcSelect = SELECT() IF USED('saft_taxtable') UPDATE actactan SET taxname = Iif(Seek(actactan.taxcode,'saft_taxtable','taxcode'),saft_taxtable.taxname,'') ENDIF SELECT (m.lcSelect) ENDPROC && completare_taxname *** Completare paymentname in actactan (frm_introd_compact.la_iesire) PROCEDURE completare_paymentname LOCAL lcSelect lcSelect = SELECT() IF USED('saft_mecanisme_plati') UPDATE actactan SET paymentname = Iif(Seek(actactan.paymentcode,'saft_mecanisme_plati','mcode'),saft_mecanisme_plati.paymentname,'') ENDIF SELECT (m.lcSelect) ENDPROC && completare_taxname *** Completare explicatie_tva in actactan (frm_introd_compact.la_iesire) PROCEDURE completare_explicatie_tva LOCAL lcSelect, lcCursor lcSelect = SELECT() lcCursor = SYS(2015) IF !USED(m.lcCursor) update_jtva_coloane("", m.lcCursor,6) ENDIF IF USED(m.lcCursor) UPDATE actactan SET explicatie_tva = Iif(Seek(actactan.id_jtva_coloana, m.lcCursor,'id_jtva'), &lcCursor..denumire,'') ENDIF USE IN (SELECT(m.lcCursor)) SELECT (m.lcSelect) ENDPROC && completare_explicatie_tva ************************************** *** Cauta partenerul dupa cod fiscal si intoarce un obiect sau NULL ************************************** Procedure GetPartenerByCodFiscal Lparameters tcCodFiscal Private pcCodFiscal Local lcSql, lnSucces, lcSelect, loPartener lcSelect = SELECT() loPartener = NULL pcCodFiscal = Alltrim(Strtran(Strtran(Upper(Alltrim(m.tcCodFiscal)), ' ', ''), 'RO', '')) lcSql = [SELECT * from vnom_parteneri where id_part = (select MAX(id_part) as id_part from nom_parteneri where replace(replace(UPPER(cod_fiscal),' ', ''), 'RO', '') = ?pcCodFiscal and sters = 0 and inactiv = 0)] llSucces = goExecutor.oExecuta(m.lcSql, "cPartenerTemp") If m.llSucces SELECT cPartenerTemp SCATTER NAME loPartener ENDIF USE IN (SELECT('cPartenerTemp')) SELECT (m.lcSelect) Return loPartener Endproc ************************************** *** Cauta partenerul dupa denumire si intoarce un obiect sau NULL ************************************** Procedure GetPartenerByDenumire Lparameters tcDenumire Private pcDenumire Local lcSql, lnSucces, lcSelect, loPartener lcSelect = SELECT() loPartener = NULL pcDenumire = Alltrim(Upper(tcDenumire)) lcSql = [SELECT * from vnom_parteneri where id_part = (select MAX(id_part) as id_part from nom_parteneri where TRIM(UPPER(denumire)) = ?pcDenumire and sters = 0 and inactiv = 0)] llSucces = goExecutor.oExecuta(m.lcSql, "cPartenerTemp") If m.llSucces SELECT cPartenerTemp SCATTER NAME loPartener ENDIF USE IN (SELECT('cPartenerTemp')) SELECT (m.lcSelect) Return loPartener Endproc ************************************** *** Cauta partenerul dupa codul IBAN si intoarce un obiect sau NULL ************************************** Procedure GetPartenerByContBanca Lparameters tcContBanca Private pcContBanca Local lcSql, lnSucces, lcSelect, loPartener lcSelect = SELECT() loPartener = NULL pcContBanca = Alltrim(TRANSFORM(m.tcContBanca)) lcSql = [SELECT * from vnom_parteneri where id_part = (select MAX(id_part) as id_part from nom_parteneri where TRIM(UPPER(cont_banca)) = ?pcContBanca and sters = 0 and inactiv = 0)] llSucces = goExecutor.oExecuta(m.lcSql, "cPartenerTemp") If m.llSucces SELECT cPartenerTemp SCATTER NAME loPartener ENDIF USE IN (SELECT('cPartenerTemp')) SELECT (m.lcSelect) Return loPartener ENDPROC ************************************** *** Intoarce Id Partener din nomenclatorul de parteneri dupa codul fiscal ************************************** Procedure GetIdPartenerByCodFiscal Lparameters tcCodFiscal, tcDenumire * tcCodFiscal: IN * tcDenumire: OUT Private pnIdPartener, pcCodFiscal Local lcSql, lnSucces, lcSelect lcSelect = SELECT() pnIdPartener = 0 pcCodFiscal = Alltrim(Strtran(Strtran(Upper(Alltrim(m.tcCodFiscal)), ' ', ''), 'RO', '')) lcSql = [select MAX(id_part) as id_part from nom_parteneri where replace(replace(UPPER(cod_fiscal),' ', ''), 'RO', '') = ?pcCodFiscal and sters = 0 and inactiv = 0] lnSucces = goExecutor.oSelect2Value(m.lcSql, @pnIdPartener) If m.lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 48, _Screen.Caption) ENDIF SELECT (m.lcSelect) Return Nvl(m.pnIdPartener, 0) Endproc ************************************** *** Intoarce Id Partener din nomenclatorul de parteneri dupa denumire ************************************** Procedure GetIdPartenerByDenumire Lparameters tcDenumire Private pnIdPartener, pcDenumire Local lcSql, lnSucces, lcSelect lcSelect = SELECT() pnIdPartener = 0 pcDenumire = Alltrim(Upper(tcDenumire)) lcSql = [select MAX(id_part) as id_part from nom_parteneri where TRIM(UPPER(denumire)) = ?pcDenumire and sters = 0 and inactiv = 0] lnSucces = goExecutor.oSelect2Value(m.lcSql, @pnIdPartener) If m.lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 48, _Screen.Caption) ENDIF SELECT (m.lcSelect) Return Nvl(m.pnIdPartener, 0) Endproc ************************************** *** Intoarce Id Partener din nomenclatorul de parteneri dupa contul bancar ************************************** Procedure GetIdPartenerByContBanca Lparameters tcCont Private pnIdPartener, pcCont Local lcSql, lnSucces pnIdPartener = 0 pcCont = Alltrim(Upper(tcCont)) lcSql = [select MAX(id_part) as id_part from nom_parteneri where TRIM(UPPER(cont_banca)) = ?pcCont and sters = 0 and inactiv = 0] lnSucces = goExecutor.oSelect2Value(m.lcSql, @pnIdPartener) If m.lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 48, _Screen.Caption) Endif Return Nvl(m.pnIdPartener, 0) Endproc ************************************** *** Intoarce denumire parteneri din nomenclatorul de parteneri dupa Id ************************************** Procedure GetDenumirePartenerById Lparameters tnIdPart Private pnIdPartener, pcDenumire Local lcSql, lnSucces, lcSelect lcSelect = SELECT() pnIdPartener = tnIdPart pcDenumire = '' lcSql = [select MAX(denumire) as denumire from nom_parteneri where id_part = ?pnIdPartener] lnSucces = goExecutor.oSelect2Value(m.lcSql, @pcDenumire) If m.lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 48, _Screen.Caption) ENDIF SELECT (m.lcSelect) Return Nvl(m.pcDenumire, '') Endproc ************************************** *** Intoarce cod fiscal parteneri din nomenclatorul de parteneri dupa Id ************************************** Procedure GetCodFiscalPartenerById Lparameters tnIdPart Private pnIdPartener, pcDenumire Local lcSql, lnSucces, lcSelect lcSelect = SELECT() pnIdPartener = tnIdPart pcCodFiscal = '' lcSql = [select MAX(cod_fiscal) as cod_fiscal from nom_parteneri where id_part = ?pnIdPartener] lnSucces = goExecutor.oSelect2Value(m.lcSql, @pcCodFiscal) If m.lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 48, _Screen.Caption) ENDIF SELECT (m.lcSelect) Return Nvl(m.pcCodFiscal, '') Endproc ************************************ *** Intoarce un obiect cu (id_util, id_partener, partener) dupa id_util ************************************ Procedure GetPartenerByUtil Lparameters tnIdUtil Private pnIdUtil Local lcSql, llSucces, loPartener pnIdUtil = m.tnIdUtil loPartener = Createobject("empty") AddProperty(loPartener, "id_util", m.pnIdUtil) AddProperty(loPartener, "id_partener", 0) AddProperty(loPartener, "partener", "") lcSql = [select id_util, id_partener, partener from vutilizatori_rol_intern where id_util = ?pnIdUtil] llSucces = goExecutor.oExecuta(m.lcSql, 'cPartenerByUtilTemp') If m.llSucces Select cPartenerByUtilTemp loPartener.id_partener = Nvl(id_partener, 0) loPartener.partener = Alltrim(Nvl(partener, '')) Use In (Select('cPartenerByUtilTemp')) Endif Return loPartener Endproc ************************************** * Genereaza toate variantele de [nume prenume1 prenume2] * = GetNamePermutations("Popescu Ion Maria", .T.) && exclude varianta originala * = GetNamePermutations("Popescu Ion Maria", .F.) && include toate variantele ************************************** Function GetNamePermutations Lparameters lcFullName, llExcludeOriginal Local lcResult, lnWordCount, i Local Array laWords[1] PRIVATE pnMaxPerms, pnPermCount pnMaxPerms = 10 && numarul maxim de permutari pnPermCount = 0 * Separare cuvinte īn array lnWordCount = Getwordcount(lcFullName) If lnWordCount < 2 Return "" Endif * LIMITARE LA MAXIM 4 CUVINTE 24 PERMUTARI If lnWordCount > 4 lnWordCount = 4 * Reconstruim numele doar cu primele 4 cuvinte lcFullName = Getwordnum(lcFullName, 1) + " " + ; Getwordnum(lcFullName, 2) + " " + ; Getwordnum(lcFullName, 3) + " " + ; Getwordnum(lcFullName, 4) ENDIF Dimension laWords[lnWordCount] For i = 1 To lnWordCount laWords[i] = Getwordnum(lcFullName, i) Endfor * Cazul special pentru 2 cuvinte If lnWordCount = 2 If llExcludeOriginal Return laWords[2] + " " + laWords[1] Endif Return lcFullName + ";" + laWords[2] + " " + laWords[1] Endif * Generam toate permutarile posibile īn lcResult lcResult = "" Local Array laUsed[1], laCurrentPerm[1] Dimension laUsed[lnWordCount], laCurrentPerm[lnWordCount] Store .F. To laUsed pnPermCount = 0 && numarul de permutari * Primul cuvānt poate fi oricare For i = 1 To lnWordCount laUsed[i] = .T. laCurrentPerm[1] = laWords[i] GenerateWordPerms(1, @laWords, @laUsed, @laCurrentPerm, lnWordCount, @lcResult) laUsed[i] = .F. Endfor * Filtram rezultatele Local lcFirstWord, lcLastWord, lcFiltered lcFirstWord = laWords[1] lcLastWord = laWords[lnWordCount] lcFiltered = "" Local lnPos, lcLine lnPos = At(";", lcResult) Do While lnPos > 0 lcLine = Left(lcResult, lnPos - 1) lcResult = Substr(lcResult, lnPos + 1) * Verificam daca primul ?i ultimul cuvānt sunt corecte If (Getwordnum(lcLine, 1) = lcFirstWord Or Getwordnum(lcLine, 1) = lcLastWord) And ; (Getwordnum(lcLine, lnWordCount) = lcFirstWord Or Getwordnum(lcLine, lnWordCount) = lcLastWord) If !llExcludeOriginal Or lcLine != lcFullName lcFiltered = lcFiltered + lcLine + ";" Endif Endif lnPos = At(";", lcResult) Enddo * Verificam ?i ultima linie If !Empty(lcResult) If (Getwordnum(lcResult, 1) = lcFirstWord Or Getwordnum(lcResult, 1) = lcLastWord) And ; (Getwordnum(lcResult, lnWordCount) = lcFirstWord Or Getwordnum(lcResult, lnWordCount) = lcLastWord) If !llExcludeOriginal Or lcResult != lcFullName lcFiltered = lcFiltered + lcResult + ";" Endif Endif Endif * Eliminam ultimul separator daca exista If !Empty(lcFiltered) lcFiltered = Left(lcFiltered, Len(lcFiltered)-1) Endif Return lcFiltered ENDPROC * Procedura recursiva pentru generarea permutarilor Procedure GenerateWordPerms Parameters lnLevel, laWords, laUsed, laCurrentPerm, lnWordCount, lcResult If m.pnPermCount >= m.pnMaxPerms Return ENDIF If lnLevel = lnWordCount pnPermCount = m.pnPermCount + 1 * Am completat toate pozitiile, adaugam permutarea la rezultat Local i, lcPerm lcPerm = laCurrentPerm[1] For i = 2 To lnWordCount lcPerm = lcPerm + " " + laCurrentPerm[i] Endfor lcResult = lcResult + lcPerm + ";" Return Endif * Pentru fiecare cuvānt neutilizat Local i For i = 1 To lnWordCount If !laUsed[i] laUsed[i] = .T. laCurrentPerm[lnLevel + 1] = laWords[i] GenerateWordPerms(lnLevel + 1, @laWords, @laUsed, @laCurrentPerm, lnWordCount, @lcResult) laUsed[i] = .F. Endif Endfor Endproc ************************************** *** Intoarce denumire fdoc din nomenclatorul de documente dupa Id ************************************** Procedure GetFdocById Lparameters tnId Private pnId, pcDenumire Local lcSql, lnSucces pnId = tnId pcDenumire = '' lcSql = [select MAX(fel_document) as fel_document from nom_fdoc where id_fdoc = ?pnId] lnSucces = goExecutor.oSelect2Value(m.lcSql, @pcDenumire) If m.lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 48, _Screen.Caption) Endif Return Nvl(m.pcDenumire, '') Endproc && GetFdocById ************************************ *** Intoarce un obiect cu (id_valuta, nume_val, moneda_nationala) dupa nume_val2/iso_valuta ************************************ Procedure GetValutaByISO Lparameters tcValutaISO Private pcValutaISO Local lcSelect, lcSql, llSucces, loValuta lcSelect = SELECT() pcValutaISO = m.tcValutaISO loValuta = Createobject("empty") AddProperty(loValuta, "id_valuta", 0) AddProperty(loValuta, "nume_val", '') AddProperty(loValuta, "moneda_nationala", 1) lcSql = [select id_valuta, nume_val, moneda_nationala from vnom_valute where nume_val2 = ?pcValutaISO] llSucces = goExecutor.oExecuta(m.lcSql, 'cValutaTemp') If m.llSucces IF RECCOUNT('cValutaTemp') > 0 Select cValutaTemp GO TOP loValuta.id_valuta = Nvl(id_valuta, 0) loValuta.nume_val = Alltrim(Nvl(nume_val, '')) loValuta.moneda_nationala = Nvl(moneda_nationala, 0) ENDIF Use In (Select('cValutaTemp')) ENDIF SELECT (m.lcSelect) Return loValuta ENDPROC ************************************** *** Cauta o factura in ireg_parteneri dupa cont, id_part, nr_act / comanda *** Se foloseste la importul din extrasele bancare, deconturi curieri, procesatori plati *** Intoarce un obiect (id_fact, cont, acont, nract) ************************************** Procedure GetDocumentByContPartenerAct Lparameters tcContPartener, tnIdPartener, tuDocument, tlComanda * loAct id_fact, cont, acont, nract Local lcSql, lcSql1, lcSql2, lcWhere, lcWhere1, lcWhere2, llSucces, loAct, lcSelect Private pnIdPartener, pcContPartener, pnNract, pnIdFact, pcComanda lcSelect = Select() pnIdPartener = tnIdPartener pcContPartener = Alltrim(Upper(tcContPartener)) pnNract = IIF(!m.tlComanda and !EMPTY(m.tuDocument), m.tuDocument, 0) pcComanda = ALLTRIM(UPPER(TRANSFORM(IIF(m.tlComanda and !EMPTY(m.tuDocument), m.tuDocument, '')))) *!* pcComanda = IIF(!EMPTY(m.pcComanda), '%' + m.pcComanda + '%', '') pnIdFact = 0 loAct = Createobject("Empty") AddProperty(loAct, "id_fact", 0) AddProperty(loAct, "cont", "") AddProperty(loAct, "acont", "") AddProperty(loAct, "nract", 0) AddProperty(loAct, "solddeb", 0) * Daca nu am id-ul de partener -- sau nu am nici numarul, nici suma documentului, nu caut nimic If Empty(m.pnIdPartener) && Or (Empty(m.pnNract) And Empty(m.pcComanda)) Return loAct Endif lcWhere2 = "i.an = ?gnAn and i.luna = ?gnLuna and i.id_part = ?pnIdPartener" DO CASE CASE !Empty(m.pnNract) lcWhere2 = m.lcWhere2 + " and (i.nract = ?pnNrAct)" && cautare fara cont, cu numaract CASE !Empty(m.pcComanda) lcWhere2 = m.lcWhere2 + " and (UPPER(l.nrord) like '%"+ m.pcComanda + "%'OR UPPER(i.explicatia) like '%" + m.pcComanda + "%' OR UPPER(i.explicatia4) like '%" + m.pcComanda + "%' OR UPPER(i.explicatia5) like '%" + pcComanda + "%')" && cautare fara cont, cu comanda ENDCASE lcWhere1 = m.lcWhere2 + IIF(!Empty(m.pcContPartener), " and i.cont = ?pcContPartener", "") lcSql = [select i.id_fact, i.cont, i.acont, i.nract, (i.precdeb+i.debit-i.preccred-i.credit) as solddeb from ireg_parteneri i left join nom_lucrari l on i.id_lucrare = l.id_lucrare where ] lcSql1 = m.lcSql + m.lcWhere1 lcSql2 = m.lcSql + m.lcWhere2 llSucces = goExecutor.oExecuta(m.lcSql1, "cRezultatTemp") If m.llSucces If Reccount('cRezultatTemp') = 0 If m.lcWhere2 <> m.lcWhere1 Use In (Select('cRezultatTemp')) llSucces = goExecutor.oExecuta(m.lcSql2, "cRezultatTemp") Endif && m.lcWhere2 <> m.lcWhere1 Endif && RECCOUNT('cRezultatTemp') = 0 Endif && m.llSucces If Used('cRezultatTemp') If Reccount('cRezultatTemp') > 1 polog.Log('Sunt prea multe rezultate care se potrivesc', Program()) Else Select cRezultatTemp Go Top loAct.id_fact = id_fact loAct.Cont = Alltrim(Cont) loAct.acont = Nvl(acont, '') loAct.nract = nract loAct.solddeb = solddeb Endif Endif Use In (Select('cRezultatTemp')) Select (m.lcSelect) Return loAct Endproc && GetDocumentByContPartenerActSuma ************************************** *** Intoarce Id Sectie din nomenclatorul de sectii dupa numele sectiei ************************************** Procedure GetIdSectie Lparameters tcSectie Private pnIdSectie, pcSectie Local lcSql, lnSucces, lcSelect lcSelect = SELECT() pnIdSectie = 0 pcSectie = Upper(Alltrim(Nvl(tcSectie, ''))) lcSql = [select MAX(id_sectie) as id_sectie from vnom_sectii where UPPER(TRIM(sectie)) = ?pcSectie and inactiv = 0] lnSucces = goExecutor.oSelect2Value(m.lcSql, @pnIdSectie) If m.lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 48, _Screen.Caption) ENDIF SELECT (m.lcSelect) Return Nvl(m.pnIdSectie, 0) Endproc ************************************** *** Intoarce obiect(id_sectie, sectie, csectie) din nomenclatorul de sectii dupa indicativ sectie ************************************** Procedure GetSectieByCsectie Lparameters tcCSectie Private pnIdSectie, pcCSectie Local lcSql, lnSucces, lcSelect Local loRec As "empty" Local lcCursor, llSucces lcSelect = SELECT() loRec = CREATEOBJECT("empty") ADDPROPERTY(loRec, 'id_sectie', 0) ADDPROPERTY(loRec, 'sectie', '') ADDPROPERTY(loRec, 'csectie', '') pcCSectie = Upper(Alltrim(Nvl(tcCSectie, ''))) lcSql = [select id_sectie, sectie, csectie from vnom_sectii where UPPER(TRIM(csectie)) = ?pcCSectie and inactiv = 0] lcCursor = SYS(2015) llSucces = goExecutor.oExecuta(m.lcSql, m.lcCursor) If m.llSucces SELECT (m.lcCursor) IF RECCOUNT() >= 1 GO TOP SCATTER NAME loRec ENDIF USE IN (SELECT(m.lcCursor)) ENDIF SELECT (m.lcSelect) Return loRec Endproc ************************************** *** Intoarce obiect(id_sectie, sectie, csectie) din nomenclatorul de sectii dupa id sectie ************************************** Procedure GetSectieById Parameters tnIdSectie Local loRec As "empty" Local lcSelect, llSucces lcSelect = SELECT() loRec = CREATEOBJECT("empty") ADDPROPERTY(loRec, 'id_sectie', 0) ADDPROPERTY(loRec, 'sectie', '') ADDPROPERTY(loRec, 'csectie', '') llSucces = goExecutor.oSelecteaza2Object("select id_sectie, sectie, csectie from vnom_sectii where id_sectie = ?tnIdSectie", @loRec) SELECT (m.lcSelect) Return loRec ENDPROC ************************************** *** Intoarce obiect din nomenclatorul de gestiuni dupa id gestiune ************************************** Procedure GetGestiuneById Parameters tnIdGestiune Local loRec As "empty" Local lcSelect, lcSql, llSucces lcSelect = SELECT() loRec = CREATEOBJECT("empty") ADDPROPERTY(loRec, 'id_gestiune', 0) ADDPROPERTY(loRec, 'nume_gestiune', '') ADDPROPERTY(loRec, 'cgest', '') TEXT TO lcSql noshow select id_gestiune, nume_gestiune, inactiv, cont, acont, nr_pag, cgest, id_sucursala, descriere, nume_tip, sucursala, id_responsabil, denumire, id_sectie, sectie, acont_adaos, acont_cheltuiala, id_lucrare, nrord, gestionar, comisie_receptie1, comisie_receptie2, comisie_receptie3 from vnom_gestiuni where id_gestiune = ?tnIdGestiune ENDTEXT llSucces = goExecutor.oSelecteaza2Object(m.lcSql, @loRec) SELECT (m.lcSelect) Return loRec ENDPROC ************************************** *** Intoarce Id Lucrare din nomenclatorul de lucrari dupa numele lucrarii ************************************** Procedure GetIdLucrare Lparameters tcLucrare Private pnIdLucrare, pcLucrare Local lcSql, lnSucces, lcSelect lcSelect = SELECT() pnIdLucrare = 0 pcLucrare = Upper(Alltrim(Nvl(tcLucrare, ''))) lcSql = [select MAX(id_lucrare) as id_lucrare from vnom_lucrari where UPPER(TRIM(nrord)) = ?pcLucrare and inactiv = 0] lnSucces = goExecutor.oSelect2Value(m.lcSql, @pnIdLucrare) If m.lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 48, _Screen.Caption) ENDIF SELECT (m.lcSelect) Return Nvl(m.pnIdLucrare, 0) Endproc ************************************** *** Intoarce Id Venchelt din nomenclatorul de venchelt dupa numele venchelt ************************************** Procedure GetIdVenchelt Lparameters tcVenchelt Private pnIdVenchelt, pcVenchelt Local lcSql, lnSucces, lcSelect lcSelect = SELECT() pnIdVenchelt = 0 pcVenchelt = Upper(Alltrim(Nvl(tcVenchelt, ''))) lcSql = [select MAX(id_Venchelt) as id_Venchelt from vnom_venchel where UPPER(TRIM(explicatie)) = ?pcVenchelt and inactiv = 0] lnSucces = goExecutor.oSelect2Value(m.lcSql, @pnIdVenchelt) If m.lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 48, _Screen.Caption) ENDIF SELECT (m.lcSelect) Return Nvl(m.pnIdVenchelt, 0) Endproc ************************************** *** Intoarce obiect din nomenclatorul Venit/Cheltuiala dupa id ************************************** Procedure GetVencheltById Parameters tnIdVenChelt Local loRec As "empty" Local lcSelect, llSucces lcSelect = SELECT() loRec = CREATEOBJECT("empty") ADDPROPERTY(loRec, 'id_venchelt', 0) ADDPROPERTY(loRec, 'tip_venchelt', 1) ADDPROPERTY(loRec, 'explicatie', '') ADDPROPERTY(loRec, 'explicatie_fiu', '') ADDPROPERTY(loRec, 'explicatie_tata', '') llSucces = goExecutor.oSelecteaza2Object("select id_venchelt, id_tata, tip_venchelt, explicatie, explicatie_fiu, explicatie_tata, inactiv, id_mod from vnom_venchel where id_venchelt = ?tnIdVenChelt", @loRec) SELECT (m.lcSelect) Return loRec ENDPROC ************************************** *** Intoarce valoarea unei optiuni ************************************** Procedure GetOptiuneFirma Lparameters tcOptiune Local lcReturn Private pcOptiune lcReturn = "" If Empty(m.tcOptiune) Or Type('tcOptiune') <> 'C' Return m.lcReturn Endif pcOptiune = Upper(Alltrim(m.tcOptiune)) lnSucces = goExecutor.oSelect2Value("select pack_sesiune.getoptiunefirma(?pcOptiune) from dual", @lcReturn) If m.lnSucces < 0 amessagebox(goExecutor.cEroare, 0 + 48, _Screen.Caption) Endif Return m.lcReturn Endproc ************************************** *** Intoarce cod bare din nomenclatorul de articole ************************************** Procedure GetCodBareByIdArticol Lparameters tnIdArticol Private pnIdArticol, pcCodBare Local lcSql, lnSucces pcCodBare = '' pnIdArticol = m.tnIdArticol lcSql = [select codbare from nom_articole where id_articol = ?pnIdArticol] llSucces = goExecutor.oSelecteaza2Value(m.lcSql, @pcCodBare) Return NVL(m.pcCodBare, '') Endproc ************************************** *** Intoarce un obiect din vnom_articole/id_articol dupa denumire/codbare/cod client/cod furnizor *** lnIdArticol = GetArticolByCodDenumire("articol", "cod bare", "cod furnizor", "cod client", IdPart, .T.) *** loArticol = GetArticolByCodDenumire("articol", "cod bare", "cod furnizor", "cod client", IdPart, .F.) ************************************** Procedure GetArticolByCodDenumire lParameters tcDenumire, tcCodBare, tcCodMat, tcCodMatF, tcCodMatP, tnIdPart, tlReturnId * tcDenumire: denumire articol * tcCodBare: cod bare articol * tcCodMat: primite = efactura.codClient, trimise = efactura.codFurnizor = nom_articole.codmat * tcCodMatF: primite = efactura.codFurnizor = nom_articole.codmatf * tcCodMatP: trimise = efactura.codClient = parteneri_articole_coduri.cod * tnIdPart: id_part client * tlReturnId: .T. = intoarce id_articol, .F. = intoarce obiect nom_articole Private pcDenumire, pcCodBare, pcCodFurnizor, pcCodCLient, pnIdPart Local lcSql, lnSucces, lcSelect, loArticol, loReturn lcSelect = SELECT() loArticol = null loReturn = Null pcDenumire = UPPER(Alltrim(NVL(m.tcDenumire, ''))) pcCodBare = UPPER(ALLTRIM(NVL(m.tcCodBare, ''))) pcCodMat = UPPER(ALLTRIM(NVL(m.tcCodMat, ''))) pcCodMatF = UPPER(ALLTRIM(NVL(m.tcCodMatF, ''))) pcCodMatP = UPPER(ALLTRIM(NVL(m.tcCodMatP, ''))) pnIdPart = NVL(m.tnIdPart, 0) TEXT TO lcSql TEXTMERGE NOSHOW SELECT * FROM vnom_articole a left join parteneri_articole_coduri c ON (a.id_part = c.id_part and c.id_part = ?pnIdPart and c.sters = 0) where a.inactiv = 0 and rownum = 1 and (<><><><><>) ENDTEXT * Daca nu exista denumire, codbare, codmat, codmatF, codmatP lcSql = STRTRAN(m.lcSql, " and ()", " and (1=2)", 1, 1, 1) lcSql = STRTRAN(m.lcSql, "( or ", "(", 1, 1, 1) llSucces = goExecutor.oSelecteaza2Object(m.lcSql, @loArticol) If m.llSucces IF m.tlReturnId loReturn = loArticol.id_articol ELSE loReturn = loArticol ENDIF ENDIF SELECT (m.lcSelect) Return loReturn ENDPROC && GetArticolByCodDenumire ************************************** *** Intoarce un obiect din vnom_articole dupa id_articol *** loArticol = GetArticolById(lnIdArticol) ************************************** Procedure GetArticolById lParameters tnId * tnId: id_articol lcSelect = SELECT() loArticol = Null pnId = NVL(m.tnId, 0) TEXT TO lcSql TEXTMERGE NOSHOW SELECT * FROM vnom_articole a where id_articol = ?pnId ENDTEXT llSucces = goExecutor.oSelecteaza2Object(m.lcSql, @loArticol) SELECT (m.lcSelect) Return loArticol ENDPROC && GetArticolById ************************************** *** Intoarce un obiect din ANAF_VEFACTURA_DETALII/id_articol dupa cod fiscal furnizor/client si denumire *** Cauta in articolele furnizorului/clientului, ultima aparitie a articolului respectiv *** lnIdArticol = GetArticolEFByPartDenumire("cod fiscal", "articol", .T.) *** loArticol = GetArticolByCodDenumire("articol", "cod bare", "cod furnizor", "cod client", IdPart, .F.) ************************************** Procedure GetArticolEFByPartDenumire lParameters tcCodFiscal, tlPrimite, tcDenumire, tlReturnId, tnIdEfactura * tcCodFiscal : cod fiscal client/furnizor * tlPrimite: facturi primite / emise * tcDenumire: denumire articol * tlReturnId: .T. = intoarce id_articol, .F. = intoarce obiect * tnIdEfactura: id_efactura curenta. sa nu caut articolul in factura curenta, ci in facturile anterioare Private pcDenumire, pcCodBare, pcCodFurnizor, pcCodCLient, pnIdPart, pnIdEfactura Local lcSql, lnSucces, lcSelect, loArticol, loReturn, lcColoanaCodFiscal lcSelect = SELECT() loArticol = null loReturn = Null pcDenumire = UPPER(Alltrim(NVL(m.tcDenumire, ''))) pcCodFiscal = UPPER(ALLTRIM(NVL(m.tcCodFiscal, ''))) pnIdArticol = 0 pnIdEfactura = IIF(!EMPTY(NVL(tnIdEfactura, 0)), m.tnIdEfactura, 0) lcColoanaCodFiscal = IIF(m.tlPrimite, "e.cod_fiscal_emitent", "e.cod_fiscal_beneficiar") TEXT TO lcSql TEXTMERGE NOSHOW SELECT * FROM (SELECT d.* FROM ANAF_VEFACTURA_DETALII d LEFT JOIN ANAF_EFACTURA e ON (e.id = d.id_efactura) WHERE <> = ?pcCodFiscal AND TRIM(UPPER(d.articol)) = ?pcDenumire and id_articol is not null ORDER BY d.id desc) WHERE rownum = 1 ENDTEXT llSucces = goExecutor.oSelecteaza2Object(m.lcSql, @loArticol) If m.llSucces * Daca nu am gasit factura cu articol ROA (este posibil sa fie de servicii, fara articole gestionabile) * Caut articolelele anterioare, fara id_articol IF EMPTY(NVL(loArticol.id_articol,0)) AND !EMPTY(NVL(m.tnIdEfactura,0)) TEXT TO lcSql TEXTMERGE NOSHOW SELECT * FROM (SELECT d.* FROM ANAF_VEFACTURA_DETALII d LEFT JOIN ANAF_EFACTURA e ON (e.id = d.id_efactura) WHERE <> = ?pcCodFiscal AND TRIM(UPPER(d.articol)) = ?pcDenumire and e.id <> ?pnIdEFactura ORDER BY d.id desc) WHERE rownum = 1 ENDTEXT llSucces = goExecutor.oSelecteaza2Object(m.lcSql, @loArticol) ENDIF ENDIF IF m.llSucces IF m.tlReturnId loReturn = loArticol.id_articol ELSE loReturn = loArticol ENDIF ENDIF SELECT (m.lcSelect) Return loReturn ENDPROC && GetArticolEFByPartDenumire ************************************** *** Alege perioada *** intoarce un obiect cu perioada aleasa ************************************** Procedure AlegePerioada Local loFrmPerioada As 'frm_perioada_luni' Local loRet As "empty" Local lcPerioada, lnAn1, lnAn2, lnFinal, lnInit, lnLuna1, lnLuna2 Private pcondper pcondper = '' loFrmPerioada = Createobject('frm_perioada_luni') loFrmPerioada.Show(1) If gnButon = 2 Return Endif If At('_', pcondper) > 0 lnAn1 = Val(Substr(pcondper, 3, 4)) lnLuna1 = Val(Substr(pcondper, 1, 2)) lnAn2 = Val(Substr(pcondper, 10, 4)) lnLuna2 = Val(Substr(pcondper, 8, 2)) lcPerioada = Substr(pcondper, 1, 2) + '/' + Substr(pcondper, 3, 4) + ' - ' + Substr(pcondper, 8, 2) + '/' + Substr(pcondper, 10, 4) Else lnAn1 = Val(Substr(pcondper, 3, 4)) lnLuna1 = Val(Substr(pcondper, 1, 2)) lnAn2 = Val(Substr(pcondper, 3, 4)) lnLuna2 = Val(Substr(pcondper, 1, 2)) lcPerioada = Substr(pcondper, 1, 2) + '/' + Substr(pcondper, 3, 4) + ' - ' + Substr(pcondper, 1, 2) + '/' + Substr(pcondper, 3, 4) Endif lnInit = lnAn1 * 12 + lnLuna1 lnFinal = lnAn2 * 12 + lnLuna2 loRet = Createobject("empty") AddProperty(loRet, "an1", m.lnAn1) AddProperty(loRet, "luna1", m.lnLuna1) AddProperty(loRet, "an2", m.lnAn2) AddProperty(loRet, "luna2", m.lnLuna2) AddProperty(loRet, "perioada", m.lcPerioada) Return loRet Endproc && AlegePerioada *** Citeste optiunea pentru semnatura rapoarte "SEMN_CONT_INTOCMIT/SEMN_CONT_VERIFICAT/SEMN_CONT_DIRECTOR/SEMN_GEST_INTOCMIT/SEMN_INTOCMIT" Procedure GetSemnatura Lparameters tcModul, tcSemnatura, tcPrefix * tcModul: CONTABILITATE/GESTIUNE... * tcSemanatura: INTOCMIT/VERIFICAT/DIRECTOR/DIRECTOREC * tcPrefix OPTIONAL, default 'SEMN': se poate completa cu SEMN/DEN Local lcValue, lcOptiune, lcPrefix lcValue = '' lcPrefix = IIF(TYPE('tcPrefix') = 'C' and !EMPTY(m.tcPrefix), UPPER(ALLTRIM(m.tcPrefix)), 'SEMN') lcOptiune = lcPrefix + Iif(!Empty(m.tcModul), '_' + Upper(m.tcModul), '') + '_' + Upper(m.tcSemnatura) && 'SEMN_CONT_DIRECTOREC' / DEN_CONT_DEPFINCONT lcValue = Strtran(Nvl(citeste_optiune(m.lcOptiune), ''), '\r', Chr(13) + Chr(10), 1, 10, 1) && INLOCUIESC /R CU LINIE NOUA Return m.lcValue Endproc *************************************************** * Citeste atasament din baza de date si scrie fisier pe disk (ex: logo.jpg) * Se apeleaza fie cu id-ul atasamentului, fie cu numele fisierului * Intoarce numarul de bytes scrisi pe disk sau 0 *************************************************** Function Atasament2File Lparameters tnIdAtasament, tcfilename, tcFilePath * tnIdAtasament (optional) : id atasament * tcFileName (optional) : nume fisier atasament * tcFilePath : calea completa unde se salveaza fisierul, inclusiv numele fisierului Local lcFiltru, lcFiltruOriginal, lcFisier, lcOrder, lcSchema, lcSelect, lcgroup, llAfiseaza, lcFilePath Local llModParam, lnIdAtas Local lcFileName, lcNumeFisier, lnBytesWritten Local laFiles[1], lcOraM, ldDataM, lnD, lnFiles, lnH, lnM, lnMin, lnS, lnY, ltDataOraBD, ltDataOraFile Private poLink, pcFileName, pnIdAtasament poLink = Null lnBytesWritten = 0 pnIdAtasament = Iif(!Empty(m.tnIdAtasament), m.tnIdAtasament, 0) pcFileName = Iif(!Empty(m.tcfilename), Justfname(m.tcfilename), '') lcFilePath = Iif(!Empty(m.tcFilePath), m.tcFilePath, '') If !(Empty(m.pnIdAtasament) And Empty(m.pcFileName)) lcSchema = [fisier w, nume_fisier C(100), dataora T ] lcSelect = [select fisier, nume_fisier, dataora from atas_atasamente where sters = 0 and ] + Iif(!Empty(m.pnIdAtasament), 'id_atas = ?pnIdAtasament', Iif(!Empty(m.pcFileName), 'nume_fisier=?pcFileName', '1=2')) lcOrder = [] lcgroup = [] lcFiltru = [] lcFiltruOriginal = [] llModParam = .T. llAfiseaza = .F. gencursor('poLink', 'cRegFisierTemp', lcSelect, lcFiltru, lcSchema, lcOrder, llAfiseaza, lcgroup, llModParam, lcFiltruOriginal) poLink.ca_baza1.afisare() If Used('cRegFisierTemp') Select cRegFisierTemp If Reccount('cRegFisierTemp') > 0 Go Top lcFisier = fisier ltDataOraBD = dataora ltDataOraFile = dataora - 1 lcNumeFisier = Alltrim(Nvl(nume_fisier, '')) lcFileName = Iif(!Empty(m.pcFileName), m.pcFileName, m.lcNumeFisier) lcFilePath = Iif(!Empty(m.lcFilePath), m.lcFilePath, m.lcFileName) Use In (Select('cRegFisierTemp')) If !Directory(Justpath(m.lcFilePath)) Md (Justpath(m.lcFilePath)) Endif * Verific daca data/ora modificarii din baza de date este mai mare decat cea de pe disk * Nu suprascriu daca fisierul de pe disk este mai nou polog.Log("Dataora fisier baza date: " + TRANSFORM(m.ltDataOraBD), Program()) If File(m.lcFilePath) lnFiles = Adir(laFiles, m.lcFilePath) If m.lnFiles = 1 ldDataM = laFiles[1, 3] lcOraM = laFiles[1, 4] lnY = Year(m.ldDataM) lnM = Month(m.ldDataM) lnD = Day(m.ldDataM) lnH = INT(VAL(Substr(m.lcOraM, 1, 2))) lnMin = INT(VAL(Substr(m.lcOraM, 4, 2))) lnS = INT(VAL(Substr(m.lcOraM, 7, 2))) Try ltDataOraFile = Datetime(m.lnY, m.lnM, m.lnD, m.lnH, m.lnMin, m.lnS) Catch ltDataOraFile = m.ltDataOraBD Endtry ENDIF polog.Log("Dataora fisier disk: " + TRANSFORM(m.ltDataOraFile), Program()) Endif If m.ltDataOraBD > ltDataOraFile lnBytesWritten = Strtofile(m.lcFisier, m.lcFilePath) ELSE lnBytesWritten = 1 Endif Endif && reccount Endif && used Endif && empty Return m.lnBytesWritten Endfunc && Atasament2File *************************************************** * Citeste fisierul de pe disk si adauga atasament in baza de date atas_atasamente * Se apeleaza cu calea completa a fisierului * Intoarce id-ul atasamentului *************************************************** Function File2Atasament Lparameters tcFile, tcDescriere Private pcFileName, pnId, pcFile, pcDescriere Local lcSql, lcSqlIns, lcSqlUpd, llSucces pnId = 0 If !File(m.tcFile) tcFile = Getfile('', 'Alege un fisier', 'Alege', 0, 'Alege un fisier') If Empty(m.tcFile) Return m.pnId Endif Endif pcFile = Filetostr(m.tcFile) pcFileName = Lower(Justfname(m.tcFile)) pcDescriere = Iif(!Empty(m.tcDescriere), Alltrim(m.tcDescriere), '') lcSql = [SELECT id_atas FROM atas_atasamente WHERE nume_fisier = ?pcFileName] lcSqlIns = [insert into atas_atasamente (fisier, nume_fisier, descriere, id_util, dataora) values (?pcFile, ?pcFileName, ?pcDescriere, ?gnIdUtil, sysdate) returning id_atas into ?@pnId] lcSqlUpd = [UPDATE atas_atasamente SET fisier = ?pcFile, descriere = ?pcDescriere, id_util = ?gnIdUtil, dataora = sysdate WHERE id_atas = ?pnId] llSucces = goExecutor.oExecuta(m.lcSql, 'crsAtasamenteTemp') If m.llSucces Do Case Case Reccount('crsAtasamenteTemp') > 1 amessagebox('Sunt mai multe inregistrari cu acelasi nume de fisier! Nu se salveaza!', 0 + 16, _Screen.Caption) Case Reccount('crsAtasamenteTemp') = 1 pnId = crsAtasamenteTemp.id_atas Endcase Use In (Select('crsAtasamenteTemp')) If Empty(m.pnId) llSucces = goExecutor.oExecuta(m.lcSqlIns) Else llSucces = goExecutor.oExecuta(m.lcSqlUpd) pnId = Iif(m.llSucces, m.pnId, 0) Endif Endif Return m.pnId Endfunc && File2Atasament * ------------------------------------- * Genereaza o comanda sql pentru totalizarea unui tabel dupa anumite coloane * Echivalentul comenzii TOTAL TO, doar ca face group by dupa toate coloanele care nu sunt in lista de insumat * lcSql = Cursor2Total('cAct', 'cActTVA', 'suma,suma_val,valtva,tvaval', .F.) * &lcSql * ------------------------------------- Procedure Cursor2Total Lparameters tcSource, tcDestination, tcFieldList, tcSumFieldList, tlGenerateCursor * tcSource: source cursor name * tcDestination: destination cursor name * tcFieldList (optional, default empty = all fields): list of fields for group by * tcSumFieldList: list of fields for sum() * tlGenerateCursor (optional, default = .F.): execute the sql Local lcField, lcFieldList, lcGroupBy, lcSql, lcSumFieldList, llField, lnColCount, lnColumn lcSumFieldList = Alltrim(Lower(m.tcSumFieldList)) lcFieldList = Iif(Empty(m.tcFieldList), '', Lower(m.tcFieldList)) lnColCount = Fcount(tcSource) lcSql = [select ] lcGroupBy = [] For lnColumn = 1 To m.lnColCount lcField = Lower(Field(m.lnColumn, m.tcSource)) If m.lcField $ m.lcSumFieldList lcSql = m.lcSql + Iif(m.lnColumn > 1, [,], []) + [Sum(] + m.lcField + [) as ] + m.lcField Else llField = Empty(m.lcFieldList) Or m.lcField $ m.lcFieldList If m.llField lcSql = m.lcSql + Iif(m.lnColumn > 1, [,], []) + m.lcField lcGroupBy = m.lcGroupBy + Iif(m.lnColumn > 1, [,], []) + m.lcField Endif Endif Endfor lcSql = m.lcSql + [ from ] + m.tcSource + [ with (buffering=.t.) group by ] + m.lcGroupBy + [ into cursor ] + m.tcDestination + [ readwrite] If m.tlGenerateCursor &lcSql Endif Return m.lcSql Endproc ************************************ * Functie pentru calculul _PAGETOTAL pentru grupuri care reseteaza pagina la 1 intr-un raport * tcCrsAlias este optional, pentru a-l putea inchide la destroy in raport ************************************ Function UpdatePageTotalGroup(tcGroupValue, tcCrsAlias) Local lcAlias, lcSelect, lnPgCnt lcSelect = Select() lcAlias = Iif(!Empty(m.tcCrsAlias), tcCrsAlias, 'crsGrpPageCnt') If !Used(m.lcAlias) Create Cursor (m.lcAlias) (rptGrp C(100), pgCnt i) Select (m.lcAlias) Index On rptGrp Tag C_GrpPage Endif Select (m.lcAlias) If !Seek(Transform(m.tcGroupValue), m.lcAlias, 'C_GrpPage') Insert Into (m.lcAlias) (rptGrp) Values (Transform(m.tcGroupValue)) Endif Replace pgCnt With Max(pgCnt, _Pageno) lnPgCnt = pgCnt Select (m.lcSelect) Return m.lnPgCnt Endfunc && UpdatePageTotalGroup ******************************************* * Delete Directories and Files in Directory (including subdirectories) * Returns the number of files * * lnFiles = xdelete('c:\temp') ******************************************* FUNCTION xdelete LPARAMETERS tcDirectory LOCAL laFiles[1], llDelete llDelete = .T. lnFiles = xdir(@laFiles, m.tcDirectory, '*.*', m.llDelete) TRY RD (m.tcDirectory) CATCH TO loEx MESSAGEBOX(m.tcDirectory + ' ' + loEx.message) ENDTRY RETURN m.lnFiles ENDFUNC && xdelete ******************************************* * Get Files in Directory (including subdirectories) * Returns the number of files * * ex: Dimension laFiles(1) * =xdir(@laFiles, getdir(), '*.*') * optional, delete the files and directories * =xdir(@laFiles, getdir(), '*.*', .T.) ******************************************* Function xdir LPARAMETERS taryParam, tcDirectory, tcFileSkeleton, tlDelete Local Array aryTemp(1, 5) Local lnCount, lnMax, lnLen, lcFile, lcDirectory, lcFileSkeleton, lcDirFileSkeleton lcDirectory = Addbs(m.tcDirectory) lcFileSkeleton = Iif(!Empty(m.tcFileSkeleton), m.tcFileSkeleton, '*.*') lcDirFileSkeleton = Addbs(tcDirectory) + m.lcFileSkeleton = Adir(aryTemp, m.lcDirFileSkeleton, "AHRSD", 1) lnMax = Alen(aryTemp, 1) For lnCount = 1 To lnMax lcFile = Alltrim(aryTemp(lnCount, 1)) If !(m.lcFile == ".") And !(m.lcFile == "..") If "D" $ aryTemp(lnCount, 5) = xdir(@taryParam, Addbs(m.tcDirectory) + m.lcFile, m.lcFileSkeleton, m.tlDelete) IF m.tlDelete TRY RD (Addbs(m.tcDirectory) + m.lcFile) CATCH TO loEx MESSAGEBOX(Addbs(m.tcDirectory) + m.lcFile + ' ' + loEx.message) ENDTRY ENDIF Else lnLen = Alen(taryParam) If !Empty(taryParam(lnLen)) Dimension taryParam(lnLen + 1) lnLen = lnLen + 1 Endif taryParam(lnLen) = m.lcDirectory + m.lcFile IF m.tlDelete TRY DELETE FILE (taryParam(lnLen)) CATCH TO loEx MESSAGEBOX(taryParam(lnLen) + ' ' + loEx.message) ENDTRY ENDIF Endif Endif ENDFOR Return Alen(taryParam) ENDFUNC *------------------------------------------------------------------------ * syGetWordNum() * An alternate version of VFP GetWordNum() that will not skip empty fields. * e.g. * syGetWordNum([A,,B,C],2,[,]) returns empty string instead of 'B' * syGetWordNum([A,,B,C],3,[,]) returns 'B' instead of 'C' * Default delimiters are space, tab, carriage return and linefeed. * Vertical tab is used as a special token. *------------------------------------------------------------------------ function syGetWordNum(tcString, tnIndex, tcDelimiters) local lcPatch, lcWord, i if vartype(tcDelimiters)<>'C' tcDelimiters = chr(32) + chr(9) + chr(13) + chr(10) endif lcPatch = tcString for i = 1 to len(tcDelimiters) lcPatch = strtran(lcPatch,substr(tcDelimiters,i,1),chr(11)+substr(tcDelimiters,i,1)+chr(11)) endfor lcWord = getwordnum(lcPatch, tnIndex, tcDelimiters) lcWord = strtran(lcWord,chr(11)) return lcWord endfunc *------------------------------------------------------------------------ * syGetWordCount() * An alternate version of VFP GetWordCount() that will not skip empty fields. * e.g. * syGetWordCount([A,,B,C],[,]) returns 4 instead of 3 * Default delimiters are space, tab, carriage return and linefeed. * Vertical tab is used as a special token. *------------------------------------------------------------------------ function syGetWordCount(tcString, tcDelimiters) local lcPatch, lnCount, i if vartype(tcDelimiters)<>'C' tcDelimiters = chr(32) + chr(9) + chr(13) + chr(10) endif lcPatch = tcString for i = 1 to len(tcDelimiters) lcPatch = strtran(lcPatch,substr(tcDelimiters,i,1),chr(11)+substr(tcDelimiters,i,1)+chr(11)) endfor lnCount = getwordcount(lcPatch, tcDelimiters) return lnCount ENDFUNC **************************** FUNCTION ValidCNP LPARAMETERS nCnp LOCAL cCod IF TYPE('nCnp') = 'N' cCod=ALLTRIM(STR(m.nCnp,15,0)) ELSE cCod = ALLTRIM(m.nCnp) ENDIF IF LEN(cCod)!=13 RETURN .F. ENDIF LOCAL _X(13),_rest, j FOR j=1 TO 13 _X(j)=VAL(SUBSTR(cCod,j,1)) ENDFOR _rest=(_X(1)*2+_X(2)*7+_X(3)*9+_X(4)*1+_X(5)*4+_X(6)*6+_X(7)*3+_X(8)*5+_X(9)*8+_X(10)*2+_X(11)*7+_X(12)*9)%11 RETURN IIF((_rest<10 and _rest=_X(13))or(_rest = 10 and _X(13)=1),.T.,.F.) ENDFUNC && ValidCNP 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 * 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)) > 9 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 * *verifiban('RO79FNNB000501041759RO01') FUNCTION VerifIBAN LPARAMETERS iban iban = STRTRAN(iban, " ", "") IF LEN(ALLTRIM(iban)) <> 24 RETURN .F. ENDIF mcontrol = SUBSTR(iban, 3, 2) iban = SUBSTR(iban, 5, 20) + SUBSTR(iban, 1, 2) + "00" miban = "" FOR i = 1 TO 24 IF ISALPHA(SUBSTR(iban, i, 1)) miban = miban + ALLTRIM(STR(ASC(SUBSTR(iban, i, 1)) - 55)) ELSE miban = miban + SUBSTR(iban, i, 1) ENDIF ENDFOR mibansec = miban rest = "" FOR i = 0 TO 7 mibansec = rest + SUBSTR(miban, i * 5 + 1, 5) dv = MOD(VAL(mibansec), 97) rest = ALLTRIM(STR(dv)) ENDFOR IF PADL(ALLTRIM(STR(98 - VAL(rest))), 2, "0") <> mcontrol RETURN .F. ELSE RETURN .T. ENDIF ENDFUNC * FUNCTION GetSumaControlIBAN LPARAMETERS iban IF LEN(ALLTRIM(iban)) <> 24 RETURN "XX" ENDIF mcontrol = SUBSTR(iban, 3, 2) iban = SUBSTR(iban, 5, 20) + ; SUBSTR(iban, 1, 2) + "00" miban = "" FOR i = 1 TO 24 IF ISALPHA(SUBSTR(iban, i, ; 1)) miban = miban + ; ALLTRIM(STR(ASC(SUBSTR(iban, ; i, 1)) - 55)) ELSE miban = miban + ; SUBSTR(iban, i, ; 1) ENDIF ENDFOR mibansec = miban rest = "" FOR i = 0 TO 7 mibansec = rest + ; SUBSTR(miban, i * ; 5 + 1, 5) dv = MOD(VAL(mibansec), 97) rest = ALLTRIM(STR(dv)) ENDFOR RETURN PADL(ALLTRIM(STR(98 - ; VAL(rest))), 2, "0") ENDFUNC * 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 GetDigitsFromString LPARAMETERS plstr, plnrdigits, ; pltip, plseparator LOCAL mlenstr, ii, ; mreturnnrintermed, ; mreturnnrfinal mlenstr = LEN(ALLTRIM(plstr)) mreturnnrintermed = "" mreturnnrfinal = "" FOR ii = 1 TO mlenstr mcurentchar = SUBSTR(plstr, ; ii, 1) IF ISDIGIT(mcurentchar) .OR. ; (pltip = 3 .AND. ; INLIST(mcurentchar, ".", ; ",")) mreturnnrintermed = mreturnnrintermed + ; mcurentchar ELSE IF pltip = 1 .OR. pltip = ; 2 mreturnnrintermed = ; "" ENDIF ENDIF IF LEN(mreturnnrintermed) >= ; plnrdigits DO CASE CASE pltip = 1 IF LEN(mreturnnrintermed) <= ; 12 .AND. ; verifcf(mreturnnrintermed) ; .AND. ; .NOT. ; ISDIGIT(SUBSTR(plstr, ; ii + 1, ; 1)) mreturnnrfinal = ; mreturnnrintermed EXIT ENDIF CASE pltip = 2 IF cvalidcnp(mreturnnrintermed) mreturnnrfinal = ; mreturnnrintermed EXIT ENDIF CASE pltip = 3 mreturnnrintermed = ; STRTRAN(mreturnnrintermed, ; plseparator, ; "") IF VAL(mreturnnrintermed) > ; 0 mreturnnrfinal = ; mreturnnrintermed EXIT ENDIF ENDCASE ENDIF ENDFOR RETURN mreturnnrfinal ENDFUNC * FUNCTION GetIBANFromString LPARAMETERS plstr, plpoz LOCAL mlenstr, ii, ; mreturnnrintermed, ; mreturnnrfinal mlenstr = LEN(ALLTRIM(plstr)) mreturnnrintermed = "" mreturnnrfinal = "" misok = .F. FOR ii = 1 TO mlenstr mcurentchar = SUBSTR(plstr, ; ii, 1) IF misok IF LEN(mreturnnrintermed) < ; 24 mreturnnrintermed = ; mreturnnrintermed + ; mcurentchar ELSE EXIT ENDIF ELSE IF mcurentchar == "R" ; .AND. ; mreturnnrintermed = ; "" .AND. ; SUBSTR(plstr, ii + 1, ; 1) == "O" mreturnnrintermed = ; mreturnnrintermed + ; mcurentchar ELSE IF mcurentchar == ; "O" .AND. ; mreturnnrintermed = ; "R" mreturnnrintermed = ; mreturnnrintermed + ; mcurentchar ELSE IF .NOT. ; misok ; .AND. ; INLIST(mcurentchar, ; "1", "2", ; "3", "4", ; "5", "6", ; "7", "8", ; "9", "0") ; .AND. ; mreturnnrintermed = ; "RO" ; .AND. ; LEN(mreturnnrintermed) <= ; 3 mreturnnrintermed = ; mreturnnrintermed + ; mcurentchar IF plpoz = ; 1 misok = ; .T. ELSE mreturnnrintermed = ; "" plpoz = ; plpoz - ; 1 ENDIF ELSE mreturnnrintermed = ; "" ENDIF ENDIF ENDIF ENDIF ENDFOR IF verifiban(mreturnnrintermed) RETURN mreturnnrintermed ELSE RETURN "" ENDIF ENDFUNC * FUNCTION ContainChar LPARAMETERS plstr DO WHILE .NOT. (ISALPHA(plstr) .OR. LEFT(plstr, 1); == "&" .OR. LEFT(plstr, 1) == "/" .OR. LEFT(plstr,; 1) == "-" .OR. LEFT(plstr, 1) == "_") IF EMPTY(plstr) RETURN .F. ENDIF plstr = RTRIM(SUBSTR(plstr, ; 2, 60)) ENDDO RETURN .T. ENDFUNC * FUNCTION GetStrFromStr LPARAMETERS plstr LOCAL mstr mstr = "" DO WHILE ISALPHA(plstr) .OR. ; LEFT(plstr, 1) == " " mstr = mstr + LEFT(plstr, 1) plstr = SUBSTR(plstr, 2, 20) ENDDO RETURN ALLTRIM(mstr) ENDFUNC * FUNCTION CheckDigit LPARAMETERS tcstring LOCAL llsuccess llsuccess = .F. IF EMPTY(tcstring) RETURN .F. ENDIF FOR lncharacter = 1 TO ; LENC(tcstring) lcchar = SUBSTRC(tcstring, ; lncharacter, 1) llsuccess = ISDIGIT(lcchar) IF llsuccess EXIT ENDIF ENDFOR RETURN llsuccess ENDFUNC * FUNCTION IsOnlyDigit LPARAMETERS tcstring LOCAL llsuccess llsuccess = .F. IF EMPTY(tcstring) RETURN .F. ENDIF FOR lncharacter = 1 TO ; LENC(tcstring) lcchar = SUBSTRC(tcstring, ; lncharacter, 1) IF .NOT. ISDIGIT(lcchar) ; .AND. .NOT. ; INLIST(lcchar, ",", ".", ; " ") RETURN .F. ENDIF ENDFOR RETURN .T. ENDFUNC PROCEDURE TestExcesSerialNumber2Date * Example ? ExcelSerialNumber2Date(39278) && 2007-07-15 ? ExcelSerialNumber2Datetime(39278.456777) && 2007-07-15 10:57:46 ? ExcelSerialNumber2Time(.456777) && 10:57:46 ENDPROC *-------------------------------------------------------------------- * Convert Excel serial number to a date FUNCTION ExcelSerialNumber2Date(tnExcelSerialNumber) RETURN {^1899/12/30} + tnExcelSerialNumber ENDFUNC && ExcelSerialNumber2Date * Convert Excel serial number to a datetime FUNCTION ExcelSerialNumber2Datetime(tnExcelSerialNumber) RETURN DTOT({^1899/12/30} + INT(tnExcelSerialNumber)) + ; ROUND(24*60*60 * (tnExcelSerialNumber % 1),0) ENDFUNC && ExcelSerialNumber2Datetime * Convert Excel serial number to a time string FUNCTION ExcelSerialNumber2Time(tnExcelSerialNumber) RETURN SUBSTR(TTOC({^2000/01/10 00:00:00} + ROUND(24*60*60 * (tnExcelSerialNumber % 1),0),3), 12) ENDFUNC && ExcelSerialNumber2Time *************************************************************** * Unzip a zip file * lcZipFile = 'c:\arhiva.zip' * lcUnzipDir = '' * lcErrrMessage = '' * llSuccs = Unzip(m.lcZipFile, @lcUnzipDir, @lcErrrMessage) *************************************************************** PROCEDURE MyUnzip LPARAMETERS tcFileName, tcUnzipDir, tcErrorMessage, tlSilent * tcFileName: IN calea catre fisierul arhiva zip * tcUnzipDir: IN/OUT director dezarhivare * tcErrorMessage: OUT mesaj eroare daca RETURN = .F. * tlSilent: .T. fara wait window la callback * RETURN: Logical .T. daca dezarhivare cu succes Local lcFileName, lcLibraryPath, llSucces, loErr llSucces = .F. lcFileName = m.tcFileName tcErrorMessage = '' If Empty(m.lcFileName) OR !FILE(m.lcFileName) tcErrorMessage = 'Fisierul de dezarhivat nu exista!' RETURN m.llSucces ENDIF IF EMPTY(m.tcUnzipDir) tcUnzipDir = Addbs(Sys(2023)) + Sys(2015) ENDIF IF !DIRECTORY(m.tcUnzipDir ) Md (m.tcUnzipDir ) ENDIF Try lcLibraryPath = ADDBS(m.gcBasePath) + Iif("ROA" $ Upper(gcBasePath), "COMUNROA", "COMUNCONTAFIN") + "\vfpcompression.fll" && CONTAFIN(ROA)\COMUNCONTAFIN(COMUNROA)\vfpcompression.fll If File(m.lcLibraryPath) If !'vfpcompression' $ LOWER(Set("Library")) Set Library To (m.lcLibraryPath) Additive Endif IF !m.tlSilent ZipCallback("MyUnzipCallBack()") && Start Event Handling - Any Function/Procedure/Method (in scope of course) ENDIF llSucces = UnzipQuick(m.lcFileName, m.tcUnzipDir ) ZipCallback("") && Stop Event Handling ELSE llSucces = .F. tcErrorMessage = 'Nu exista libraria ' + m.lcLibraryPath ENDIF CATCH TO loErr llSucces = .F. tcErrorMessage = loErr.Message ENDTRY RETURN m.llSucces ENDPROC Procedure UnzipQuickShell Lparameters tcFileName, tcUnzipDir, tcErrorMessage, tlSilent * tcFileName: IN calea catre fisierul arhiva zip * tcUnzipDir: IN/OUT director dezarhivare * tcErrorMessage: OUT mesaj eroare daca RETURN = .F. * tlSilent: .T. fara wait window la callback && nu este implementat la shell * RETURN: Logical .T. daca dezarhivare cu succes Local loShell As "shell.application", loEx as Exception Local lcFileName, lcUnzipDir, llSucces, ofile tcErrorMessage = '' llSucces = .F. Try lcFileName = m.tcFileName && "C:\temp\D401001F.ZIP" lcUnzipDir = m.tcUnzipDir IF EMPTY(m.tcUnzipDir) OR TYPE('tcUnzipDir') <> 'C' lcUnzipDir = Addbs(Sys(2023)) + Sys(2015) ENDIF If !Directory(m.lcUnzipDir) Md (m.lcUnzipDir) Endif loShell = Createobject("shell.application") For Each ofile In loShell.NameSpace(m.lcFileName).items loShell.NameSpace(m.lcUnzipDir).copyhere(ofile, 16) Endfor llSucces = .T. Catch To loEx tcErrorMessage = loEx.Message llSucces = .F. Endtry Return m.llSucces Endproc && UnzipQuickShell ******************************** * Intoarce calea COMUNA pentru pdf-uri declaratii, efactura generate de program * D:\ROA\[tcTip]\[AAAA_LL]\[FIRMA]\[tcTip2] * lcFisierPDF = GetPdfPath('EFACTURA', 'PRIMITE') ******************************** FUNCTION GetPdfPath LPARAMETERS tcTip, tcTip2 * tcTip: D300/D394/D390/eFactura * tcTip2: (optional) Primite (eFactura) Local lcCaleFisier, lcMesaj, lcTip, llSucces, loEx, lcFirma lcTip = IIF(!EMPTY(m.tcTip), UPPER(ALLTRIM(m.tcTip)), 'ALTE') *** Creez structura director export (caletemp\D390\aaaa_ll\firma\ llSucces = .F. Try lcCaleFisier = Addbs(m.gcBasePath) + m.lcTip + "\" && d:\ROA\D390\ If !Directory(m.lcCaleFisier) Md (m.lcCaleFisier) Endif lcCaleFisier = m.lcCaleFisier + Alltrim(Str(gnAn)) + "_" + Padl(Alltrim(Str(gnLuna)), 2, "0") + "\"&& d:\ROA\D390\2011_01\ If !Directory(m.lcCaleFisier) Md (m.lcCaleFisier) Endif lcFirma = WindowsSpecialCharacters(m.gcFirma, "_") && Chrtran(m.gcFirma, [/\?%*:|"<>.,;=], Replicate('_', 14)) lcFirma = Strtran(Alltrim(m.lcFirma), [ ], [_], 1, 100, 1) lcFirma = LEFT(m.lcFirma,70) && daca este prea lunga calea, xml3.save nu poate salva fisiere lcCaleFisier = m.lcCaleFisier + m.lcFirma + "\" && Strtran(gcFirma, [ ], [_]) + "\" && d:\ROA\D390\2011_01\firma\ If !Directory(m.lcCaleFisier) Md (m.lcCaleFisier) Endif IF !EMPTY(m.tcTip2) lcCaleFisier = m.lcCaleFisier + UPPER(ALLTRIM(m.tcTip2)) + '\' && d:\ROA\D390\2011_01\firma\primite\ If !Directory(m.lcCaleFisier) Md (m.lcCaleFisier) ENDIF ENDIF llSucces = .T. Catch To loEx lcCaleFisier = '' lcMesaj = "Creare director " + lcCaleFisier + " " + loEx.Message amessagebox(lcMesaj, 0 + 48) Endtry RETURN m.lcCaleFisier ENDFUNC && GetPdfPath FUNCTION DeleteFiles lcName = SYS(2000, '*.TXT') DO WHILE LEN (lcName) > 0 DELETE FILE (lcName) lcName = SYS (2000, '*.TXT') ENDDO ENDFUNC PROCEDURE HTTPDownloadFile LPARAMETERS lcURL, m.lcDownloadFile Local loHTTP As "winhttp.winhttprequest.5.1" Local lnBytes, lnStatus loHTTP = Createobject("winhttp.winhttprequest.5.1") loHTTP.Open("GET", m.lcURL, .F.) loHTTP.Send() lnStatus = loHTTP.Status lnBytes = 0 If m.lnStatus = 200 && OK lnBytes = STRTOFILE(loHTTP.ResponseBody, m.lcDownloadFile) ENDIF RETURN m.lnBytes > 0 ENDPROC