*!* 22.07.2016
*!* marius.mutu
*!* cursor2lista - adaugare parametru tcFilter

Function caut_nume_politica
Lparameters tnIdPol
Local lcNume
Store "" To lcNume
If !Empty(Nvl(tnIdPol,0))
	If Used('crstemppol')
		Use In crstemppol
	Endif
	lcSql = [select nume from ] + gcS + [.crm_vpolitici_pret_curente where id_pol = ] + Alltrim(Str(tnIdPol))
	lnSucces = goExecutor.oExecute(lcSql,[crstemppol])
	If lnSucces < 0
		amessagebox(goExecutor.oPrelucrareEroare(),16,"Eroare")
	Else
		Select crstemppol
		lcNume = Alltrim(Upper(nume))
	Endif
	If Used('crstemppol')
		Use In crstemppol
	Endif
Endif
Return lcNume
Endfunc	&&	caut_nume_politica
*****************************************************************************************
Function caut_nume_grupa_art
Lparameters tnIdGrupaArt
Local lcNume
Store "" To lcNume
If !Empty(Nvl(tnIdGrupaArt,0))
	If Used('crstempgrupart')
		Use In crstempgrupart
	Endif
	lcSql = [select grupa from ] + gcS + [.vgest_art_gr where id_grupa = ] + Alltrim(Str(tnIdGrupaArt))
	lnSucces = goExecutor.oExecute(lcSql,[crstempgrupart])
	If lnSucces < 0
		amessagebox(goExecutor.oPrelucrareEroare(),16,"Eroare")
	Else
		Select crstempgrupart
		lcNume = Alltrim(Upper(grupa))
	Endif
	If Used('crstempgrupart')
		Use IN crstempgrupart
	Endif
Endif
Return lcNume
ENDFUNC

*****************************************************************************************
* Cautare nume gestiuni depozit/sectie (roacomenzi)
*****************************************************************************************
Function caut_nume_gest_dep
	parameters tcLISTA_GESTIUNI_DEPOZIT
	* tcLISTA_GESTIUNI_DEPOZIT: lista id-uri gestiuni tip depozit corespunzatoare unei sectii, separate prin |

	Local lcNume
	Store "" To lcNume
	If !Empty(Nvl(tcLISTA_GESTIUNI_DEPOZIT,''))
		Use In (SELECT('crstempgest'))
		lcSql = [select stringagg(cgest) as cgest from vnom_gestiuni where id_gestiune in (SELECT X FROM table(charn2collection(?tcLISTA_GESTIUNI_DEPOZIT, ',')))]
		llSucces = goExecutor.oExecuta(lcSql,[crstempgest])
		If llSucces
			Select crstempgest
			lcNume = Alltrim(Upper(cgest))
		Endif
		Use In (SELECT('crstempgest'))
	Endif
	Return lcNume
ENDFUNC

*****************************************************************************************
Procedure make_sectii_utilizator
	lcSel = [{call PACK_COMENZI.sectii_utilizator(?gnIdUtil,?gnIdSucursala)}]
	lcCursor = 'crsSectii'
	lnSucces = goExecutor.oExecute(lcSel,lcCursor)
	If lnSucces < 0
		amessagebox(goExecutor.cEroare,0+16,"Eroare")
		Return
	Endif
	Select crsSectii
	Go Top
Endproc && make_sectii_utilizator
*****************************************************************************************
Procedure extrage_optiuni
Parameters tcLista, tnId

Local lcLista, lcReturn
Store '' To lcReturn
lcLista = Nvl(Alltrim(tcLista),'')
lnNrOptiuni = Getwordcount(lcLista,";")
For i=1 To lnNrOptiuni
	lcExtragOptId = Getwordnum(lcLista,i,";")
	lcId_extras = Getwordnum(lcExtragOptId,1,[:])
	If lcId_extras = Alltrim(Str(tnId))
		lcReturn = Getwordnum(lcExtragOptId,2,[:])
	Endif
Endfor

Return lcReturn

Endproc && extrage_optiune
********************************************************************************************************************
*!*	lcLista = '1001::3;2::777;21001::5;'
*!*	lcId = 2
*!*	lcValoareNoua = '9'
*!*	lcListaNoua = recompune_optiuni(lcLista,lcId,lcValoareNoua)
Procedure recompune_optiuni
Parameters tcLista, tnId, tcValoareNoua

