romfast/roacontracte
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
50c98bb951cdd123edcf0eefd8bd4cc973cfee71
roacontracte/Programe/proceduri.prg
Marius Mutu 7cc3bff358 Initial: flux text FoxBin2Prg (git urmareste .??2 in-arbore, binarele VFP git-ignored) 
Inrolare ROACONTRACTE conform COMUN\docs\inrolare-proiect-git-text.md:
- .gitignore/.gitattributes dupa modelul ROACONT (COMUN/ exclus, are repo propriu)
- 439 texte FoxBin2Prg generate in arbore (vc2/sc2/fr2/mn2/pj2/db2)
- Clase\registry.vcx ramane binar: memo .vct corupt (Error 41), nu se poate converti
- Clase\ferestre_contracte.vcx: text generat, roundtrip scutit (fara write-back)
- CLAUDE.md, docs/README.md, roa_sync.bat

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_01RYbiinqXxdEqXi53x4Ro7K
2026-08-03 01:51:36 +03:00

936 lines
22 KiB
Plaintext
Raw Blame History

*-----------------------------------------------
Function existacamp
Param numef,numec
Sele &numef
For i=1 To Fcount()
If Upper(Allt(Field(i)))=Upper(Allt(numec))
Return .T.
Endif
Next
Return .F.
*-----------------------------------------------
Function existacimp
Param numef,numec
Sele &numef
For i=1 To Fcount()
If Upper(Allt(Field(i)))=Upper(Allt(numec))
Return .T.
Endif
Next
Return .F.
***-----------------------------------------------------------------------------------------------------------------
Procedure CAUT_ALF
Parameters NUMEBAZA,NUMECIMP,CAPTEXT,VARMEM
Local MC0,MC1,MC2
Set Safety Off
MC0='SELE '+NUMEBAZA
MC1='VARMEM=M.'+NUMECIMP
MC2='SET order TO TAG '+NUMECIMP
&MC0
Go Top
If Eof()
Appe Blank
Endif
&MC2
OCA=Createobject("CAUTALF")
OCA.Caption=CAPTEXT
OCA.GRID1.RecordSource=NUMEBAZA
OCA.GRID1.COLUMN1.ControlSource=NUMECIMP
OCA.Show(1)
Scatter Memvar
&MC1
Return
***-----------------------------------------------------------------------------------------------------------------
Procedure CAUT_ALFa
Parameters NUMEBAZA,NUMECIMP,CAPTEXT,VARMEM
Local MC0,MC1,MC2
Set Safety Off
MC0='SELE '+NUMEBAZA
MC1='VARMEM=M.'+NUMECIMP
MC2='SET order TO TAG '+NUMECIMP
&MC0
Go Top
If Eof()
Appe Blank
Endif
&MC2
OCA=Createobject("CAUTALFa")
OCA.Caption=CAPTEXT
OCA.GRID1.RecordSource=NUMEBAZA
OCA.GRID1.COLUMN1.ControlSource=NUMECIMP
OCA.cmdrenunt1.Visible=.T.
OCA.Show(1)
Scatter Memvar
&MC1
Return
***-----------------------------------------------------------------------------------------------------------------
Procedure mesaj
Parameters m1,m2
ot=Create('text')
ot.label2.Caption=m1
ot.label3.Caption=m2
ot.Show(1)
Return
***-----------------------------------------------------------------------------------------------------------------
Procedure mesajval
Parameters m1,m2
ot=Create('textval')
ot.label2.Caption=m1
ot.valoare=m2
ot.Show(1)
Return
***-----------------------------------------------------------------------------------------------------------------
Procedure mesajatent
Parameters m1,m2
ot=Create('atentie')
ot.label2.Caption=m1
ot.label3.Caption=m2
ot.Show(1)
Return
***-----------------------------------------------------------------------------------------------------------------
Procedure mesajrosu
Parameters m1,m2
ot=Create('atentierosu')
ot.label2.Caption=m1
ot.label3.Caption=m2
ot.Show(1)
Return
***-----------------------------------------------------------------------------------------------------------------
Procedure alfabeta
Parameters clasa,e5,b5,C5,e6,b6,C6,e7,b7,c7,expl
m.explicatia=expl
clasaact='actverif'
oc=Create(clasa)
With oc
.eti5=e5
.eti6=e6
.eti7=e7
.baza5=b5
.baza6=b6
.baza7=b7
.cimp5=C5
.cimp6=C6
.cimp7=c7
.num=C5
.num2=C6
.expl=c7
Endwith
If expl='do curs.spr'
oc.expl=expl
Endif
If txt2=.F.
m.FDOC="FACTURA"
oc.text2.Enabled=.F.
* oc.text2.controlsource="FACTURA"
Endif
oc.Show(1)
Return
***-----------------------------------------------------------------------------------------------------------------
Procedure alfabetaper
Parameters clasa,e5,b5,C5,e6,b6,C6,e7,b7,c7,expl,cumpvanz
m.explicatia=expl
clasaact='actverif'
oc=Create(clasa)
With oc
.eti5=e5
.eti6=e6
.eti7=e7
.baza5=b5
.baza6=b6
.baza7=b7
.cimp5=C5
.cimp6=C6
.cimp7=c7
.num=C5
.num2=C6
.expl=c7
.cv=cumpvanz
Endwith
oc.Show(1)
Return
***-----------------------------------------------------------------------------------------------------------------
*!* Procedure IESIRE
*!* *close tables
*!* *close database
*!* *set defa to &dirgen
*!* *erase actactan.*
*!* *erase ?temp.*
*!* Quit
*!* Return
***-----------------------------------------------------------------------------------------------------------------
Procedure mesajm
Param txt,i
Local T,p
p=Iif(i<10,Str(i,1),Str(i,2))
T='orm.label'+p+'.caption="'+txt+'"'
&T
If i<20
i=i+1
Endif
p=Iif(i<10,Str(i,1),Str(i,2))
T='orm.IMAGE'+p+'.VISIBLE=.T.'
&T
Return
***-----------------------------------------------------------------------------------------------------------------
Func ULTIMAZIL
Param LLL,AAA
Local N
Do Case
Case Inlist(LLL,1,3,5,7,8,10,12)
N=31
Case Inlist(LLL,4,6,9,11)
N=30
Case Inlist(LLL,2)
N=28
If Mod(AAA,2)=0
N=29
Endif
Endcase
Return N
***-----------------------------------------------------------------------------------------------------------------
Function SERIA_LUNARA_E_CORECTA
Local TIPAR,LOC,L
L=Val(M.NL)
LOC=L+Floor((L-1)/2)
TIPAR='VOICUIONEMIL'
Sele cul
Go Top
&&ESTE CORECTA ULTIMA SERIE?
If Substr(TIPAR,L,1)=Substr(GREEN,LOC,1);
AND Substr(red,1,1)=Substr(GREEN,3,1);
AND Substr(red,2,1)=Substr(GREEN,6,1);
AND Substr(red,3,1)=Substr(GREEN,9,1);
AND Substr(red,4,1)=Substr(GREEN,12,1);
AND Substr(red,5,1)=Substr(GREEN,15,1)
Return .T.
Else
Return .F.
Endif
***-----------------------------------------------------------------------------------------------------------------
Function e_ultima_luna
Sele calendar
Loca For m.NL=NL And m.an=an
Skip
If Eof()
ultima_luna=.T.
Return .T.
Else
ultima_luna=.F.
Return .F.
Endif
***-----------------------------------------------------------------------------------------------------------------
Procedure danu
Parameters m1
od=Create('danu')
od.label1.Caption=m1
od.Show(1)
Return
***-----------------------------------------------------------------------------------------------------------------
Procedure danuquit
Parameters m1
od=Create('danu')
od.label1.Caption=m1
od.Show(1)
If buton=2
Quit
Endif
Return
***-----------------------------------------------------------------------------------------------------------------
Proc pr
Param j
If j>M
OP.Release
OP=Crea('progresbar')
j=0
OP.Show()
Endif
OP.PRBAR.Value=j
OP.p=Round(100*OP.PRBAR.Value/OP.PRBAR.Max,2)
OP.Refresh
j=j+1
Return
***-----------------------------------------------------------------------------------------------------------------
Proc MESAJT
Param M.denumire
OTEXT.oleTreeview.NODES.Add(,,,M.denumire,)
STARE=STARE+1
Return
***-----------------------------------------------------------------------------------------------------------------
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
***-----------------------------------------------------------------------------------------------------------------
Procedure inchidprog
Local CC,M.NUMESTATIE,UU
Return
UU=utilizator
If !Used('OPTIUNI')
Return
Endif
Sele OPTIUNI
Loca For OPTIUNE='RETEA'
If !Found() Or (Found() And !DA)
Sele OPTIUNI
Use
Return
Endif
Sele OPTIUNI
Use
If !File('C:\CONTAFIN\TEMP\RETEA.DBF')
Return
Endif
Sele 0
Use C:\CONTAFIN\TEMP\RETEA Shar Alias RETEA
m.NUMESTATIE=Allt(NUMESTATIE)
CC=DIRGEN
Use
If File('&DIRGEN\Dateretea\istoric.DBF')
Sele 0
Use &DIRGEN\Dateretea\istoric Share Alias istoric
Else
Sele 0
Use &CC\START2000\Data\istoric Share Alias istoric
Endif
Sele istoric
Set Order To DATAORAINT
Loca For Empty(dataoraies) And Allt(statie)=m.NUMESTATIE And Allt(utilizator)=Allt(UU)
If Found()
If Flock()
Repl dataoraies With Datetime()
Unlock
Endif
Endif
Sele istoric
Use
If File('&DIRGEN\Dateretea\activ.DBF')
Sele 0
Use &DIRGEN\Dateretea\Activ Share Alias Activ
Else
Sele 0
Use &CC\START2000\Data\Activ Share Alias Activ
Endif
Sele Activ
Loca For Allt(statie)=m.NUMESTATIE
If !Found()
Wait Wind 'Aceasta statie nu este inregistrata in server!'
Else
Sele Activ
If Flock()
Repl DEVIZE With .F.
Endif
Unlock
Endif
Sele Activ
Use
Return
***-----------------------------------------------------------------------------------------------------------------
Proc gendinante
Sele ORDante
Set Filter To
Sele CLIE
Set Filter To
Sele ORDante.*,CLIE.* From ORDante,CLIE Where ORDante.codc=CLIE.codc Into Cursor cliord Order By DATAI
ovs=Crea('selante')
ovs.Show(1)
Return
***-----------------------------------------------------------------------------------------------------------------
Procedure AFISNOTEPAD
Param NUMEFIS
Do Case
Case File('C:\WINDOWS\NOTEPAD.EXE')
Run /N C:\Windows\NOTEPAD.Exe &NUMEFIS
Case File('C:\WINnt\system32\NOTEPAD.EXE')
Run /N C:\WINnt\system32\NOTEPAD.Exe &NUMEFIS
Otherwise
Do mesajatent With 'Nu se poate vizualiza textul','pe acest sistem!'
Endcase
***-----------------------------------------------------------------------------------------------------------------
Procedure SCRIETEXT
Param NUMEFIS,TEXTUL
Set Textmerge To &NUMEFIS Additive Noshow
TEXT
<<TEXTUL>>
ENDTEXT
Return
Endproc && SCRIETEXT
***-----------------------------------------------------------------------------------------------------------------
Procedure INITTEXT
Param NUMEFIS
Set Textmerge To &NUMEFIS
Set Textmerge On Noshow
Return
***-----------------------------------------------------------------------------------------------------------------
Procedure SFTEXT
Set Textmerge To
Set Textmerge Off
Return
***-----------------------------------------------------------------------------------------------------------------
Procedure adaugtext
Param fisierul,TEXTUL
Wait Wind TEXTUL Nowait
Set Textmerge On
Set Textmerge Noshow
Set Textmerge To &fisierul Additive
\<<textul>>
Set Textmerge To
Return
***-----------------------------------------------------------------------------------------------------------------
Procedure errq
Do mesaj With 'Pentru moment accesul nu este posibil','Incercati mai tarziu.'
errq=.T.
Return
***-----------------------------------------------------------------------------------------------------------------
*!* Function SUMA_IN_VORBE
*!* Param suma
*!* Local i,lit,numar1
*!* Store 0 To i
*!* Store '' To lit,numar1
*!* numar1=Space(12)
*!* numar1=Str(suma,12)
*!* Dimension A(12)
*!* A(1)=Subs(numar1,12,1)
*!* A(2)=Subs(numar1,11,1)
*!* A(3)=Subs(numar1,10,1)
*!* A(4)=Subs(numar1,9,1)
*!* A(5)=Subs(numar1,8,1)
*!* A(6)=Subs(numar1,7,1)
*!* A(7)=Subs(numar1,6,1)
*!* A(8)=Subs(numar1,5,1)
*!* A(9)=Subs(numar1,4,1)
*!* A(10)=Subs(numar1,3,1)
*!* A(11)=Subs(numar1,2,1)
*!* A(12)=Subs(numar1,1,1)
*!* Sele mila1
*!* *********************
*!* Loca For NR=Val(A(12))
*!* lit=lit+Alltri(cr1)
*!* If Val(A(11))=1
*!* If Val(A(10))=0
*!* Loca For NR=Val(A(11))
*!* lit=lit+Alltri(cr5)
*!* Else
*!* Loca For NR=Val(A(10))
*!* lit=lit+Alltri(cr4)
*!* Endif
*!* Else
*!* If Val(A(10))=0
*!* Loca For NR=Val(A(11))
*!* lit=lit+Alltrim(cr5)
*!* Else
*!* Loca For NR=Val(A(11))
*!* lit=lit+Alltrim(cr2)
*!* Loca For NR=Val(A(10))
*!* lit=lit+Alltrim(cr3)
*!* Endif
*!* Endif
*!* Do Case
*!* Case Val(A(12)) # 0
*!* lit=lit+' miliarde'
*!* Case Val(A(11)) # 0
*!* lit=lit+' miliarde'
*!* Case Val(A(10)) # 0
*!* lit=lit+' miliarde'
*!* Endcase
*!* ***********************
*!* Loca For NR=Val(A(9))
*!* lit=lit+Alltri(cr1)
*!* If Val(A(8))=1
*!* If Val(A(7))=0
*!* Loca For NR=Val(A(8))
*!* lit=lit+Alltri(cr5)
*!* Else
*!* Loca For NR=Val(A(7))
*!* lit=lit+Alltri(cr4)
*!* Endif
*!* Else
*!* If Val(A(7))=0
*!* Loca For NR=Val(A(8))
*!* lit=lit+Alltrim(cr5)
*!* Else
*!* Loca For NR=Val(A(8))
*!* lit=lit+Alltrim(cr2)
*!* Loca For NR=Val(A(7))
*!* lit=lit+Alltrim(cr3)
*!* Endif
*!* Endif
*!* Do Case
*!* Case Val(A(9)) # 0
*!* lit=lit+' milioane'
*!* Case Val(A(8)) # 0
*!* lit=lit+' milioane'
*!* Case Val(A(7)) # 0
*!* lit=lit+' milioane'
*!* Endcase
*!* ***********************
*!* Loca For NR=Val(A(6))
*!* lit=lit+Alltri(cr1)
*!* If Val(A(5))=1
*!* If Val(A(4))=0
*!* Loca For NR=Val(A(5))
*!* lit=lit+Alltri(cr5)
*!* Else
*!* Loca For NR=Val(A(4))
*!* lit=lit+Alltri(cr4)
*!* Endif
*!* Else
*!* If Val(A(4))=0
*!* Loca For NR=Val(A(5))
*!* lit=lit+Alltrim(cr5)
*!* Else
*!* Loca For NR=Val(A(5))
*!* lit=lit+Alltrim(cr2)
*!* Loca For NR=Val(A(4))
*!* lit=lit+Alltrim(cr3)
*!* Endif
*!* Endif
*!* Do Case
*!* Case Val(A(6)) # 0
*!* lit=lit+' mii'
*!* Case Val(A(5)) # 0
*!* lit=lit+' mii'
*!* Case Val(A(4)) # 0
*!* lit=lit+' mii'
*!* Endcase
*!* *********************
*!* Loca For NR=Val(A(3))
*!* lit=lit+Alltri(cr1)
*!* If Val(A(2))=1
*!* If Val(A(1))=0
*!* Loca For NR=Val(A(2))
*!* lit=lit+Alltri(cr5)
*!* Else
*!* Loca For NR=Val(A(1))
*!* lit=lit+Alltri(cr4)
*!* Endif
*!* Else
*!* If Val(A(1))=0
*!* Loca For NR=Val(A(2))
*!* lit=lit+Alltrim(cr5)
*!* Else
*!* Loca For NR=Val(A(2))
*!* lit=lit+Alltrim(cr2)
*!* Loca For NR=Val(A(1))
*!* lit=lit+Alltrim(cr3)
*!* Endif
*!* Endif
*!* Do Case
*!* Case Val(A(3)) # 0
*!* lit=lit+' lei'
*!* Case Val(A(2)) # 0
*!* lit=lit+' lei'
*!* Case Val(A(1)) # 0
*!* lit=lit+' lei'
*!* Endcase
*!* Sele mila1
*!* *!* use
*!* lit=Strtran(lit,' ','')
*!* Return lit
***-----------------------------------------------------------------------------------------------------------------
Procedure LIST_EXCEL
Param TTABEL,TTITLU,TAHEADER
External Array TAHEADER
LCFIS=Allt(LOC)+"\"+Allt(NFSCURT)+"\TEMPO\LIST_"+Sys(2)+".XLS"
LCFIS=Strtran(LCFIS,'\\','\')
Set Textmerge On To (LCFIS) Noshow
LCANTET=Uppe(Allt(TTITLU))+crlf
\
\\<<LCANTET>>
\
If Parameters()<3
LCHEADER=""
Sele (TTABEL)
For i=1 To Fcount()
LCHEADER=LCHEADER+Upper(Allt(Field(i)))+Tab
Endfor
LCHEADER=LCHEADER+crlf
\\<<LCHEADER>>
Sele (TTABEL)
Scan
LDATE=""
For i=1 To Fcount()
F=Field(i)
T=&F
LDATE=LDATE+Transform(T,"")+Tab
Endfor
LDATE=LDATE+crlf
\\<<LDATE>>
Endscan
Set Textmerge To
Else
LCHEADER=""
NRCOL=Alen(TAHEADER,1)
Sele (TTABEL)
For i=1 To NRCOL
If Empty(TAHEADER[I,1])
LCHEADER=LCHEADER+Upper(Allt(TAHEADER[I,2]))+Tab
Else
LCHEADER=LCHEADER+Upper(Allt(TAHEADER[I,1]))+Tab
Endif
Endfor
LCHEADER=LCHEADER+crlf
\\<<LCHEADER>>
Sele (TTABEL)
Scan
LDATE=""
For i=1 To NRCOL
* F=Field(TAHEADER[I,2])
F=TAHEADER[I,2]
* IF EXISTACAMP(,F)
T=&F
LDATE=LDATE+Alltrim(Transform(T,""))+Tab
* ELSE
* LDATE=LDATE+" "+Tab
* ENDIF
Endfor
LDATE=LDATE+crlf
\\<<LDATE>>
Endscan
Set Textmerge To
Endif
* WAIT WINDOW "Se deschide Excel..." NOWAIT
OEXCEL = Createobject("Excel.Application")
OEXCEL.WorkBooks.Open(LCFIS)
OEXCEL.Visible=1
*!* IF TYPE(OEXCEL)='0'
*!* OEXCEL=""
*!* ENDIF
Endproc && list_excel
*__________________________________________________________
&& 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&&,tTipField
*WAIT WINDOW TALIAS
*ON error Errorh(ERROR(),PROGRAM(),LINENO())
LLLOOKUP=Iif(Type("tfield")="C",.T.,.F.)
LLChar = 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
If LLChar
LCAUT="LOCATE FOR "+Allt(TFIELD)+"='"+Allt(Str(LNCOUNTERVAL))+"'"
Else
LCAUT="LOCATE FOR "+Allt(TFIELD)+"="+Allt(Str(LNCOUNTERVAL))
Endif
*** 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
***-------------------------------------------------------------------------------------------------------
*-------------------------------------------------------------------------------------------
*** 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 * From calendar Into Cursor tsel_luna Order By an Desc ,NL Desc
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
***-----------------------------------------------------------------------------------------------------------------
*!* 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 caut_alfa_cursor
Parameters NUMEBAZA,NUMECIMP,CAPTEXT,VARMEM
Local MC0,MC1,MC2, llVizibil
Set Safety Off
llVizibil = .T.
MC0='SELE '+NUMEBAZA
MC1='VARMEM=M.'+NUMECIMP
*MC2='SET order TO TAG '+NUMECIMP
MC2 = [INDEX ON ] +NUMECIMP+ [ TAG nume OF &loc\&nfscurt\tempo\xindex.idx COMPACT ASCENDING ]
*!* &MC0
*!* &MC2
*!* GO TOP
Local lcNumeCol2
Store '' To lcNumeCol2
LcCol = Alltrim(NUMEBAZA) + '.cod_fiscal'
If Type(LcCol) # 'U'
lcNumeCol2 = 'cod_fiscal'
Endif
LcCol = Alltrim(NUMEBAZA) + '.gest'
If Type(LcCol) # 'U'
lcNumeCol2 = 'gest'
Endif
LcCol = Alltrim(NUMEBAZA) + '.id_sectie'
If Type(LcCol) # 'U'
lcNumeCol2 = 'id_sectie'
Endif
If Empty(lcNumeCol2)
lcNumeCol2 = 'space(4)'
llVizibil = .F.
Endif
LcCol = Alltrim(NUMEBAZA) + '.id'
If Type(LcCol) # 'U'
lcNumeCol3 = 'id'
Else
lcNumeCol3 = 'space(4)'
Endif
Select Distinct &NUMECIMP, &lcNumeCol2, &lcNumeCol3 From (NUMEBAZA) Into Cursor tnomenclator Readwrite Order By &NUMECIMP
OCA=Createobject("CAUTALFa")
OCA.Caption=CAPTEXT
OCA.GRID1.RecordSource='tnomenclator'
OCA.GRID1.COLUMN1.ControlSource = NUMECIMP
OCA.GRID1.COLUMN2.ControlSource = lcNumeCol2
OCA.GRID1.COLUMN2.Visible = llVizibil
OCA.cmdrenunt1.Visible=.T.
OCA.command1.Visible=.F.
OCA.command2.Visible=.F.
OCA.command3.Visible=.F.
OCA.Show(1)
*!* &MC0
*!* SCATTER MEMVAR
*!* SET FILTER TO
If buton=2
Use In tnomenclator
Return
Endif
lcFile = Addbs(gcTempPath) + 'xindex.idx'
If File(lcFile)
Set Index To
Delete File &lcFile
Endif
*!* &MC1
Select tnomenclator
Scatter Memvar
&MC1
Use In tnomenclator
Return
***-----------------------------------------------------------------------------------------------------------------
Reference in New Issue View Git Blame Copy Permalink