romfast/roacontracte
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
main
roacontracte/Programe/roacontracte.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

1065 lines
28 KiB
Plaintext
Raw Permalink Blame History

Parameters tparam
Local lchost, lcUserName, lcPassword, lnIdUtil, lnIdProgram, lcUserNameApp,lcPasswordApp
Store '' To lchost, lcUserName, lcPassword, lcUserNameApp,lcPasswordApp
Store 0 To lnIdUtil, lnIdProgram
Public gcNumeProgram
gcNumeProgram = "ROACONTRACTE"
If !Like(gcNumeProgram + '*', Upper(Alltrim(Juststem(Sys(16,0)))))
Messagebox("Nu puteti porni acest program!",0+16,"Atentie")
Return
Endif
_Screen.Icon=gcNumeProgram+'.ico'
Set Century On
Set Deleted On
Set Date To Dmy
Set Exclusive Off
Set Cpdialog Off
Set Talk Off
Set Safety Off
Set Escape Off
Set Exact On
Set Mark To '/'
Set Ansi On
Set Console Off
Set Notify Off
Set Seconds Off
Set NullDisplay To ''
Set Decimals To 4
_Screen.Visible=.F.
_Screen.AutoCenter=.T.
SET HOURS TO 24
*VARIABILE_______
Local lcMainClassLib
Local lcLastSetTalk,lcLastSetPath,lcLastSetClassLib,lcOnShutdown
*VARIABILE__________________________________________________________________________
Declare nror[65000]
Declare RTVA[22,2]
Public CRLF,CR,LF,Tab
Store Chr(13) + Chr(10) To CRLF
Public pcNl,pcAn
Store "" To pcNl,pcAn && se initializeaza in start00
CR=Chr(13)
LF=Chr(10)
Tab=Chr(9)
Public pcTitlu,pl_verificat
Store "" To pcTitlu
Store .F. To pl_verificat
Public BUTON, luna_inchisa, luna_neplatita, PRIMADATA, m.ctva, m.ctvam, m.ctvai, antet, m.nivel
Public OStart,OSETVIZ,OSETTULBAR,OSETINSTRUM,orm,OTEXT,OJUR,osetgest,tlbr_INSTR,tlbr_VIZ,oprinc,DIRGEN
Public pcapsocsub,pcapsocvar
pcapsocsub=0
pcapsocvar=0
Public a4
a4=.T.
m.nrgrup=999
Store .F. To luna_inchisa,tlbr_INSTRum,tlbr_VIZ
Store 1 To BUTON,col_menu
Store .T. To PRIMADATA,luna_neplatita
*** DECLARATII DE VARIABILE PUBLICE
**********************************************************************************************
*-- Save and configure environment.***********************
lcLastSetTalk=Set("TALK")
Set Talk Off
lcLastSetPath=Set("PATH")
Public gcAppPath,gcAppName,gcTempPath, gcCaleServerDate, gcUserNameApp, gcPasswordApp,gcDirMare, gcBasePath
Store '' To gcUserNameApp, gcPasswordApp, gnNivelUtilizator, gnGrupUtilizator, gcAcces,gcDirMare, gcBasePath
Set Procedure To 'd:\roa\roacontracte\comun\utile\web\wwutils.prg' Additive
Set Procedure To 'd:\roa\roacontracte\comun\utile\web\wwapi.prg' Additive
gcAppPath=Addbs(ShortPath(GetAppStartPath()))
If Right(gcAppPath ,9)="PROGRAME\"
gcAppPath = Substr(gcAppPath ,1,Len(gcAppPath )-9)
Endif
gcAppName=Allt(Uppe(Juststem(Sys(16,0))))
Set Default To (gcAppPath)
lcPath = gcAppPath + 'Date;' + ;
gcAppPath + 'Include;' + ;
gcAppPath + 'FERESTRE;' + ;
gcAppPath + 'GRAFICE;' + ;
gcAppPath + 'Help;' + ;
gcAppPath + 'CLASE;' + ;
gcAppPath + 'MENIURI;' + ;
gcAppPath + 'PROGRAME;' + ;
gcAppPath + 'RAPOARTE;' + ;
gcAppPath + 'COMUN\PROGRAME;' + ;
gcAppPath + 'COMUN\CLASE;' + ;
gcAppPath + 'COMUN\FERESTRE;' + ;
gcAppPath + 'COMUN\GRAFICE;' + ;
gcAppPath + 'COMUN\RAPOARTE;' + ;
gcAppPath + 'COMUN\UTILE\CALENDAR;' + ;
gcAppPath + 'COMUN\UTILE\GRIDEXTRAS;' + ;
gcAppPath + 'COMUN\UTILE\CTL32;' + ;
gcAppPath + 'COMUN\UTILE\HPDF;' + ;
gcAppPath + 'COMUN\UTILE\HPDF\REPORTOUTPUT;' + ;
gcAppPath + 'COMUN\UTILE\WEB;' + ;
gcAppPath + 'COMUN\UTILE\EMAIL;' + ;
gcAppPath + 'COMUN\UTILE\EXCEL;' + ;
gcAppPath + 'COMUN\UTILE\NFJSON;' + ;
gcAppPath + 'COMUN\UTILE\NFXML;' + ;
gcAppPath + 'COMUN\UTILE\MENU;' + ;
Addbs(Substr(gcAppPath,1,Rat([\],gcAppPath,2)))+[COMUNROA\]
Set Path To (lcPath)
Push Menu _Msysmenu
lcLastSetClassLib=Set("CLASSLIB")
lcMainClassLib= gcAppPath + "COMUN\clase\appwiz.vcx"
*CLASE__________________________________________________________
Set Classlib To (lcMainClassLib) Additive
Set Classlib To CAUT Additive
Set Classlib To ooptiuni Additive
Set Classlib To accessibility Additive
Set Classlib To registry Additive
Set Classlib To decabaza Additive
Set Classlib To cauta_alfa_forms Additive
Set Classlib To ferestre_oracle Additive
Set Classlib To caut_ora Additive
Set Classlib To ferestre_contracte Additive
Set Classlib To onomenclatoare Additive
Set Classlib To ofundal Additive
Set Classlib To ofundal_roaclienti Additive
*!* messagebox in romana - ar trebui bagat intr-o librarie de utilitati
*!* messagebox.vcx, functia amessagebox in oproceduri_comune, imagini mb_*.bmp, messagebox.h
Set Classlib To Messagebox Additive
Set Classlib To otoolbar Additive
Set Classlib To ferestre_cere_date Additive
Set Classlib To orapoarte_comun Additive
* SET CLASSLIB TO outlook2003bar ADDITIVE
Set Classlib To onom_articole Additive
*Set Classlib To oparteneri ADDITIVE
SET CLASSLIB TO ofacturare_comun ADDITIVE
Set Classlib To ocriterii.vcx Additive
Set Classlib To ctl32_statusbar.vcx Additive
Set Classlib To ctl32_common.vcx Additive
Set Classlib To ctl32_structs.vcx Additive
Set Classlib To ctl32_progressbar.vcx Additive
Set Classlib To serii_numere.vcx Additive
Set Classlib To ferestre_atasamente Additive
SET CLASSLIB TO ofacturare ADDITIVE
SET CLASSLIB TO onom_curs ADDITIVE
SET CLASSLIB TO comun ADDITIVE
SET CLASSLIB TO ofacturare_rapoarte ADDITIVE
SET CLASSLIB TO wwdialogs.vcx ADDITIVE
*!* modificare v 2.0.34
SET CLASSLIB TO orapoarte_cont.vcx additive
SET CLASSLIB TO _calendar.vcx additive && v 2.1.5
Set Classlib To locale Additive && v 2.1.10
SET CLASSLIB TO gridextras.vcx ADDITIVE
SET CLASSLIB TO menutool.vcx ADDITIVE
*PROCEDURI______________________________________________________
Set Procedure To quitapp Additive
Set Procedure To init_program Additive
Set Procedure To oproceduri_comune Additive
Set Procedure To gencursor.prg Additive
Set Procedure To updateserver.prg Additive
Set Procedure To update_nomenclator.prg Additive
Set Procedure To onomenclatoare Additive
Set Procedure To oproceduri_ams Additive
Set Procedure To ocautare Additive
Set Procedure To oinit_optiuni Additive
Set Procedure To osecurity Additive
Set Procedure To proceduri Additive
Set Procedure To oproceduri_roacontracte Additive
Set Procedure To acces_meniu Additive
Set Procedure To proceduri Additive
Set Procedure To oheader Additive
Set Procedure To oparteneri_contracte Additive
Set Procedure To oproceduri_maintenance.prg Additive && modifica_id_partener
Set Procedure To proceduri_excel Additive
Set Procedure To cauta_alfa Additive
Set Procedure To ini.prg Additive
Set Procedure To wwxmlhttp.prg Additive
Set Procedure To wwutils.prg Additive
Set Procedure To wwconfig.prg Additive
Set Procedure To oexport.prg Additive
Set Procedure To oproceduri_atasamente.prg Additive
Set Procedure To oserii_numere Additive
Set Procedure To oproceduri_atasamente Additive
SET PROCEDURE TO oproceduri_facturare ADDITIVE
SET PROCEDURE TO ofacturare_comun ADDITIVE
SET PROCEDURE TO ofacturare ADDITIVE
SET PROCEDURE TO oproceduri_curs ADDITIVE
SET PROCEDURE TO ooperatii_comune ADDITIVE
SET PROCEDURE TO odocumente ADDITIVE
SET PROCEDURE TO regex.prg ADDITIVE
SET PROCEDURE TO oproceduri_rapoarte_fact ADDITIVE
SET PROCEDURE TO filebringer.prg additive
SET PROCEDURE TO iniacces.prg ADDITIVE
SET PROCEDURE TO oupdate.prg additive
SET PROCEDURE TO procese.prg additive
SET PROCEDURE TO version.prg additive
SET PROCEDURE TO wwapi.prg ADDITIVE
SET PROCEDURE TO wwcodeupdate.prg additive
SET PROCEDURE TO wwhttp.prg ADDITIVE
SET PROCEDURE TO xmlaccess.prg additive
SET PROCEDURE TO xmlparser.prg additive
*!* modificare v 2.0.34
SET PROCEDURE TO validare.prg Additive
*!* modificare v 2.0.35
SET PROCEDURE TO xdate.prg Additive
SET PROCEDURE TO suma_in_vorbe.prg additive
*!* modificare v 2.0.35 ^
SET PROCEDURE TO gridextrasprocs.prg ADDITIVE
Set Procedure To proceduri_comune Additive
SET PROCEDURE TO blat.prg ADDITIVE
SET PROCEDURE TO email.prg ADDITIVE
SET PROCEDURE TO nfxmlread.prg ADDITIVE
SET PROCEDURE TO nfxmlread.prg ADDITIVE
SET PROCEDURE TO nfjsonread.prg ADDITIVE
SET PROCEDURE TO xmlefactura.prg ADDITIVE
*----------------------------------------------------------------------------
If Pcount() = 1 And Type('tparam') = 'C'
glParametri = .T.
Private laParametri
Declare laParametri[1]
lcParam = Alltrim(tparam)
lnNr = lista2array(lcParam,@laParametri,";")
If lnNr < 6
Messagebox('Numar incorect de parametri',0+16,'Eroare')
Return
Endif
lchost = laParametri[1]
lcUserName = laParametri[2]
lcPassword = laParametri[3]
lnIdUtil = Round(Val(laParametri[4]),0)
lnIdProgram = Round(Val(laParametri[5]),0)
lnParametru_prog = Round(Val(laParametri[6]),0)
Else
glParametri = .F.
lchost = 'JCSSERVER'
lcUserName = 'CONTAFIN_ORACLE'
lcPassword = ''
lnIdUtil = 0
lnIdProgram = 0
lnParametru_prog = 0
Endif
*-------------------------------------
Public glVerificTabel && daca se verifica structura tabelelor in totv.prg
glVerificTabel=.T.
Public glQuit
glQuit = .F.
Public gnIdIstoric
gnIdIstoric = 0
*!* gcAppDataPath=gcAppPath+"Date_"+gcAppName+"\" && D:\CONTAFIN\TRANS\DATE_TRANS && PT OPTIUNI , FISIERE SPECIFICE PROGRAMULUI SI
gcUtilizatoriPath = gcAppPath + "UTILIZATORI\"
Store "" To gcTempPath, gcCaleServerDate
*!* If !Directory(gcAppDataPath)
*!* Md (gcAppDataPath)
*!* Endif
*---------------------------------------
*** DIRGEN
liat=Rat("\",gcAppPath,2)
gcDirMare = Addbs(Left(gcAppPath,liat-1)) && modificare v 2.0.34
DIRGEN = gcDirMare
gcBasePath = DIRGEN
Cd &DIRGEN
*!* 21.06.2006
*!* marius.mutu
Private gcGeneralIniFile, gcSettingsFile
gcGeneralIniFile = m.gcDirMare + "settings.ini"
gcSettingsFile = m.gcGeneralIniFile
If !File(gcGeneralIniFile)
TEXT TO lcSettings NOSHOW
[errors]
host=http://romfast.dnsalias.com:3000/errors/create_xml
ENDTEXT
Strtofile(lcSettings, gcGeneralIniFile)
Endif
*!* modificare v 2.1.10
PRIVATE gcReportPreviewer, gcReportPreviewerPath
gcReportPreviewer = "FoxyPreview" && oexport.prg
gcReportPreviewerPath = gcDirMare + "COMUNROA\"
*!* modificare v 2.1.10 ^
gcSecurityPath = m.gcDirMare + 'Security\'
gcSecurityFile = gcSecurityPath + 'ROA_SECURITY.TXT'
Private poLog,goLog && obiect pt logarea mesajelor sistemului
poLog = Newobject("Log_Mesaje","Log_Mesaje.prg")
goLog = poLog
*!* public poLog && obiect pt logarea mesajelor sistemului
*!* poLog = NEWOBJECT("Log_Mesaje","Log_Mesaje.prg")
*!* modificare v 2.1.10
Private gcLocalePath, goLocale, gcLocale
gcLocalePath = gcAppPath + "Locale\"
lcLanguage = getini(gcGeneralIniFile,"locale","lang")
llLocale= getini(gcGeneralIniFile,"locale","llocale")
If Empty(m.lcLanguage)
gcLocale = 'Romana'
Else
gcLocale = m.lcLanguage
Endif
Local lcObjLocale
If gcLocale = 'Romana'
lcObjLocale = [Locale_dummy]
Else
lcObjLocale = [Locale]
Endif
goLocale=Newobject(lcObjLocale,"Locale.vcx")
If !Empty(m.llLocale) And m.llLocale<>'0'
goLocale.llocale=.T.
Endif
Release lcObjLocale
goLocale.locale = gcLocale
*!* modificare v 2.1.10 ^
Public glQuit
glQuit = .F.
Public gnIdIstoric
gnIdIstoric = 0
Public gcAntet
Store '' To gcAntet
*!* modificare v 2.1.10
*!* If verificari()
*!* _Screen.Visible=.T.
*!* Do mesaj With "Se fac verificari programului","Va rugam reveniti"
*!* glQuit= .T.
*!* Quit
*!* Endif
*!* If !Debug_Start()
*!* lcParam=tparam
*!* If Empty(tparam) Or (Type('tParam')='C' And !verific_start(tparam,DIRGEN,gcAppName))
*!* _Screen.Visible=.T.
*!* Do mesaj With "Programul trebuie pornit doar din START",""
*!* Quit
*!* Endif
*!* Endif
*!* modificare v 2.1.10 ^
*** verificare serie permanenta
*!* modificare v 2.0.41
*!* Public tipar,SER_PERM,SER_PERI,VERSIUNE
*!* Store .F. To SER_PERM,SER_PERI
*!* modificare v 2.0.41 ^
***************************** VARIABILE ORACLE
Private goUtilizator
Private gnHandle,gnidutil,GCCODFISCAL,GCADRESA,GCNUMEFIRMA,GCMONEDA,GNDIFZILE, gcUserNameApp, gcPasswordApp
Private gnButon && variabila pentru renunt si terminat
Store 2 To gnButon
Store '' To GCCODFISCAL,GCADRESA,GCNUMEFIRMA,GCMONEDA, gcUserNameApp, gcPasswordApp, gcNivelUtilizator, gcGrupUtilizator, gcAcces
gnHandle = -1
gnidutil = 0
Private gcHost, gcUserName, gcPassword, gofundal, gnIdProgram, gnId_prg_owner, gnParametru_prog
Store 0 To gnIdProgram, gnId_prg_owner
Store 1 To gnParametru_prog && default contracte clienti (daca nu se porneste programul din roastart)
gofundal=''
Private goFirma,gnIdFirma,gcFirma,gnAn,gnLuna && ,gnPA,gnPC
&& STORE 0 TO gnPA,gnPC && nr. de zecimale afisare, calcul
Store Null To goFirma
Store 0 To gnIdFirma,gnAn,gnLuna
Store '' To gcFirma
Private glUltimaLuna,glPrimaLuna, glLunaBuna,glLuna_neplatita,glLunaInchisa
Store .F. To glUltimaLuna,glPrimaLuna, glLunaBuna,glLuna_neplatita,glLunaInchisa
***toolbar***
Private otool,ohelp
Store '' To otool,ohelp
***toolbar***
Private gcS && schema firmei
Store 'DEMO' To gcS
If Type('laparametri',1)="A"
If Alen(laParametri,1)=10
gnAn = Val(laParametri[7])
gnLuna = Val(laParametri[8]) &&lansare noua
gcS = laParametri[9]
gnIdFirma = Val(laParametri[10])
Endif
Endif
Private gcCopyRight
gcCopyRight = '<27> ROA Romfast SRL'
&& obiect global wrap pt sqlexec cu text eroare si succes
Private goExecutor, goConn
goExecutor = Createobject("oExecutor")
goConn = Createobject("oConn")
&& obiect global pentru export : frx, xls
Private goExport
goExport = Createobject("oExportConfig")
*!* 21.06.2006
*!* marius.mutu
Private goMyXMLHTTP
lcHostErrors = getini(gcGeneralIniFile,'errors','host')
goMyXMLHTTP = Createobject("MyXMLHTTP", lcHostErrors)
*!* 28.10.2008
Private pnGNnumar && poGeneratorNumere
Store 0 To pnGNnumar
&& obiect global pt luna aleasa din calendar
Private goCalendar
Store Null To goCalendar
gcHost = lchost
gcUserName = lcUserName
gcPassword = lcPassword
gcUserNameApp = lcUserNameApp
gcPasswordApp = lcPasswordApp
gnidutil = lnIdUtil
gnIdProgram = lnIdProgram
gnParametru_prog = lnParametru_prog
If Empty(gnParametru_prog)
gnParametru_prog = 1
Endif
If !glParametri
lnValid = getcrsSecurity(gcSecurityFile)
If lnValid > 0
If Used('crsHost')
Select crsHost
Go Top
gcHost = Alltrim(Host)
gcUserName = Alltrim(schema)
gcPassword = Alltrim(pwd)
Use In crsHost
Endif
Endif
Endif
*!* IF glParametri
*!* gcHost = lcHost
*!* gcUserName = lcUserName
*!* gcPassword = lcPassword
*!* gcUserNameApp = lcUserNameApp
*!* gcPasswordApp = lcPasswordApp
*!* gnIdUtil = lnIdUtil
*!* gnIdProgram = lnIdProgram
*!* ELSE
*!* gcHost = "jcsserver"
*!* gcUserName = "contafin_ORACLE"
*!* gcPassword = "123"
*!* gcUserNameApp = ''
*!* gcPasswordApp = ''
*!* gnIdUtil = 1
*!* gnIdProgram = 8
*!* ENDIF
***************************** VARIABILE ORACLE
*!* modificare v 2.0.41
*!* Use &gcAppPath\SER In 0 Alias SER Shared
*!* Select SER
*!* Go Top
*!* tipar=TIP
*!* SER_PERM=SER_PERMAN
*!* SER_PERI=SER_PERIOD
*!* VERSIUNE=VERcont
*!* MODEL_PROGRAM=MODEL
*!* Use In SER
*!* parolamea=Substr(tipar,Month(Date()),1)
*!* parolamea=parolamea+Allt(Str(Day(Date())))+Allt(Str(Month(Date())))
*!* If !_DEBUG()
*!* If SER_PERM And !verif_ser_perm()
*!* Quit
*!* Endif
*!* Endif
*!* Public cales,eserver,loc,numestatie
*!* eserver=.F.
*!* Store '' To cales,loc,numestatie
*!* modificare v 2.0.41 ^
Public NUMEPROGRAM,MENIUPROGRAM,FUNDALPROGRAM
NUMEPROGRAM = 'ROACONTRACTE'
_program='roacontracte'
lcOnShutdown="ShutDown()"
On Shutdown &lcOnShutdown
On Error ErrorHandler(Error(),Program(),Lineno())
*!*_Shell="DO Cleanup IN progs\ROACLIENTI"
*-- Instantiate application object.***************************
Release goApp
Public goApp
goApp=Createobject("wzApplication")
*-- Configure application object.*****************************
Local laVersion
Dimension laVersion(12)
If Agetfileversion(laVersion, Sys(16,0)) > 0
NUMEPROGRAM = laVersion(10)
Endif
Release laVersion
Do Case
Case gnParametru_prog = 1 && clienti
NUMEPROGRAM='ROA - CONTRACTE CLIENTI'
Case gnParametru_prog = 2 && furnizori
NUMEPROGRAM='ROA - CONTRACTE FURNIZORI'
Otherwise
NUMEPROGRAM='ROA - CONTRACTE'
Endcase
goApp.SetCaption(NUMEPROGRAM)
goApp.cStartupMenu= gcAppPath + "meniuri\roacontracte.mpr"
*!* goApp.cStartupForm=DIRGEN+"\devize\FERESTRE\FUNDAL"
goApp.cStartupForm = gcAppPath + 'comun\ferestre\frm_login.scx'
_Screen.WindowState=2
*-- Show application.
Public poCtr, goContract
Store '' To poCtr, goContract
Public podg_dg, podg_ob, podg_tf, podg_tl, podg_obs, podg_link, podg_fact, podg_garantii
* STORE '' TO podg_dg, podg_ob, podg_tf, podg_tl, podg_obs, podg_link, podg_fact
Private poCtrScadentar, poCtrFactGarant, poLink
Store '' To poCtrScadentar, poCtrFactGarant, poLink
&& folosesc gencursorul pt ca am nevoie de schema pt. DATA_rata
goApp.Show
*-- Release application.
Release goApp
*-- Restore default menu.
*!* Pop Menu _Msysmenu
*-- Restore environment.
On Error
On Shutdown
If Not lcLastSetClassLib==Set("classlib")
Release Classlib (lcMainClassLib)
Endif
If Empty(lcLastSetPath)
Set Path To
Else
Set Path To &lcLastSetPath
Endif
If lcLastSetTalk=="ON"
Set Talk On
Else
Set Talk Off
Endif
CLEANUP()
Return
* FUNCTII______________________________________________________________________
Function ErrorHandler(nError,cMethod,nLine)
Local lcErrorMsg,lcCodeLineMsg
Wait Clear
lcErrorMsg=Message()+Chr(13)+Chr(13)
lcErrorMsg=lcErrorMsg+"Method: "+cMethod
lcCodeLineMsg=Message(1)
If Between(nLine,1,10000) And Not lcCodeLineMsg="..."
lcErrorMsg=lcErrorMsg+Chr(13)+"Line: "+Alltrim(Str(nLine))
If Not Empty(lcCodeLineMsg)
lcErrorMsg=lcErrorMsg+Chr(13)+Chr(13)+lcCodeLineMsg
Endif
Endif
If Type('goMyXMLHTTP') = 'O'
lcLunaHTTP = Iif(Type('gnLuna') = 'N', Transform(gnLuna) + "/","") + Iif(Type('GNAN') = 'N', Transform(gnAn),"")
lcErrorMsgHTTP = Sys(0) + ":" + Iif(Type('GCS')='C'," " + gcS,"") + ": " + lcLunaHTTP + Chr(13) +Chr(10) + lcErrorMsg + ;
CHR(13) +Chr(10) + Chr(13) + Chr(10) + GETCALLSTACK()
lcUserName = gcUserNameApp
lcProgram = Juststem(Sys(16,0))
goMyXMLHTTP.postError(lcErrorMsgHTTP, lcUserName, lcProgram)
Endif
If AMESSAGEBOX(lcErrorMsg,17,_Screen.Caption)#1
On Error
On Shutdown
If _vfp.StartMode = 0
Debug
Suspend
Else
Quit
Endif
*!* RETURN .F.
Endif
Endfunc
Function Shutdown
*!* =End_Istoric(gnIdIstoric, Addbs(DIRGEN)+"DATERETEA\", "START_ISTORIC")
If Type("goApp")=="O" And Not Isnull(goApp)
Return goApp.OnShutDown()
Endif
Cleanup()
Quit
Endfunc
Function Cleanup
If Cntbar("_msysmenu")=7
Return
Endif
On Error
On Shutdown
Set Classlib To
Set Path To
Clear All
* Close All
Pop Menu _Msysmenu
Return
*-----------------------------------------------------
Function verif_ser_perm
Clear
Return PORNIRE()
Function PORNIRE
Set Exact On
Private calewin,calesys,checksum1,checksum2,serinreg,serdisk,file1,file2,valret,serdisktemp,ser1,ser2,key1,KEY2
Store '' To calewin,serinreg,serdisk,calesys,serdisktemp,catehd,ser1,ser2,key1,KEY2
Store 0 To checksum1,checksum2
Store .T. To valret
Declare Integer SHGetFolderPath In SHFOLDER.Dll ;
INTEGER hwndOwner, ;
INTEGER nFolder, ;
INTEGER hToken, ;
INTEGER dwFlags, ;
STRING @ pszPath
Declare Integer GetActiveWindow In WIN32API
#Define CSIDL_WINDOWS 36
#Define CSIDL_SYSTEM 37
#Define CSIDL_PROGRAMS 38
lcPath = Repl(Chr(0),261)
=SHGetFolderPath(GetActiveWindow(),CSIDL_WINDOWS,0,0,@lcPath)
calewin=Left(lcPath,At(Chr(0),lcPath)-1)
lcPath = Repl(Chr(0),261)
=SHGetFolderPath(GetActiveWindow(),CSIDL_SYSTEM,0,0,@lcPath)
calesys=Left(lcPath,At(Chr(0),lcPath)-1)
&&se verifica existenta celor trei fisiere
lcTextEroare = ""
If (Not File(calesys+'\diskserial.dll')) Or (Not File(calesys+'\getmacip.dll')) Or (Not File(calewin+'\comdir.snr'))
valret=.F.
lcTextEroare = lcTextEroare + calesys + '\diskserial.dll ' + Transform(File(calesys+'\diskserial.dll')) + ;
' ' + calesys+'\getmacip.dll' + Transform(File(calesys+'\getmacip.dll')) + ' ' + calewin+'\comdir.snr' + Transform(File(calewin+'\comdir.snr')) + Chr(13) + Chr(10)
Endif
If valret
file1=Filetostr(calesys+'\diskserial.dll')
checksum1=Sys(2007,file1)
file2=Filetostr(calesys+'\getmacip.dll')
checksum2=Sys(2007,file2)
&&severifica daca dll-urile nu au fost modificate
If (Val(checksum1) != 58755) Or (Val(checksum2) != 30476)
valret=.F.
lcTextEroare = lcTextEroare + 'checksum1 ' + checksum1 + ' checksum2 ' + checksum2 + Chr(13) + Chr(10)
Endif
Endif
&&se citesc seriile tutturor celor patru hard disk-uri posibile(pe IDE primary master,primary slave...)
&&se tine minte primul cu seria nenula-daca nu s-a putut citi seria de la nici unul se pune o serie default
&&seria default este "NUAREHAR"
If valret
Declare Integer GetSerialNumber In diskSerial.Dll Integer ,String
catehd=0
For i=0 To 3
serdisktemp=Space(40)
GetSerialNumber(i,@serdisktemp)
If (Len(Alltrim(serdisktemp))!=0) And (catehd=0)
serdisktemp=sircaracter(serdisktemp)
serdisk=serdisktemp
catehd=catehd+1
Endif
Endfor
If (Len(Alltrim(serdisk))=0)
serdisk='NUAREHAR'
Else
If ((Len(Alltrim(serdisk))>0) And (Len(Alltrim(serdisk))<8))
serdisk=serdisk+Replicate('1',8-Len(Alltrim(serdisk)))
Endif
Endif
serdisk=Substr(Alltrim(serdisk),Len(Alltrim(serdisk))-7,8)
Endif
&&se citeste din comdir.snr seria de inregistrare si se verifica egalitatea cu seria obtinuta anterior
If valret
gnFileHandle = Fopen(calewin+'\comdir.snr')
nSize = Fseek(gnFileHandle, 0, 2) && Move pointer to EOF
If nSize!=9
valret=.F.
lcTextEroare = lcTextEroare + 'nSize ' + Transform(nSize) + Chr(13) + Chr(10)
Else
= Fseek(gnFileHandle, 0, 0) && Move pointer to BOF
cString = Fread(gnFileHandle,9)
ser1=Substr(cString,1,4)
ser2=Substr(cString,5,4)
key1=Substr(cString,9,1)
KEY2=DECTOBIN(Alltrim(HEXDEC(key1)))
serinreg=decodare1(Alltrim(Upper(ser1)),KEY2)+decodare1(Alltrim(Upper(ser2)),KEY2)
If serdisk!=serinreg
valret=.F.
lcTextEroare = lcTextEroare + 'serdisk ' + serdisk + ' serinreg ' + serinreg + Chr(13) + Chr(10)
Endif
Endif
= Fclose(gnFileHandle)
Endif
seriedisk1=serdisk
serieinreg1=serinreg
On Error valret=.F.
poLog.Log('Eroare verificare serie ' + Chr(13) + Chr(10) + lcTextEroare, Program())
If Type('goMyXMLHTTP') = 'O'
If !Empty(lcTextEroare)
goMyXMLHTTP.postError('Eroare verificare serie ' + Chr(13) + Chr(10) + lcTextEroare, gcUserNameApp, Juststem(Sys(16,0)))
Endif
Endif
Return valret
*************
*************
Function decodare1
Parameters lstring,CHEIE
Local lens,poz1,poz2,POZ3,lret,LRET2,lcstring,val1,lret1
lret=''
lret1=''
LRET2=''
lcstring=Alltrim(Upper(lstring))
lens=Len(lcstring)
For i=1 To 4
poz1=Substr(lcstring,i,1)
val1=Asc(poz1)
POZ3=Substr(CHEIE,i,1)
Do Case
Case val1>=48 And val1<=57
If ((val1-47)+Int(Val(POZ3)))<=10
poz2=Chr(val1+Int(Val(POZ3)))
Else
poz2=Chr(val1+Int(Val(POZ3))-10)
Endif
Case val1>=65 And val1<=90
If ((val1-64)+2*Int(Val(POZ3)))<=26
poz2=Chr(val1+2*Int(Val(POZ3)))
Else
poz2=Chr(val1+2*Int(Val(POZ3))-26)
Endif
Endcase
LRET2=LRET2+poz2
Endfor
For i=1 To lens
poz1=Substr(LRET2,i,1)
val1=Asc(poz1)
Do Case
Case val1>=48 And val1<=57
If ((val1-47)+i)<=10
poz2=Chr(val1+i)
Else
poz2=Chr(val1+i-10)
Endif
Case val1>=65 And val1<=90
If ((val1-64)+2*i)<=26
poz2=Chr(val1+2*i)
Else
poz2=Chr(val1+2*i-26)
Endif
Endcase
lret=lret+poz2
Endfor
lens=Len(lret)
For i=1 To lens
poz1=Substr(lret,i,1)
val1=Asc(poz1)
Do Case
Case val1>=48 And val1<=57
poz2=Chr(val1+17)&& din 0-9 in A-J
Case val1>=65 And val1<=74
poz2=Chr(val1-17)&& din A-J in 0-9
Case val1>=75 And val1<=82
poz2=Chr(val1+8)&&din K-R in S-Z
Case val1>=83 And val1<=90
poz2=Chr(val1-8)&&din S-Z in K-R
Endcase
lret1=lret1+poz2
Endfor
Return lret1
***********
&&transformarea in decimal a unui caracter hexa
Function HEXDEC
Lparameters LC
Local LV
Do Case
Case LC=='0'
LV='0'
Case LC=='1'
LV='1'
Case LC=='2'
LV='2'
Case LC=='3'
LV='3'
Case LC=='4'
LV='4'
Case LC=='5'
LV='5'
Case LC=='6'
LV='6'
Case LC=='7'
LV='7'
Case LC=='8'
LV='8'
Case LC=='9'
LV='9'
Case LC=='A'
LV='10'
Case LC=='B'
LV='11'
Case LC=='C'
LV='12'
Case LC=='D'
LV='13'
Case LC=='E'
LV='14'
Case LC=='F'
LV='15'
Endcase
Return LV
****************
&&codarea binara din hexa pe patru biti
Function DECTOBIN
Parameters sc
Local lretf
Do Case
Case sc=='0'
lretf='0000'
Case sc=='1'
lretf='0001'
Case sc=='2'
lretf='0010'
Case sc=='3'
lretf='0011'
Case sc=='4'
lretf='0100'
Case sc=='5'
lretf='0101'
Case sc=='6'
lretf='0110'
Case sc=='7'
lretf='0111'
Case sc=='8'
lretf='1000'
Case sc=='9'
lretf='1001'
Case sc=='10'
lretf='1010'
Case sc=='11'
lretf='1011'
Case sc=='12'
lretf='1100'
Case sc=='13'
lretf='1101'
Case sc=='14'
lretf='1110'
Case sc=='15'
lretf='1111'
Endcase
Return lretf
***********
Function ECARACTER
Parameters strg1
Private pz,ch,lcstring,vret,lg1
Store 0 To pz,lg1
Store '' To ch,lcstring
Store .T. To vret
lcstring=Upper(strg1)
lg1=Len(lcstring)
For ind1=1 To lg1
ch=Substr(lcstring,ind1,1)
If (Not Between(Asc(ch),48,57)) And (Not Between(Asc(ch),65,90))
vret=.F.
Exit
Endif
Endfor
Return vret
************
Function sircaracter
Parameters strg1
Private pz,ch,lcstring,vret,lg1,lciesire
Store 0 To pz,lg1
Store '' To ch,lcstring,lciesire
Store .T. To vret
strg1=Strtran(strg1,Alltrim(Chr(39)),'')&&caracterul '
strg1=Strtran(strg1,Alltrim(Chr(39)),'')&&caracterul "
lcstring=Upper(Alltrim(strg1))
lg1=Len(lcstring)
For ind1=1 To lg1
ch=Substr(lcstring,ind1,1)
If Between(Asc(ch),48,57) Or Between(Asc(ch),65,90)
lciesire=lciesire+ch
Endif
Endfor
Return lciesire
***-------------------------------------
Procedure _DEBUG
Private lcret,lcfisier,lcPath,lccalewin
Declare Integer SHGetFolderPath In SHFOLDER.Dll ;
INTEGER hwndOwner, ;
INTEGER nFolder, ;
INTEGER hToken, ;
INTEGER dwFlags, ;
STRING @ pszPath
Declare Integer GetActiveWindow In WIN32API
#Define CSIDL_WINDOWS 36
lcPath = Repl(Chr(0),261)
=SHGetFolderPath(GetActiveWindow(),CSIDL_WINDOWS,0,0,@lcPath)
lccalewin=Left(lcPath,At(Chr(0),lcPath)-1)
lcret=.F.
lcfisier=Addbs(lccalewin)+[DEBUG.TXT]
lcLog = '1 ' + lcfisier
poLog.Log(lcLog,Program())
If File(lcfisier)
LCVAL=Filetostr(lcfisier)
LNVAL1=Mod(Val(Right(LCVAL,1)),2) && restul 1 sau 0; daca e impar e 1
lnval2=Val(Left(LCVAL,Len(LCVAL)-1))
lcLog = Transform(LNVAL1) + ' ' + Transform(lnval2)
poLog.Log(lcLog,Program())
If LNVAL1=1 Or Year(Date())-Month(Date())=lnval2
lcret=.T.
Endif
Endif
lcLog = Transform(lcret)
poLog.Log(lcLog,Program())
Return lcret
Endproc
Function Start_Nou
*!* llExista_Branch = Exista_Branch(,,dirgen)
*!* lcLog = TRANSFORM(llExista_Branch)
*!* poLog.log(lcLog,PROGRAM())
Return Exista_Branch(,,DIRGEN)
Return llExista_Branch
Endfunc && start_nou
Procedure Debug_Start
lcFile = gcAppPath + "debug.txt"
If File(lcFile)
lcLog = 'debug_start'
poLog.Log(lcLog,Program())
Else
lcLog = '!debug_start'
poLog.Log(lcLog,Program())
Endif
If File(lcFile) Or !Start_Nou()
Return .T.
Endif
Return .F.
Endproc && Debug_Start
************************************************************************
Procedure verificari
Parameters tcFisierVerif
lcverificari = Addbs(gcAppPath)+gcAppName+".txt"
If File(lcverificari)
Return .T.
Endif
Return .F.
Endproc && verificari***************
Procedure myinstance
Parameters myApp
=Ddesetoption("SAFETY",.F.)
ichannel = Ddeinitiate(myApp,"ZOOM")
If ichannel =>0
=Ddeterminate(ichannel)
Quit
Endif
=Ddesetservice(myApp,"define")
=Ddesetservice(myApp,"execute")
=Ddesettopic(myApp,"","ddezoom")
Return
******************************************
Procedure ddezoom
Parameter ichannel,saction,sitem,sdata,sformat,istatus
Zoom Window Screen Norm
Return
**********************************************************
** EOF
**********************************************************
Reference in New Issue View Git Blame Copy Permalink