Local lcLista, lcListaNoua, lcId, lcValoareNoua, lnGrupuri, lcGrup, lcIdCautat, lnPoz, lnPozGrup, lcValoare
lcLista = Nvl(Alltrim(tcLista),'')
lcId = Alltrim(Str(tnId))
lcValoareNoua = Alltrim(tcValoareNoua)

llGasit = .F.
lcListaNoua = ''
lnGrupuri = Getwordcount(lcLista,';')
For i = 1 To lnGrupuri
	lcGrup = Getwordnum(lcLista,i,";")
	If i=1
		lcIdCautat = lcId + [:]
	Else
		lcIdCautat = ';'+ lcId + [:]
		lcGrup = ';' + lcGrup				&&	';id_sectie::optiune_veche'
	Endif
	lnPozGrup = At(lcIdCautat,lcGrup)
	If lnPozGrup > 0
		llGasit = .T.
		lnPoz = At([:], lcGrup)
		If lnPoz > 0
			lcValoare = Substr(lcGrup,lnPoz)	&&	'::optiune_veche'
			lcGrup= Strtran(lcGrup,lcValoare,[:]+lcValoareNoua)
		Endif
	Endif
	lcListaNoua = lcListaNoua + lcGrup
Endfor

If lnGrupuri = 0
	lcListaNoua = lcId + [:] + lcValoareNoua
Else
	If !llGasit
		lcListaNoua = lcListaNoua + ';' + lcId + [:] + lcValoareNoua
	Endif
Endif

Return lcListaNoua

Endproc && recompune_optiuni
*****************************************************************************************
Function cere_perioada_luni
Lparameters tlIanMar,tnOptiuneStart
***	tnOptiuneStart - pe ce e setat
***		0	=	luna
***		1	=	perioada
Local lcAn1,lcAn2,lcLuna1,lcLuna2,loPerioada,lofrmperioada
Private pcondper
Store "" To loPerioada,lofrmperioada
pcondper = ""
lofrmperioada = Createobject('frm_perioada_luni',.T.,tnOptiuneStart)
lofrmperioada.Show(1)
If gnButon=2
	loPerioada = Null
Else
	loPerioada = Createobject("Session")
	loPerioada.AddProperty([cPerioada],[])
	loPerioada.AddProperty([nInit],0)
	loPerioada.AddProperty([nFinal],0)

	lnPoz=At('_',pcondper)
	lcAn1 = Substr(pcondper,3,4)
	lcLuna1 = Substr(pcondper,1,2)
	If lnPoz>0
		lcAn2 = Substr(pcondper,10,4)
		lcLuna2 = Substr(pcondper,8,2)
	Else
		lcAn2 = Substr(pcondper,3,4)
		lcLuna2 = Substr(pcondper,1,2)
	Endif

	loPerioada.nInit = Val(lcAn1) * 12 + Val(lcLuna1)
	loPerioada.nFinal = Val(lcAn2) * 12 + Val(lcLuna2)
	loPerioada.cPerioada = lcLuna1 + '/' + lcAn1 + ' - ' + lcLuna2 + '/' + lcAn2
Endif
Release pcondper,lcAn1,lcAn2,lcLuna1,lcLuna2,lofrmperioada
Return loPerioada
Endfunc

*!*	SET CLASSLIB TO d:\contafin\contab\clase\caut.vcx ADDITIVE 
*!*	oo=ret_luna("Luna de inceput")
*** scattered = MYSCATTER() && This is instead of SCATTER NAME...
Procedure myScatter
	Parameters tcBlank
	Local llBlank, loScatter
	
	llBlank=.F.
	If Type('tcBlank')='C'
		If 'BLANK'$UPPER(tcBlank)
			llBlank=.T.
		Endif
	Endif

	myScatterObject = Createobject("myScatterObject")
	If !Empty(Alias())
		If llBlank
			Scatter Name loScatter Memo Blank
		Else
			Scatter Name loScatter Memo
		Endif
		lnFields = Fcount(Alias())
		For N =1 To lnFields
			lcField=Field(N)
			lcvalue=loScatter.&lcField
			myScatterObject.AddProperty(lcField, lcvalue)
		Endfor
		Release loScatter
	Endif
	Return myScatterObject && Always return an object, so GATHER command could not choke.
