1676 lines
41 KiB
Plaintext
1676 lines
41 KiB
Plaintext
*!* 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
|