**** start app **** >local lerrorflag,cerror,cdatabase,nloop,nanswer,lfrmlogin,cdbcname,nlength,lcdefaultpath >set procedure to sysproc additive >oapp=createobject('clSystem') >do header >do declare >oapp.startdir=sys(5)+curdir() > >**** open config.dbf >select 0 >cerror=on("ERROR") >on error lerrorflag=.t. >use config shared >on error &cerror. >if lerrorflag=.t. > =messagebox("Cannot Open Config.dbf"+chr(13)+sys(5)+curdir(),0+16,oapp.msgtitle) > do footer > return >endif >**** open settings.dbf >select 0 >cerror=on("ERROR") >on error lerrorflag=.t. >use settings shared >on error &cerror. >if lerrorflag=.t. > oapp.settingflag=.f. >else > oapp.settingflag=.t. >endif >lerrorflag=.f. >**** open database >cdbcname=alltrim(config.datadir)+oapp.dbcname+".dbc"&&DY data base name:dyts.dbc >nlength=len(oapp.dbcname)+4 && add '.dbc' >wait window "Open Database" nowait >cerror=on("ERROR") >on error lerrorflag=.t. >_screen.visible=.t. >cdatabase=alltrim(locfile(cdbcname,"dbc")) >_screen.visible=.f. >on error &cerror. >if lerrorflag=.t. > wait clear > do footer > return >endif >if upper(right(cdatabase,nlength))<>upper(oapp.dbcname)+".DBC" > wait clear > =messagebox("Wrong Database!",0+16,oapp.msgtitle) > do footer > return >endif >wait clear >cerror=on("ERROR") >on error lerrorflag=.t. >open database &cdatabase. shared >on error &cerror. >if lerrorflag=.t. > =messagebox("Cannot Open Database",0+16,oapp.msgtitle) > do footer > return >endif >if upper(left(cdatabase,len(cdatabase)-nlength))<>upper(alltrim(config.datadir)) > replace config.datadir with left(cdatabase,len(cdatabase)-nlength) >endif >**** start application >do form topform name topform linked > >read events >if type("oApp")="O" and not isnull(oapp) && it might be helpful :) > do footer >endif >return > > >define class clsystem as custom > version="3.1" > msgtitle="Main Company" > dbcname="maindata" > userid='' > errorind=0 > quitflag=.f. > topform=.null. > frmlogin=.null. > startdir="" > debugflag=.f. > register1=.f. && for dynamic multi-object processes, sometimes can be object! > settingflag=.f. && for saving individual settings > frmsplash=.null. > blockmenu=.f. >enddefine > >define class myheader as header && header for shipinvn.scx > fieldnumber=0 > procedure rightclick > thisform.headerrightclick(this) > endproc >enddefine > > > > >function apishellexecute(m.lnhwnd, m.lcoperation, m.lcfile, m.lcparameters, m.lcdirectory, m.lnshowcmd) > declare integer ShellExecute in Shell32.dll as apiShellExecute ; > integer lnHwnd, ; > string lcOperation, ; > string lcFile, ; > string lcParameters, ; > string lcDirectory, ; > integer lnShowCmd > return apishellexecute(m.lnhwnd, m.lcoperation, m.lcfile, m.lcparameters, m.lcdirectory, m.lnshowcmd) >endfunc > > > >**********************************sysproc > > >procedure header > on error do errorhandler with program(),lineno(1) > clear > close data all > close tables all > set exclusive off > set escape on > set deleted on > set exact on > set confirm off > set near on > set multilocks on > set sysmenu to > set path to > set classlib to class1 > set classlib to class2 additive > set reprocess to automatic > set collate to 'MACHINE' > set century off > set century to 19 rollover 15 > =hidescreen() > _screen.caption="company" > _screen.icon="desktop.ico" > _screen.fontname="Arial" > _screen.fontsize=8 > _screen.fontbold=.f. > _screen.themes=.f. > set status bar off > on shutdown do quitapp > on escape do escapekey > return >endproc > > > > > >procedure footer > wait window 'Closing... Wait, Please!' nowait > close data all > close tables all > set escape on > set deleted off > set exact off > set multilocks off > set sysmenu to default > set path to > set classlib to > set exclusive on > set notify on > oapp.topform=.null. > oapp.register1=.null. > release all > =showscreen() > _screen.caption="Microsoft Visual Foxpro" > set status bar on > on shutdown > on key > on error > on escape > set procedure to > clear all > wait clear > set talk on > return >endproc > > >procedure escapekey > if type('oApp')<>'O' or isnull(oapp) > on shutdown > cancel > return > endif > if messagebox('Do You Really Want To Cancel Processing And Close The System?', ; > 4+32,oapp.msgtitle)<>6 > retry > endif > on shutdown > clear events > cancel > quit > return >endproc > > > > >function showscreen > _screen.left=0 > _screen.windowstate=2 > _screen.caption="" > _screen.visible=.t. > return >endfunc > > >function hidescreen > _screen.left=-2000 > _screen.windowstate=2 > _screen.caption="" > _screen.visible=.f. > return >endfunc > > >procedure showtable&&brow table for developer debug > lparameter calias > =showscreen() > select (calias) > browse > =hidescreen() > return >endproc > > >procedure quitapp&&stop event processing > on shutdown > if vartype(_screen.themesmanager)=="O" > _screen.removeobject("ThemesManager") > endif > if type('oApp')<>'O' > clear events > return > endif > if type('oApp.topform.tmrTop')=='O' and not isnull(oapp.topform.tmrtop) > oapp.topform.closemodalforms() > oapp.topform.tmrtop.enabled=.t. > else > oapp.quitflag=.t. > clear events > endif > return >endproc > > > > >procedure errorhandler > parameter cprogram,nline > local nanswer > local array aerrorinfo(7) > =aerror(aerrorinfo) > if used('syserror') > insert into syserror (userid,sysinfo,created,linenum,errornum,errormsg,progname) ; > values(oapp.userid,sys(0),datetime(),nline,aerrorinfo[1],aerrorinfo[2],cprogram) > endif > nanswer=messagebox("Application Error: "+aerrorinfo[2]+". Program "+cprogram+ ; > ". Line "+alltrim(str(nline)),2+16,oapp.msgtitle) > do case > case nanswer=3 && abort > oapp.errorind=1 > do quitapp > on error > * cancel > case nanswer=4 && retry > retry > case nanswer=5 && ignore > oapp.errorind=1 > endcase > return >endproc>