Endproc

Define Class myScatterObject As Session
	* You may use any VFP class directly like myScatterObject = CREATEOBJECT("Session")
	* But you may optionally use this DEFINE CLASS
	* and declare the native PEMs here as HIDDEN if you want, so they are not exposed
	* in case you are using class other than Session or work with VFP version prior to VFP 7.0
Enddefine
PROCEDURE lista2cursor
PARAMETERS tcLISTA,tcAlias,tcCol1,tcSeparator
&& tcLista este un sir de caractere care contine elementele separate prin <;> default	
&& tcAlias este cursorul 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,";")
	LOCAL Lclista,lcSeparator,lnNRF,lcF1,i

	lcLista=UPPER(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)


	FOR i=1 TO lnNRF
		lcF1=LEFT(lcLista,AT(lcSeparator,lcLista)-1)

		IF i!=lnNRF
			lcLista=SUBSTR(lcLista,AT(lcSeparator,lcLista)+1)
		ENDIF

	INSERT INTO (tcAlias) (&tcCol1) VALUES (lcF1)
	
	ENDFOR

	RETURN lnNrf
	
ENDPROC && lista2cursor
*____________________________________________________________________________________________

*** returneaza un obiect cu proprietatile cont si acont (doar conturile din 'tcListaConturi' existente in planul de conturi)
Function ret_cont
	Parameters tcTitlu, tcListaConturi

	Private loCont

	Local Ol As "frm_sel_cont"
	Local lcLista, lcSel, lnSucces, lcSelect
	lcSelect = SELECT()
	
	Create Cursor tCont (conturi c(5))
	lcLista = IIF(!EMPTY(m.tcListaConturi), Alltrim(m.tcListaConturi), '')
	lista2cursor(m.lcLista, 'tCont', 'conturi', ',')

	Select tCont
	Replace All conturi With Alltrim(conturi) + '*'

	lcSel = [select cont, acont, tip_sold from plcont where an = ] + Alltrim(Str(gnAn)) + [ and inactiv = 0 and nefolosit = 0 ]
	lnSucces = goExecutor.oExecute(lcSel, 'tplcont')

	If lnSucces < 0
		amessagebox(goExecutor.cEroare, 0 + 16, 'Eroare')
		Use In (Select('tCont'))
		Return .F.
	Endif

	Use In (Select('tsel_cont'))

	Select * From tplcont p Join tCont T On Like(Alltrim(T.conturi), p.Cont) ;
		Into Cursor tsel_cont Readwrite ;
		Order By p.Cont, p.acont

	Use In (Select('tCont'))
	Use In (Select('tPlCont'))

	Select tsel_cont
	Delete All For acont = '0000'
	loCont = myScatter('blank')

	Ol = Createobject("frm_sel_cont")
	With Ol
		.lb_titlu_alb_b121.Caption = tcTitlu
		If Empty(.cboCont.RowSource)
			.cboCont.RowSource = "tsel_cont.cont,acont"
		Endif
		.ocont = loCont
		If Empty(.cAlias)
			.cAlias = Left(.cboCont.RowSource, At(".", .cboCont.RowSource) - 1)
		Endif
	Endwith
	Ol.Show(1)

	Use In (Select('tsel_Cont'))
	Select (m.lcSelect)

	Return loCont
Endfunc && ret_cont
*-------------------------------------------------------------------------------------------

*** returneaza un obiect cu proprietatile an si nl (de fapt cu toate coloanele din calendar)
Function ret_luna
	Parameters tcTitlu
	
	PRIVATE loLuna

	Select calendar
	USE DBF('calendar') IN 0 AGAIN ALIAS tsel_luna share
	SELECT tsel_luna
	loLuna=myscatter('blank')

	Ol=Createobject("frm_sel_luna")
	WITH Ol
		.lblTitlu.Caption=tcTitlu
		IF EMPTY(.cboLuna.rowsource)
			.cboLuna.rowsource="tsel_luna.nl,an"
		ENDIF
		.oLuna=loLuna
		IF EMPTY(.cAlias)
			.cAlias=LEFT(.cboLuna.RowSource,AT(".",.cboLuna.RowSource)-1)
		ENDIF 		
	ENDWITH 
	Ol.Show(1)
	
	USE IN tsel_luna

	Return loLuna
ENDFUNC && ret_oluna
*___________________________________________________________________________________________

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 cerestring
PARAMETERS tit,nvar
	OLIT=CREATEOBJECT("CAUTLITERE")
	WITH OLIT
		.CAPTION=tit
		.label1.visible=.f.
		.text1.controlsource=nvar
	endwith
	olit.show(1)
RETURN

*-----------------------------------------
PROCEDURE cerenumar
PARAMETERS tit,nvar
	Ointre=CREATEOBJECT("CAUTintre")
	WITH Ointre
		.CAPTION=''
		.label1.caption=tit
		.label2.visible=.f.
		.text1.controlsource=nvar
		.text2.visible=.f.
	endwith
	ointre.show(1)
RETURN


*-----------------------------------------
PROCEDURE cereDATE
PARAMETERS tit,nvar1,NVAR2,L1,L2
	Ointre=CREATEOBJECT("CAUTintre")
	WITH Ointre
		.CAPTION=TIT
		.text1.controlsource=nvar1
		.text2.controlsource=nvar2
		.label1.caption=L1
		.label2.caption=L2
	endwith
	ointre.show(1)
RETURN



*----------------------------------------------
FUNCTION get_date_prec
Sele calendar
Locate For nl=m.nl And an=m.an
Skip -1
If !Bof()
	nla=nl
	ana=an
	dateA=calefirma+'\an'+ana+'\date'+nla &&DATE PREC
Else
	dateA=dirgen+'\_alfa\an0000\date00\'
Endif
RETURN datea

*--------------------------------------------------------------------------------

function existacimp
param numet,numec
for i=1 to fcount()
if upper(allt(field(i)))=upper(allt(numec))
	return .t.
endif
next
return .f.

*---------------------------------------------------------------------------------

function compartabele
PARAMETERS nume

SET EXACT on
SELECT fistotv
LOCATE FOR numef=UPPER(nume)
IF !FOUND()
	RETURN
ENDIF
SCATTER memv
c1=ALLTRIM(m.calealfa)+'\'
c2=ALLTRIM(m.cale)+'\'
SELECT &nume
nrcol1=FCOUNT()
dat=c1+m.numef

USE &dat IN 0 ALIAS aliasmf

SELECT aliasmf
nrcol2=FCOUNT()
USE IN aliasmf

IF nrcol1<>nrcol2 
RETURN .f.
	ELSE
RETURN .t.
ENDIF

ENDPROC 
*-----------------------------------------
function cereluna
PARAMETERS tit
LOCAL lz,az
lz=luna
az=anul
SELECT calendar
SET FILTER TO 
	Ox=CREATEOBJECT("seleluna")
	ox.label1.caption=tit
	ox.show(1)	
	nlun=luna
	nan=anul
luna=lz
anul=az
SELECT calendar
SET FILTER TO 
RETURN nlun+nan

*__________________________________________________________

&& Folosesc un tabel <ids> (tabel,id) cu cate o linie pt fiecare tabel
&& aflu id-ul urmator si il scriu in tabela <ids>
&& returnez id-ul
&& EX1: LNEW_ID=NEW_ID("GRILA_SAL") --> urmatorul id din <grila_sal> fara cautare in tabela originala
&& EX2: LNEW_ID=NEW_ID("GRILA_SAL","ID") --> urmatorul id din <grila_sal> cu cautare in tabela originala dupa campul<id>
&& ex3: LNEW_ID=NEW_ID("GRILA_SAL","ID",.T.) --> .T. INSEAMNA CA TABELUL ORIGINAL ESTE INDEXAT DUPA <ID> 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

******

* Foloseste comment de la coloane si tooltiptext de la grid pt a salva recordsource si controlsource din grid inainte de reconstructie
PROCEDURE SAVE_GRID_COMMENT
PARAM toGrid
*wait wind 'save_grid'
private pogrid
if param()=0 or type('togrid')!="O"
	return .F.
endif

poGrid=togrid

* remember control sources in the column's comment field
with pogrid
  local nColumnIndex
  for m.nColumnIndex = 1 to .ColumnCount
    .Columns(m.nColumnIndex).Comment = .Columns(m.nColumnIndex).ControlSource
  endfor
  .ToolTipText=.RecordSource
  .RecordSource=""
endwith

return .T.
endproc && SAVE_GRID_COMMENT
***--------------------------------------------------------------
PROCEDURE RESTORE_GRID_COMMENT
PARAM toGrid

*wait wind 'restore_grid'
private pogrid
if param()=0 or type('togrid')!="O"
	return .F.
endif

poGrid=togrid


with poGrid
* restore record source
  .RecordSource = .ToolTipText
* restore control sources
  for m.nColumnIndex = 1 to .ColumnCount
    .Columns(m.nColumnIndex).ControlSource = .Columns(m.nColumnIndex).Comment
  endfor
    .ToolTipText=""
endwith
return .T.
endproc && RESTORE_GRID_COMMENT


* Foloseste comment de la coloane si tooltiptext de la grid pt a salva recordsource si controlsource din grid inainte de reconstructie
PROCEDURE SAVE_GRID_TAG
PARAM toGrid
*wait wind 'save_grid'
private pogrid
if param()=0 or type('togrid')!="O"
	return .F.
endif

poGrid=togrid

* remember control sources in the column's comment field
with pogrid
  local nColumnIndex
  for m.nColumnIndex = 1 to .ColumnCount
    .Columns(m.nColumnIndex).Tag = .Columns(m.nColumnIndex).ControlSource
  endfor
  .ToolTipText=.RecordSource
  .RecordSource=""
endwith

return .T.
endproc && SAVE_GRID_TAG
***--------------------------------------------------------------
PROCEDURE RESTORE_GRID_TAG
PARAM toGrid

*wait wind 'restore_grid'
private pogrid
if param()=0 or type('togrid')!="O"
	return .F.
endif

poGrid=togrid


with poGrid
* restore record source
  .RecordSource = .ToolTipText
* restore control sources
  for m.nColumnIndex = 1 to .ColumnCount
    .Columns(m.nColumnIndex).ControlSource = .Columns(m.nColumnIndex).Tag
  endfor
    .ToolTipText=""
endwith
return .T.
endproc && RESTORE_GRID_TAG


*-------------------------------------------
* Function...: Xmenu
* Author.....: MARTIN
* Date.......: 04/06/1997
* Notes......: Based on an idea from Steve Zimmelman for FoxPro 2.x
* Parameters.: tcItems = Semicolon-separated String with the various options
* ...........: tnBar   = Initially selected item (default=1)
* Returns....: Selected item number
* See Also...: PROMPT() [FoxPro Native]
*
PROCEDURE XMENU
	LPARAMETERS TCITEMS, TNBAR

	LOCAL NITEMCOUNT, AITEMS, X, NROW, NCOL, CTITLE, NLASTPOS, CCOLOR, AITEMS

	PRIVATE CPOPMENU, NSELECT	&& They flow into the GetChoice internal procedure

	IF PCOUNT() < 2
		TNBAR = 1
	ENDIF

	ACTIVATE SCREEN

	* Parse every item
	*
	M.NITEMCOUNT = OCCURS( ';', TCITEMS ) + 1
	DIMEN AITEMS[ m.nItemCount ]
	M.NLASTPOS = 1

	FOR m.X = 1 TO m.NITEMCOUNT

		IF m.X < m.NITEMCOUNT

			AITEMS[ m.x ] = SUBS( m.TCITEMS, m.NLASTPOS, ;
				( AT( ';', m.TCITEMS, m.X ) - 1 ) - m.NLASTPOS + 1 )
		ELSE
			AITEMS[ m.x ] = SUBS( m.TCITEMS, m.NLASTPOS, ;
				( LEN( m.TCITEMS ) - m.NLASTPOS ) + 1 )
		ENDIF

		IF AITEMS[ m.x ] # "\-"

			AITEMS[ m.x ] = ALLT( AITEMS[ m.x ] )
		ENDIF

		M.NLASTPOS=AT( ';', m.TCITEMS, m.X ) + 1
	NEXT

	* Calculates the mouse pointer position
	*
	M.NROW = IIF( MROW() + m.NITEMCOUNT < SROW(), MROW() - 1, SROW() - m.NITEMCOUNT )
	M.NCOL = IIF( MCOL() + 10 < SCOL(), MCOL() - 3, MCOL() - 13 )

	* Gets an unique name for the pop-up
	*
	M.CPOPMENU = 'M' + SYS(3) + "_"

DEFINE POPUP ( m.CPOPMENU ) SHORTCUT RELATIVE FROM NROW, NCOL

FOR m.X = 1 TO m.NITEMCOUNT

DEFINE BAR m.X OF ( m.CPOPMENU ) PROMPT AITEMS[ m.x ]
NEXT

M.CANS = ""
M.NSELECT = 0
CLEAR TYPE

ON SELECTION POPUP ( m.CPOPMENU ) DO GETCHOICE

ACTIVATE POPUP ( m.CPOPMENU ) BAR TNBAR

POP KEY
RELEASE POPUP ( m.CPOPMENU )

RETURN IIF( LASTKEY()=27, 0, m.NSELECT )

ENDPROC && XMENU

*--------------------
	PROCEDURE GETCHOICE

		M.NSELECT = BAR()

		DEACTIVATE POPUP ( m.CPOPMENU )

		RETURN
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& MENIU &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

*---------------------------------------------------------------------------------
*** compara 2 tabele ca structura si ca tag-uri de indexare
FUNCTION compara_tabele
PARAMETERS tcAliasC,tcFisS

lcExact=SET("Exact")
SET EXACT ON 
*** tcAliasC = Alias-ul tabelului comparat ; trebuie sa fie deschis
*** tcFisS = calea completa catre fisierul standard

LOCAL lnOK,lnFileSDoesntexist,lnDifferentColumnCount,lnDifferentColumns,lnDifferentTags

lnOK = 0	
lnFileSDoesntexist = 1
lnDifferentColumns = 2
lnDifferentTags = 3

PRIVATE lcOldAlias
lcOldAlias=ALIAS()
IF EMPTY(lcOldAlias)
	lcOldAlias=SELECT(0)
ENDIF

lcAliasC=ALLTRIM(tcAliasC)
lcFisS=ALLTRIM(tcFisS)

IF !FILE('&lcFisS')
	SELECT (lcOldAlias)
	RETURN lnFileSDoesntexist
ENDIF 


USE ('&lcFisS') IN 0 SHARED ALIAS FisierSursa


*** verific numarul de coloane
SELECT (lcAliasC)
lnnrcolC=FCOUNT()
lnNrTagC=TAGCOUNT()

SELECT FisierSursa
lnNrColS=FCOUNT()
lnNrTagS=TAGCOUNT()

IF lnNrcolC!=lnNrcolS
	USE IN FisierSursa
	RETURN lnDifferentColumns
ENDIF

*** verific daca am aceleasi coloane

SELECT FisierSursa
FOR i=1 TO lnNrColS

	lcFieldName=FIELD(i)
	lcFieldTypeS=TYPE(lcFieldName)
	lcFieldC=lcAliasC+"."+lcFieldName
	lcFieldTypeC=TYPE(lcFieldC)
	
	lnSizeS =  FSIZE(lcFieldName)
	lnSizeC = FSIZE(lcFieldName,lcAliasC)
	
	IF lcFieldTypeC="U" OR lcFieldTypeC!=lcFieldTypeS  OR lnSizeS!=lnSizeC&& nu exista campul sau exista dar au tipuri diferite sau au dimensiune diferita
		USE IN FisierSursa
		SELECT (lcOldAlias)
		RETURN lnDifferentColumns	
	ENDIF
	
	SELECT FisierSursa
ENDFOR 

*** verific daca am acelasi nr de taguri
IF lnNrTagC!=lnNrTagS
	USE IN FisierSursa
	SELECT (lcOldAlias)
	RETURN lnDifferentTags		
ENDIF 

*** verific daca am aceleasi taguri
SELECT FisierSursa
FOR i=1 TO lnNrTagS
	lcTagS=TAG(i)
	
	SELECT (lcAliasC)
	lcTagC=TAG(i)
	IF lcTagC!=lcTagS
		USE IN FisierSursa
		SELECT (lcOldAlias)
		RETURN lnDifferentTags	
	ENDIF
	SELECT FisierSursa
ENDFOR 


USE IN FisierSursa
SELECT (lcOldAlias)
RETURN lnOK	


ENDPROC && compara_tabele

***----------------------------------------------------------------
*!*	get_text("parteneri","id","partener",id_partD)
FUNCTION get_text
PARAMETERS tcAlias1,tcField1,tcField2,tcField3

PRIVATE lcOldAlias,lcField3,lcret
lcRet=""
lcoldalias=ALIAS()
*!*	IF !EMPTY(tcAlias2)
*!*		SELECT (tcalias2)
*!*	ENDIF 
lcfield3=tcfield3
*WAIT WINDOW tcfield3+STR(lcfield3)
SELECT (tcAlias1)
*LOCATE FOR &tcField1=lcField3
IF SEEK(lcfield3,tcalias1,tcField1)
	lcret=&tcField2
ENDIF 
SELECT (lcOldAlias)
RETURN lcRet

ENDFUNC && get_text

*-----------------------------------


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 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

***-------------------------------------------------------------------------------------------
*** Creeaza o lista dintr-un cursor, la coloane de tip caracter, incadreaza itemii cu apostrof
PROCEDURE cursor2listac
	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, llChar

	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
		llChar = (TYPE(lcColumn) = 'C')
		IF TYPE(lcColumn) # 'U'
			SELECT * FROM (tcCursor) INTO CURSOR crsListaTemp
			
			SELECT crsListaTemp
			SCAN FOR &lcFilter
				lcLista = m.lcLista + IIF(m.llChar, ['], []) + ALLTRIM(TRANSFORM(EVALUATE(tcColumn))) + IIF(m.llChar, ['], []) + m.lcSeparator
			ENDSCAN 
			USE IN crsListaTemp

			IF !EMPTY(lcLista)
				lcLista = LEFT(lcLista, LEN(lcLista) - 1)
			ENDIF 			
		ENDIF 	
		

		SELECT (lcSelect)
	ENDIF 	
	
	RETURN lcLista	

ENDPROC && cursor2listac

***-------------------------------------------------------------------------------------------
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
***-----------------------------------------------------------


*******************************************************************
* 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 tcCursorSource, tcCursorDest
	
	LOCAL lcSelect, i, lcAlias, lcLista
	lcLista = []
	lcSelect = SELECT()
	lcAlias = m.tcCursorSource
	
	SELECT (lcAlias)
	lnFields = FCOUNT()
	FOR i = 1 TO lnFields
		lcField = FIELD(i)
		* lista doar cu campurile comune
		IF !EMPTY(m.tcCursorDest) AND TYPE(m.tcCursorDest + '.' + m.lcField) = 'U'
			LOOP 
		ENDIF 		
		lcLista = m.lcLista + [,] + m.lcField
	ENDFOR 
	IF !EMPTY(m.lcLista)
		lcLista = SUBSTR(m.lcLista,2)
	ENDIF

	SELECT (m.lcSelect)
	RETURN m.lcLista
	
ENDFUNC && Lista_Campuri
***----------------------------------------

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
***------------------------------------------------------

PROCEDURE findCriteriu
PARAMETERS tacriterii,nCriteriu
EXTERNAL ARRAY tacriterii

FOR n = 1 TO ALEN(tacriterii,0)
	IF tacriterii(n,6)=nCriteriu
		lnNumar=n
	ENDIF
ENDFOR
	RETURN lnNumar
ENDPROC



#IF .F.
	*!* VERIFICARE CloneObj
	Local loRecS, loRecD
	Local loRecS As Custom
	loRecS = Createobject("custom")
	loRecS.Tag = 'TEST S'

	loRecD = CloneObj(loRecS)
	loRecD.Tag = 'TEST D'

	Messagebox(loRecS.Tag + ' ' + loRecD.Tag)

	*!* VERIFICARE CopyProps
	loRecS = Createobject("empty")
	ADDPROPERTY(loRecS,"myProperty", "CUSTOMPROPERTY")

	loRecD = Createobject("custom")
	loRecD.Tag = 'TAG D'
	ADDPROPERTY(loRecD,"myProperty", "")


	CopyProps (loRecS, loRecD, .F.)
	Messagebox(loRecD.Tag + ' ' + loRecD.myProperty)
#ENDIF 

*!* COPIAZA PROPRIETATILE UNUI OBIECT SURSA IN OBIECTUL DESTINATIE
*!* OBIECTUL SURSA ESTE CREAT
*!* NU COPIAZA PROPRIETATILE/VALORILE DE TIP OBIECT (EX: COLLECTION)
Procedure CloneObj (toSource)
	Local laProps[1],lnPropCount,loDest,i, lcProperty, luValue
	Local loEx As Exception

	If Type('toSource.Class')='C' And Type('toSource.ClassLibrary')='C'
		loDest = Newobject(toSource.Class,toSource.ClassLibrary)
	Else
		loDest = Createobject('EMPTY')
	Endif

	lnPropCount = Amembers(laProps,toSource,0)
	For i = 1 To m.lnPropCount
		lcProperty = laProps[m.i]
		luValue = Null

		Try
			luValue = Getpem(toSource, lcProperty)
		Catch To loEx When loEx.ErrorNo = 1924 && "name" is not an object (Error 1924)
			*
		Endtry
		If !Pemstatus(loDest, lcProperty, 5)
			AddProperty(loDest, lcProperty, luValue)
		Else
			Try
				loDest.&lcProperty = luValue
			Catch To loEx When loEx.ErrorNo = 1743 && Property "name" is read-only (Error 1743)
				*
			Endtry
		Endif
	Endfor

	Return loDest
ENDPROC && CloneObj 

*!* COPIAZA PROPRIETATILE UNUI OBIECT SURSA IN OBIECTUL DESTINATIE 
*!* tlAddProperty : T daca se adauga proprietatile noi din sursa in destinatie, .F. se copie doar proprietatile existente (Default .F.)
Procedure CopyProps (toSource, toDest, tlAddProperty)
	Local laProps[1],lnPropCount,loDest,i, lcProperty, luValue
	Local loEx As Exception
	LOCAL llAddProperty

	IF TYPE('toSource') <> 'O' OR TYPE('toDest') <> 'O'
		RETURN
	ENDIF 
	
	IF PCOUNT() < 3 OR TYPE('tlAddProperty') <> 'L'
		llAddProperty = .F.
	ELSE 
		llAddProperty = tlAddProperty 
	ENDIF 	

	lnPropCount = Amembers(laProps,toSource, 0)
	For i = 1 To m.lnPropCount
		lcProperty = laProps[m.i]
		luValue = Null

		Try
			luValue = Getpem(toSource, lcProperty)
		Catch To loEx When loEx.ErrorNo = 1924 && "name" is not an object (Error 1924)
			LOOP && NU MAI SETEZ PROPRIETATEA DACA IMI DA EROARE
		ENDTRY
		
		If !Pemstatus(toDest, lcProperty, 5)
			IF llAddProperty
				AddProperty(toDest, lcProperty, luValue)
			ENDIF 	
		Else
			Try
				toDest.&lcProperty = luValue
			Catch To loEx When loEx.ErrorNo = 1743 && Property "name" is read-only (Error 1743)
				*
			Endtry
		Endif
	Endfor
ENDPROC && CopyProps 

PROCEDURE debug_start_eventtracking
	LOCAL lcDebug_eventlog
	lcDebug_eventlog = gcAppPath + FORCEEXT("event_" + TTOC(DATETIME(),1),"log")


	*-- load the events to track
	SET EVENTLIST TO AfterRowColChange,;
			BeforeRowColChange,;
			Click,;
			DblClick,;
			Delete,;
			Deleted,;
			Destroy,;
			Error,;
			ErrorMessage,;
			GotFocus,;
			Init,;
			InteractiveChange,;
			keyPress,;
			Load,;
			LostFocus,;			
			ProgrammaticChange,;
			Valid,;
			When

	SET EVENTTRACKING TO (lcDebug_eventlog)
	SET EVENTTRACKING ON

ENDPROC && debug_start_eventtracking

PROCEDURE debug_end_eventtracking
	SET EVENTTRACKING TO         && Closes the log file!
	SET EVENTTRACKING OFF
ENDPROC && debug_end_eventtracking