LOCAL lcalias, latables[1,1], j, k, lctext, lctables, lnoldreprocess,;
lcmessage, laerror[7]
IF goprogram.nerror2005counter < 10
IF nerror = 2005
goprogram.nerror2005counter = goprogram.nerror2005counter + 1
= INKEY(0.2)
RETRY
ENDIF
ENDIF
* Record / File is in use by another ....
IF (nerror = 108) OR (nerror = 109)
LOCAL lnsecsincemidnight
lnsecsincemidnight = VAL(SYS(2))
IF (goprogram.nlastinuseerror = 0) OR (lnsecsincemidnight - goprogram.nlastinuseerror > 20)
* first time the error occured
goprogram.nlastinuseerror = lnsecsincemidnight
ELSE
* test for still in 15 seconds timeout period otherwise do not perform a retry
IF (lnsecsincemidnight - goprogram.nlastinuseerror) > 15
* clear InUse-Error
goprogram.nlastinuseerror = 0
ENDIF
ENDIF
IF goprogram.nlastinuseerror > 0
* wait and try again
INKEY(0.03)
RETRY
ENDIF
ENDIF
* clear InUse-Error
goprogram.nlastinuseerror = 0
IF EMPTY(cmessage)
lcmessage = MESSAGE()
ELSE
lcmessage = cmessage
ENDIF
laerror[1] = .F.
=AERROR(laerror)
IF !EMPTY(laerror[1])
IF TYPE("_screen.ActiveForm") = "O"
IF pemstatus(_SCREEN.ACTIVEFORM,'ErrorHandler',5)
IF _SCREEN.ACTIVEFORM.errorhandler(laerror[1])
RETURN .F.
ENDIF
ENDIF
ENDIF
ENDIF
lcalias = ALIAS()
IF EMPTY(nline)
nline = -1
ENDIF
lctext = UPPER(cmethod) + CHR(13) +;
"line : " + TRANSFORM(nline) + CHR(13)+;
"code : " + MESSAGE(1) + CHR(13)
lctables = ""
j = 1
DO WHILE !EMPTY(PROGRAM(j))
lctext = lctext + PROGRAM(j)+CHR(13)
j = j + 1
ENDDO
IF AUSED(latables) > 0
lctables = "*" + ALIAS()+ " ["+TAG()+"]"
FOR j = 1 TO ALEN(latables,1)
IF latables[j,1] # ALIAS()
lctables = lctables + CHR(13) + latables[j,1]
ENDIF
NEXT
ENDIF
?? CHR(7)
_SCREEN.LOCKSCREEN = .F.
IF TYPE("_screen.ActiveForm") = "O" AND TYPE("_screen.activeform.lockscreen") # "U"
_SCREEN.ACTIVEFORM.LOCKSCREEN = .F.
ENDIF
LOCAL lnanswer
lnanswer = MESSAGEBOX(msg_errornum + TRANSFORM(nerror) + id_cr +;
msg_method + cmethod + " : " +TRANSFORM(nline)+ id_cr +;
lcmessage + id_cr +;
"'"+MESSAGE(1)+"'", ;
mb_abortretryignore+mb_iconstop , ;
msg_program_error)
IF lnanswer # 4
LOCAL lcloseit
lnoldreprocess = SET('REPROCESS')
SET REPROCESS TO AUTOMATIC
IF !USED("VFXLOG")
lcloseit = .T.
IF ADIR(ladummy,goprogram.cvfxdir+"vfxlog.dbf")#1
* Table not found. Create new table.
*!* This can not be referenced from a function.
*!* this.createtable(goprogram.cvfxdir+"vfxlog")
goprogram.createtable(goprogram.cvfxdir+"vfxlog")
ENDIF
USE (goprogram.cvfxdir+"vfxlog") IN 0 ORDER TAG OBJECT SHARED AGAIN
ENDIF
SELECT vfxlog
INSERT INTO vfxlog (TYPE, DATE, TIME) ;
VALUES ("ERROR", DATE(), TIME())
IF VARTYPE(m.gu_user)="C"
REPLACE USER WITH m.gu_user
ENDIF
REPLACE ERROR WITH nerror,;
MESSAGE WITH lcmessage,;
method WITH lctext,;
TABLES WITH lctables
lctempfile = UPPER("X"+SUBSTR(SYS(2015),4,7)+".TXT")
REPLACE method WITH method + CHR(13) + "MEMORY CONFIGURATION:" + CHR(13)
LIST MEMO TO FILE(lctempfile) NOCONSOLE
APPEND MEMO method FROM (lctempfile)
ERASE (lctempfile)
REPLACE method WITH method + CHR(13) + "OBJECTS:" + CHR(13)
LIST OBJECTS TO FILE(lctempfile) NOCONSOLE
APPEND MEMO method FROM (lctempfile)
ERASE (lctempfile)
IF lcloseit
USE IN vfxlog
ENDIF
SET REPROCESS TO lnoldreprocess
IF !EMPTY(lcalias)
SELECT (lcalias)
ENDIF
ENDIF
DO CASE
CASE lnanswer = 3 && Abort
DO WHILE TXNLEVEL() > 0
ROLLBACK
ENDDO
IF AUSED(latables) > 0
FOR j = 1 TO ALEN(latables,1)
IF INLIST(CURSORGETPROP('Buffering',latables[j,1]),3,5)
= TABLEREVERT(.T., latables[j,1])
ENDIF
NEXT
ENDIF
ON SHUTDOWN QUIT
CLEAR EVENTS
CLEAR EVENTS
IF VERSION(2)#2
QUIT
ELSE
RETURN TO MASTER
ENDIF
CASE lnanswer = 4 && Retry
RETRY
CASE lnanswer = 5 && Ignore
RETURN .T.
ENDCASE
RETURN .F.
ENDFUNC
goprogram.onquit()
ENDFUNC
LOCAL lnformcount, lobject, lledit, llinsert, lldelete, llaudit
IF VARTYPE(goprogram) = "O"
* it's up to you, when debugging returning always .t. can be handy and speedy
*!* if goprogram.ldebugmode
*!* return .f.
*!* endif
ELSE
RETURN .F.
ENDIF
IF TYPE("_screen.ActiveForm")="O"
IF VARTYPE(_SCREEN.ACTIVEFORM.WINDOWTYPE) <> "U"
IF _SCREEN.ACTIVEFORM.WINDOWTYPE = 1 && Modal Skip Always
RETURN .T.
ENDIF
ENDIF
ENDIF
lnformcount = goprogram.nformcount
llaudit=.F.
IF TYPE("_screen.activeform.laudit")="L"
llaudit=_SCREEN.ACTIVEFORM.laudit
ENDIF
lobject = TYPE("_screen.ActiveForm.lEmpty") <> "U"
IF lobject
lnformstatus = _SCREEN.ACTIVEFORM.nformstatus
llmore = _SCREEN.ACTIVEFORM.lmore
llempty = _SCREEN.ACTIVEFORM.lempty
IF TYPE("_screen.ActiveForm.lMultipage") <> "U"
llmultipage = _SCREEN.ACTIVEFORM.lmultipage
ELSE
llmultipage = .F.
ENDIF
lledit = _SCREEN.ACTIVEFORM.lcanedit
llinsert = _SCREEN.ACTIVEFORM.lcaninsert
lldelete = _SCREEN.ACTIVEFORM.lcandelete
ELSE
lnformstatus = id_normal_mode
llmore = .F.
llempty = .T.
llmultipage = .F.
lledit = .F.
llinsert = .F.
lldelete = .F.
ENDIF
tcmenuitem = UPPER(tcmenuitem)
DO CASE
CASE tcmenuitem = "FILE_OPEN"
RETURN goprogram.lopendialog
CASE tcmenuitem = "FILE_CLOSE"
RETURN (lnformcount = 0 OR (lnformstatus <> id_normal_mode))
CASE tcmenuitem = "FILE_EXIT"
* return (lnFormStatus <> ID_NORMAL_MODE)
RETURN .F.
CASE tcmenuitem = "EDIT_NEW"
RETURN (lnformcount = 0 AND !goprogram.lopendialog OR !llinsert)
CASE tcmenuitem = "EDIT_RECORDCOPY"
RETURN (lnformcount = 0 AND !goprogram.lopendialog OR !llinsert) OR llempty
CASE tcmenuitem = "EDIT_EDIT"
RETURN (lnformcount = 0 OR !lledit OR llempty OR lnformstatus <> id_normal_mode)
CASE tcmenuitem = "EDIT_DELETE"
RETURN (lnformcount = 0 OR !lldelete OR llempty OR lnformstatus <> id_normal_mode)
CASE tcmenuitem = "EDIT_MORE"
RETURN (lnformcount = 0 OR !llmore OR llempty OR lnformstatus <> id_normal_mode)
CASE tcmenuitem = "EDIT_FIND"
RETURN (lnformcount = 0 OR llempty)
CASE tcmenuitem $ "EDIT_TOP,EDIT_PREV,EDIT_NEXT,EDIT_BOTTOM"
RETURN (lnformcount = 0 OR llempty)
CASE tcmenuitem $ "EDIT_COPY,EDIT_PASTE,EDIT_CUT"
RETURN (lnformcount = 0 OR lnformstatus = id_normal_mode)
CASE tcmenuitem $ "VIEW_NEXTPAGE,VIEW_PREVPAGE"
RETURN (lnformcount = 0 OR !llmultipage)
CASE tcmenuitem $ "EDIT_SAVE,EDIT_RESTORE"
RETURN (lnformcount = 0 OR lnformstatus = id_normal_mode)
CASE tcmenuitem $ "FILE_PRINT"
RETURN (lnformcount = 0 OR llempty OR lnformstatus <> id_normal_mode)
ENDCASE
RETURN .F.
ENDFUNC
LOCAL lcalias, lcid, lnoldreprocess, lnoldarea, lcexact
lnoldarea = SELECT()
*!* Set exact on to find the right record.
lcexact = SET("EXACT")
SET EXACT ON
IF EMPTY(tcalias)
lcalias = ALIAS()
IF CURSORGETPROP("SOURCETYPE") = 1 && LOCAL VIEW
lcalias = UPPER(CURSORGETPROP("TABLES"))
lcalias = SUBSTR(lcalias, AT("!", lcalias) + 1)
ENDIF
ELSE
lcalias = UPPER(tcalias)
ENDIF
lnoldreprocess = SET('REPROCESS')
SET REPROCESS TO AUTOMATIC
*!* This function should work also if the application object does not exist.
IF TYPE("goprogram.class")="C"
IF ADIR(ladummy,goprogram.cvfxdir+"vfxsysid.dbf")#1
* Table not found. Create new table.
goprogram.createtable(goprogram.cvfxdir+"vfxsysid")
ENDIF
USE (goprogram.cvfxdir+"vfxsysid") IN 0 ORDER TAG KEY
ELSE
USE vfxsysid IN 0 ORDER TAG KEY
ENDIF
SELECT vfxsysid
IF EMPTY(tnlen)
IF !EMPTY(vfxsysid.MAXLEN)
tnlen=vfxsysid.MAXLEN
ELSE
tnlen = FSIZE('VALUE')
ENDIF
ELSE
IF tnlen > FSIZE('VALUE')
tnlen = FSIZE('VALUE')
ENDIF
ENDIF
* verify Startvalue
LOCAL lnstart
DO CASE
CASE VARTYPE(tcstart)="C"
lnstart = VAL(tcstart)
CASE VARTYPE(tcstart)="N"
* do nothing
lnstart = tcstart
OTHERWISE
lnstart = 1
ENDCASE
IF SEEK(lcalias)
IF RLOCK()
* use current value in vfxsysid
lcid = VAL(vfxsysid.VALUE)
** if the actual value in vfxsysid is smaller than the start value, take care of that!
IF lcid < lnstart
lcid = lnstart - 1
ENDIF
lcid = incbase10(IIF(lcid=0,"",STR(lcid)), tnlen)
REPLACE value WITH lcid IN vfxsysid
ENDIF
UNLOCK
ELSE
* use start value minus 1 as it will be incremented by incbase10()
lcid = lnstart - 1
lcid = incbase10(IIF(lcid=0,"",STR(lcid)), tnlen)
INSERT INTO vfxsysid (keyname, VALUE, MAXLEN) ;
VALUES(UPPER(lcalias), lcid, tnlen)
ENDIF
USE IN vfxsysid
SET REPROCESS TO lnoldreprocess
IF !EMPTY(lnoldarea)
SELECT (lnoldarea)
ENDIF
*!* Restore the old setting for exact.
SET EXACT &lcexact
RETURN lcid
ENDFUNC
LOCAL lcalias, lcloseit, lnoldreprocess
PUBLIC _goxlockuser, _goxlockdate,_goxlocktime
_goxlockuser = ""
_goxlockdate = ""
_goxlocktime = ""
lcalias = ALIAS()
lnoldreprocess = SET('REPROCESS')
SET REPROCESS TO AUTOMATIC
lcloseit = .F.
IF EMPTY(tcalias)
tcalias = ALIAS()
ENDIF
SELECT (tcalias)
IF EMPTY(tnrecord) && Lock Table!
tnrecord = 0
ENDIF
IF !USED("VFXLOCK")
IF ADIR(ladummy,goprogram.cvfxdir+"vfxlock.dbf")#1
* Table not found. Create new table.
goprogram.createtable(goprogram.cvfxdir+"vfxlock")
ENDIF
USE (goprogram.cvfxdir+"vfxlock") ORDER TAG KEY IN 0 AGAIN
lcloseit = .T.
ENDIF
SELECT vfxlock
IF SEEK(PADR(UPPER(tcalias),32) + STR(tnrecord,10), "VFXLOCK", "KEY")
lok = .F.
_goxlockuser = vfxlock.user_name
_goxlockdate = DTOC(vfxlock.DATE)
_goxlocktime = vfxlock.TIME
ELSE
lok = .T.
INSERT INTO vfxlock VALUES(tcalias,tnrecord, DATE(), TIME(), m.gu_user_name)
ENDIF
IF lcloseit
USE IN vfxlock
ENDIF
IF!EMPTY(lcalias)
SELECT (lcalias)
ENDIF
SET REPROCESS TO lnoldreprocess
IF!EMPTY(lcalias)
SELECT (lcalias)
ENDIF
RETURN lok
ENDFUNC
LOCAL lcalias, lcloseit, lnoldreprocess
PUBLIC _goxlockuser, _goxlockdate,_goxlocktime
_goxlockuser = ""
_goxlockdate = ""
_goxlocktime = ""
lcalias = ALIAS()
lnoldreprocess = SET('REPROCESS')
SET REPROCESS TO AUTOMATIC
lcloseit = .F.
IF EMPTY(tcalias)
tcalias = ALIAS()
ENDIF
SELECT (tcalias)
IF EMPTY(tnrecord) && Lock Table!
tnrecord = 0
ENDIF
IF !USED("VFXLOCK")
IF ADIR(ladummy,goprogram.cvfxdir+"vfxlock.dbf")#1
* Table not found. Create new table.
THIS.createtable(goprogram.cvfxdir+"vfxlock")
ENDIF
USE (goprogram.cvfxdir+"vfxlock") ORDER TAG KEY IN 0 AGAIN
lcloseit = .T.
ENDIF
SELECT vfxlock
IF SEEK(PADR(UPPER(tcalias),32) + STR(tnrecord,10), "VFXLOCK", "KEY")
IF FLOCK()
IF tlalllock
DELETE ALL FOR ALLTRIM(UPPER(TABLE)) == ALLTRIM(UPPER(tcalias))
ELSE
DELETE
ENDIF
ENDIF
UNLOCK IN vfxlock
lok = .T.
ELSE
lok = .F.
ENDIF
IF lcloseit
USE IN vfxlock
ENDIF
SET REPROCESS TO lnoldreprocess
IF!EMPTY(lcalias)
SELECT (lcalias)
ENDIF
RETURN lok
ENDFUNC
LOCAL lcbuffer, lnvalue, lnkey
lnkey = 9
lcbuffer = ""
FOR j = 1 TO LEN(tctext)
lnvalue = BITXOR(ASC(SUBSTR(tctext,j,1)),lnkey)
lcbuffer = lcbuffer + CHR(lnvalue)
NEXT
RETURN lcbuffer
ENDFUNC
LOCAL lnanswer
IF EMPTY(tcmessagetext)
tcmessagetext = "Syntax Error: ErrorMsg(tcMessageText, tnDialogType, tcMessageTitle)"
ENDIF
IF EMPTY(tndialogtype)
tndialogtype = mb_ok+mb_iconstop
ENDIF
IF EMPTY(tcmessagetitle)
tcmessagetitle = msg_attention
ENDIF
lnanswer = MESSAGEBOX(tcmessagetext, tndialogtype, tcmessagetitle)
RETURN lnanswer
ENDFUNC
LOCAL _array[1,1], cobjname, oobject, j, maxobj, x, ocontrol, ntabindex
maxobj = AMEMBERS(_array,ocontainer,1)
ntabindex = 99999
ocontrol = .F.
FOR j = 1 TO maxobj
IF _array[j,2] = "Object"
cobjname = _array[j,1]
oobject = ocontainer.&cobjname
IF UPPER(oobject.BASECLASS) $ UPPER("TextBox;EditBox;ComboBox;ListBox;CheckBox;Spinner;Container")
IF oobject.ENABLED AND oobject.VISIBLE
IF oobject.TABINDEX < ntabindex
ocontrol = oobject
ntabindex = oobject.TABINDEX
ENDIF
ENDIF
ENDIF
IF UPPER(oobject.BASECLASS) == UPPER("Page")
IF oobject.PARENT.ACTIVEPAGE=oobject.PAGEORDER
IF setfirstfocus(oobject)
RETURN .T.
ENDIF
ENDIF
ENDIF
ENDIF
NEXT
IF VARTYPE(ocontrol) = "O"
ocontrol.SETFOCUS()
RETURN .T.
ENDIF
RETURN .F.
ENDFUNC
LOCAL narg, i, nmaxlen
IF EMPTY(tcseparator)
tcseparator = ';'
ENDIF
nmaxlen = LEN(tcargument)
IF nmaxlen > 0
narg = 1
ELSE
RETURN 0
ENDIF
narg = OCCURS(tcseparator, tcargument)
narg = narg + 1
RETURN narg
ENDFUNC
IF PARAMETERS() < 3 OR tcseparator == ''
tcseparator = ';'
ENDIF
tcargument = tcseparator + tcseparator + tcargument + ;
REPLICATE(tcseparator,MAX(0,tcargno))
tcargument = SUBSTR(tcargument, AT(tcseparator,tcargument,MAX(0,tcargno)+1)+LEN(tcseparator))
RETURN LEFT(tcargument,AT(tcseparator,tcargument)-1)
ENDFUNC
LOCAL lcnewvalue, lnstringlength
lnstringlength = LEN(tcvalue)
IF PARAMETERS() = 2
lnstringlength = tnmaxlen
ENDIF
IF EMPTY(tcvalue)
tcvalue = '0'
ENDIF
lcnewvalue = PADL(RIGHT(ALLT(STR(VAL(tcvalue) + 1, lnstringlength)), lnstringlength), lnstringlength)
lcnewvalue = STRTRAN(lcnewvalue,' ', '0')
RETURN lcnewvalue
ENDFUNC
LPARAMETERS tcvariable
LOCAL j, k, ctext, xvalue
ctext = "Called by: " + CHR(13)
j = 1
DO WHILE !EMPTY(PROGRAM(j))
j = j + 1
ENDDO
k = j - 1
IF k > 4
j = k - 4
ENDIF
DO WHILE j < k
ctext = ctext + PROGRAM(j)+CHR(13)
j = j + 1
ENDDO
IF !EMPTY(tcvariable)
ctext = ctext + tcvariable + " = "
xvalue = &tcvariable
IF VARTYPE(xvalue) = "C"
ctext = ctext + xvalue
ENDIF
IF VARTYPE(xvalue) $ "NFI"
ctext = ctext + TRANSFORM(xvalue)
ENDIF
IF VARTYPE(xvalue) $ "D"
ctext = ctext + DTOC(xvalue)
ENDIF
IF VARTYPE(xvalue) $ "D"
ctext = ctext + DTOC(xvalue)
ENDIF
IF VARTYPE(xvalue) $ "L"
ctext = ctext + IIF(xvalue , ".T.", ".F.")
ENDIF
ENDIF
WAIT WINDOW ctext
RETURN .T.
ENDFUNC
LOCAL lnoldsession, lcalias, lctext, lused
lctext = ""
IF EMPTY(tcmessageid)
RETURN lctext
ENDIF
lcalias = ALIAS()
lnoldsession = SET('datasession')
SET DATASESSION TO 1
IF !USED("vfxmsg")
LOCAL lctable
IF VARTYPE(goprogram)#"O"
lctable=GETFILE('DBF','Message')
IF EMPTY(lctable)
RETURN '???'
ENDIF
ELSE
lctable = goprogram.cvfxdir+"vfxmsg"
ENDIF
USE (lctable) ORDER TAG KEY AGAIN IN 0 ALIAS vfxmsg
ENDIF
IF EMPTY(tclangid)
IF VARTYPE(goprogram) = "O"
tclangid = goprogram.getlangid()
ELSE
tclangid = "TEXT"
ENDIF
ELSE
IF !INLIST(tclangid,"ENG","ESP","FRE","GER","ITA","USR")
tclangid = "TEXT"
ENDIF
ENDIF
IF SEEK(UPPER(ALLTRIM(tcmessageid)), "vfxmsg","key")
lctext = EVAL("vfxmsg."+tclangid)
ELSE
lctext = "?"+ALLTRIM(tcmessageid)+"?"
ENDIF
SET DATASESSION TO lnoldsession
IF !EMPTY(lcalias)
SELECT(lcalias)
ENDIF
IF EMPTY(lctext)
lctext = "?"+ALLTRIM(tcmessageid)+"? ["+tclangid+"]"
ENDIF
RETURN lctext
ENDFUNC
LOCAL lcretval, lctype
lcretval = ""
lctype = VARTYPE(tuparam)
DO CASE
CASE lctype = "C"
lcretval = IIF(ISNULL(tuparam), "¦", tuparam)
CASE INLIST(lctype, "N", "B", "Y")
lcretval = STR(tuparam)
CASE lctype = "L"
lcretval = IIF(tuparam, "T", "F")
CASE lctype = "D"
lcretval = DTOC(tuparam)
CASE lctype = "T"
lcretval = TTOC(tuparam)
ENDCASE
RETURN lcretval
ENDFUNC
LOCAL laDummy[1],retval
PRIVATE pcHelptext,pcBook,pcBook2,pcChaptertcTitle,pcIndex
IF ADIR(laDummy,"vfxhelp.dbf")=1 AND TYPE("_screen.activeform")="O"
* Edit help
WITH _screen.activeform
IF TYPE("_screen.activeform.activecontrol")="O" AND !ISNULL(_screen.activeform.activecontrol)
* Search HelpcontextID
USE vfxhelp IN 0 SHARED AGAIN
IF SEEK(.activecontrol.helpcontextid,"vfxhelp","helpid")
pcBook=vfxhelp.book
pcBook2=vfxhelp.book2
pcChapter=vfxhelp.chapter
pcIndex=vfxhelp.index
pcTitle=vfxhelp.title
pcHelptext=vfxhelp.helptext
IF EMPTY(m.pcBook) && Form Caption
pcBook=.caption
ENDIF
IF EMPTY(m.pcBook2) && Page Caption
IF TYPE("_screen.activeform.pgfpageframe")="O"
pcBook2=.pgfpageframe.pages[.pgfpageframe.activepage].caption
ENDIF
ENDIF
IF EMPTY(m.pcChapter)
IF PEMSTATUS(.activecontrol,"controlsource",5)
IF "." $ .activecontrol.controlsource
pcChapter=SUBSTR(.activecontrol.controlsource,AT(".",.activecontrol.controlsource)+1)
ELSE
pcChapter=.activecontrol.controlsource
ENDIF
pcChapter=PROPER(m.pcChapter)
ENDIF
ENDIF
IF EMPTY(m.pcIndex)
pcIndex=m.pcChapter+" ("+ALLTRIM(m.pcBook)+", "+ALLTRIM(m.pcBook2)+")"
ENDIF
IF EMPTY(m.pcTitle)
pcTitle=m.pcIndex
ENDIF
IF EMPTY(m.pcHelptext)
IF !EMPTY(.activecontrol.tooltiptext)
pcHelptext=.activecontrol.tooltiptext
ENDIF
IF !EMPTY(.activecontrol.statusbartext)
pcHelptext=.activecontrol.statusbartext
ENDIF
ENDIF
DO FORM form\vfxhelp TO retval
IF VARTYPE(retval)="N"
IF retval=1
REPLACE helptext WITH m.pcHelptext,;
book WITH m.pcBook,;
book2 WITH m.pcBook2,;
chapter WITH m.pcChapter,;
title WITH m.pcTitle,;
index WITH m.pcIndex IN vfxhelp
ENDIF
ENDIF
ELSE
WAIT WINDOW "HelpContextID not found: "+;
JUSTFNAME(SYS(1271,.activecontrol))+"-"+SYS(1272,.activecontrol)+"="+TRANSFORM(.activecontrol.helpcontextid)
ENDIF
USE IN vfxhelp
ENDIF
ENDWITH
ELSE
* Show CHM-Help
contexthelp()
ENDIF
RETURN .T.
*-------------------------------------------------------
* Function....: ContextHelp()
* Called by...:
*
* Abstract....:
*
* Returns.....:
*
* Parameters..:
*
* Notes.......:
*-------------------------------------------------------
LOCAL lnhelpid
lnhelpid = -1
IF TYPE("_screen.activeform.activecontrol.helpcontextid") != "U" AND;
!EMPTY(_SCREEN.ACTIVEFORM.ACTIVECONTROL.HELPCONTEXTID)
lnhelpid = _SCREEN.ACTIVEFORM.ACTIVECONTROL.HELPCONTEXTID
ELSE
IF TYPE("_screen.activeform.helpcontextid") != "U"
IF !EMPTY(_SCREEN.ACTIVEFORM.HELPCONTEXTID)
lnhelpid = _SCREEN.ACTIVEFORM.HELPCONTEXTID
ENDIF
ENDIF
ENDIF
IF lnhelpid == -1
HELP
ELSE
HELP ID lnhelpid
ENDIF
RETURN .T.
ENDFUNC
IF EMPTY(tcobjname)
tcobjname = "o"
ENDIF
IF EMPTY(tcclassname)
RETURN ''
ENDIF
IF PARAMETERS() < 5
tlcentered = .T.
ENDIF
IF TYPE("toPage."+tcobjname)=="U"
LOCAL locontrol
toform.LOCKSCREEN = .T.
topage.ADDOBJECT(tcobjname,tcclassname)
locontrol = EVAL("toPage."+tcobjname)
IF locontrol.BASECLASS == "Container"
locontrol.BORDERWIDTH = 0
ENDIF
IF pemstatus(locontrol,'OnLoadPosition',5)
locontrol.onloadposition()
ENDIF
IF VARTYPE(toform.oresizecontrol)="O"
IF tlcentered AND locontrol.COMMENT != "
LOCAL lnfactorx, lnfactory
lnfactorx = toform.oresizecontrol.nfactorx
lnfactory = toform.oresizecontrol.nfactory
locontrol.LEFT = (topage.PARENT.PAGEWIDTH - locontrol.WIDTH *lnfactorx) / 2
locontrol.TOP = (topage.PARENT.PAGEHEIGHT - locontrol.HEIGHT*lnfactory) / 2
IF locontrol.LEFT > 2
locontrol.LEFT = locontrol.LEFT - 2*lnfactorx
ENDIF
IF locontrol.TOP > 2
locontrol.TOP = locontrol.TOP - 2*lnfactory
ENDIF
ENDIF
toform.oresizecontrol.addcontrol(locontrol)
ENDIF
locontrol.VISIBLE = .T.
toform.LOCKSCREEN = .F.
ENDIF
ENDFUNC
LOCAL lcdblink, lnheader
IF tnfilehandle < 0
RETURN ''
ENDIF
=FSEEK(tnfilehandle,0,0)
IF ASC(FREAD(tnfilehandle,1)) != 48
** Not a Visual FoxPro Database
RETURN ''
ENDIF
=FSEEK(tnfilehandle,dbf_data_offset,0) && Position of the First Data Record
lnheaderlen = ASC(FREAD(tnfilehandle,1)) + ASC(FREAD(tnfilehandle,1)) * 256
IF lnheaderlen < dbf_backlink_len
RETURN ''
ENDIF
** Backlink to the database
=FSEEK(tnfilehandle,lnheaderlen-dbf_backlink_len)
lcdblink = ALLTRIM(FREAD(tnfilehandle,dbf_backlink_len))
RETURN STRTRAN(lcdblink,CHR(0),'')
ENDFUNC
LOCAL lnheader
IF tnfilehandle < 0
RETURN -1
ENDIF
=FSEEK(tnfilehandle,0,0)
IF ASC(FREAD(tnfilehandle,1)) != 48
** Not a Visual FoxPro Database
RETURN ''
ENDIF
=FSEEK(tnfilehandle,dbf_data_offset,0) && Position of the First Data Record
lnheaderlen = ASC(FREAD(tnfilehandle,1)) + ASC(FREAD(tnfilehandle,1)) * 256
IF lnheaderlen < dbf_backlink_len
RETURN -1
ENDIF
tcdbc = LOWER(ALLTRIM(tcdbc))
IF LEN(tcdbc) > dbf_backlink_len
RETURN -1
ENDIF
=FSEEK(tnfilehandle,lnheaderlen-dbf_backlink_len)
lcdblink = tcdbc + REPLICATE(CHR(0),dbf_backlink_len-LEN(tcdbc))
= FWRITE(tnfilehandle, lcdblink)
RETURN 0
ENDFUNC
IF TYPE("tcto")#"C"
tcto=""
ENDIF
IF TYPE("tcfrom")#"C"
tcfrom=""
ENDIF
IF TYPE("glclientsupport")="U"
PUBLIC glclientsupport
glclientsupport=.F.
ENDIF
IF EMPTY(tcto) AND EMPTY(tcfrom)
IF !EMPTY(datapath_loc)
tcto=datapath_loc+"\"
tcfrom=datapath_loc+"\update\"
ELSE
RETURN .F.
ENDIF
ENDIF
IF !EMPTY(tcto) AND EMPTY(tcfrom)
tcfrom=IIF(RIGHT(tcto,1) = "\", LEFT(tcto, LEN(TRIM(tcto))-1), TRIM(tcto)) + "\update\"
ENDIF
* Datadir and updatedir must be different!
IF UPPER(ALLTRIM(tcto))==UPPER(ALLTRIM(tcfrom))
RETURN .F.
ENDIF
* Are there any files in the update directory?
LOCAL lnhowmany,lok,j,laFile[1]
lok=.T.
lnhowmany = ADIR(lafile,tcfrom+"*.*", "A")
IF lnhowmany>0
IF glclientsupport
* Update all clients using this update directory
USE vfxpath SHARED AGAIN IN 0 ALIAS temppath
SELECT temppath
LOCAL lnreccnt
COUNT ALL FOR !DELETED() TO lnreccnt
IF lnreccnt > 0
COPY TO ARRAY aclients
USE IN temppath
FOR j=1 TO ALEN(aclients,1)
IF UPPER(TRIM(tcfrom))==UPPER(IIF(RIGHT(TRIM(aclients[j,3]),1)="\",TRIM(aclients[j,3]),TRIM(aclients[j,3])+"\"))
IF !vfx_doupdate(tofoxapp, tlmute, tcfrom,;
IIF(RIGHT(TRIM(aclients[j,2]),1)="\",TRIM(aclients[j,2]),TRIM(aclients[j,2])+"\"), ;
IIF(RIGHT(TRIM(aclients[j,5]),1)="\",TRIM(aclients[j,5]),TRIM(aclients[j,5])+"\"))
lok=.F.
ENDIF
ENDIF
NEXT
ENDIF
IF USED("TempPath")
USE IN temppath
ENDIF
ELSE
IF !vfx_doupdate(tofoxapp, tlmute, tcfrom, tcto)
lok=.F.
ENDIF
ENDIF
ENDIF
IF lok
* delete update directory if all clients succeeded
FOR j = 1 TO lnhowmany
ERASE (tcfrom+lafile[j,1])
NEXT
ENDIF
RETURN lok
*-------------------------------------------------------
* Function....: vfx_doupdate()
* Called by...:
*
* Abstract....:
*
* Returns.....:
*
* Parameters..:
*
* Notes.......:
*-------------------------------------------------------
*!* Check whether an update is currently running with this client.
IF ADIR(ladummy,tcto+"UPD$CTRL.KEY")=1
= errormsg(msg_update_running)
RETURN .F.
ENDIF
IF TYPE("tcVfxPath")#"C"
tcvfxpath = tcto
ENDIF
*!* Initialize this function.
LOCAL lcpath, lcdbc, lnhowmany, lafile[1], laupdated[1], lcdbclink, lnneedupdate,;
j, lcsafety, lnfile
lcdbc = LOWER(tofoxapp.cmaindatabase)
LOCAL lavfxfiles[1], lcto
lavfxfiles[1] = ""
lcto = ""
IF tcto <> tcvfxpath
= ADIR(lavfxfiles,tcvfxpath+"*.*", "A")
ENDIF
IF !(".dbc" $ lcdbc)
lcdbc = lcdbc + ".dbc"
ENDIF
lcsafety = SET('safety')
SET SAFETY OFF
CLOSE DATA ALL
CLOSE TABLES ALL
lnfile = - 1
*!* Are there any files in the client directory?
lnhowmany = ADIR(lafile,tcto+"*.*", "A")
IF lnhowmany = 0
** New Installation, copy data from Update directory
lnhowmany = ADIR(lafile,tcfrom+"*.*", "A")
IF lnhowmany > 0
IF TYPE("toFoxApp.oIntroForm")="O" AND !ISNULL(tofoxapp.ointroform)
tofoxapp.ointroform.RELEASE()
ENDIF
lnfile = FCREATE(tcto+"UPD$CTRL.KEY", 0)
IF lnfile < 0
= errormsg(msg_update_conflict)
SET SAFETY &lcsafety
RETURN .F.
ENDIF
*!* Copy all files from update directory into client directory ...
*-- Pfad von VFX Tabellen wird berüchsichtigt wenn neue Instalation vorliegt
LOCAL lctable, llfree, lctemp
lctable = SYS(2015)
llfree = .F.
lctemp = ""
FOR j = 1 TO lnhowmany
IF ".LOG" $ lafile[j,1]
LOOP
ENDIF
IF ".KEY" $ lafile[j,1]
LOOP
ENDIF
WAIT WINDOW msg_copying+" " + lafile[j,1] + " ..." NOWAIT
llfree = .F.
lctemp = ""
IF UPPER(LEFT(lafile[j,1],3)) == "VFX"
lctemp = LEFT(lafile[j,1], AT(".", lafile[j,1])-1)
USE (tcfrom+lctemp) IN 0 ALIAS (lctable) SHARED
SELECT (lctable)
llfree = EMPTY(CURSORGETPROP("database"))
USE IN (lctable)
IF !llfree
CLOSE DATABASES ALL
ENDIF
ENDIF
lcto = IIF(UPPER(LEFT(lafile[j,1],3)) == "VFX" AND llfree, tcvfxpath, tcto)
COPY FILE (tcfrom + lafile[j,1]) TO (lcto + lafile[j,1])
NEXT
RELEASE lctable, llfree, lctemp
=FCLOSE(lnfile)
ERASE(tcto+"UPD$CTRL.KEY")
ENDIF
CLOSE DATA ALL
SET SAFETY &lcsafety
RETURN .T.
ELSE
DIMENSION ladbcalttables(1), ladbcnewtables(1), lacurrusedtables(1)
ladbcalttables(1) = ""
ladbcnewtables(1) = ""
lacurrusedtables(1) = ""
*!* Update Data
lnfile = -1
lnhowmany = ADIR(lafile,tcfrom+"*.dbf", "A")
IF lnhowmany > 0
IF TYPE("toFoxApp.oIntroForm")="O" AND !ISNULL(tofoxapp.ointroform)
tofoxapp.ointroform.RELEASE()
ENDIF
LOCAL lcolddbcname, lcnewdbcname, lnfilehandle, lcommit, lcerror, lcsavedir, lcbackupdir, lcvfxbackupdir
** Some data into Update directory, take that ;)
lnfile = FCREATE(tcto+"UPD$CTRL.KEY", 0)
IF lnfile < 0
= errormsg(msg_update_conflict)
SET SAFETY &lcsafety
RETURN .F.
ENDIF
lcerror = ON('error')
__vfx_error = .F.
ON ERROR =_vfx_updateerror(ERROR())
lcolddbcname = STRTRAN(lcdbc,".dbc","")
lcnewdbcname = "X"+SUBSTR(SYS(2015),4,7)
lcommit = .T.
WAIT WINDOW msg_savingdata NOWAIT
*!* Copy files from update directory in temporary directory under client directory
lcsavedir = tcto+"X"+SUBSTR(SYS(2015),4,7)
MD (lcsavedir)
lnhowmany = ADIR(lafile,tcfrom+"*.*", "A")
FOR j = 1 TO lnhowmany
COPY FILE (tcfrom+lafile[j,1]) TO (lcsavedir+"\"+lafile[j,1])
NEXT
IF tofoxapp.lsavedatabeforeupdate
*!* Copy files from client-data directory in temporary directory under client directory (backup)
lcbackupdir = tcto+"Z"+SUBSTR(SYS(2015),4,7)
MD (lcbackupdir)
lnhowmany = ADIR(lafile,tcto+"*.*", "A")
FOR j = 1 TO lnhowmany
IF ".LOG" $ lafile[j,1]
LOOP
ENDIF
IF ".KEY" $ lafile[j,1]
LOOP
ENDIF
IF lafile[j,1]#"UPD$CTRL.KEY"
COPY FILE (tcto+lafile[j,1]) TO (lcbackupdir+"\"+lafile[j,1])
ENDIF
NEXT
*!* Copy VFX_files from client-data directory in temporary directory under client directory (backup)
IF tcto <> tcvfxpath
lcvfxbackupdir = tcto+"V"+SUBSTR(SYS(2015),4,7)
MD (lcvfxbackupdir)
lnhowmany = ADIR(lafile,tcvfxpath+"*.*", "A")
FOR j = 1 TO lnhowmany
IF lafile[j,1]#"UPD$CTRL.KEY"
* Copy just VFX Tables, no other files.
IF !(".DBF" $ lafile[j,1] OR ".FPT" $ lafile[j,1] OR ".CDX" $ lafile[j,1])
LOOP
ENDIF
COPY FILE (tcvfxpath+lafile[j,1]) TO (lcvfxbackupdir+"\"+lafile[j,1])
ENDIF
NEXT
ENDIF
ENDIF
*!* Create update log file.
LOCAL lnascfile
lnascfile = -1
IF !tlmute
IF FILE(tcto+"update.log")
ERASE(tcto+"update.log")
ENDIF
lnascfile = FCREATE(tcto+"update.log")
IF lnascfile != -1
* All CHR(13) changed to CHR(13)+CHR(10).
=FWRITE(lnascfile,"------------------------------------------------"+CHR(13)+CHR(10)+;
"update started on " + TTOC(DATETIME()) +CHR(13)+CHR(10)+;
"------------------------------------------------"+CHR(13)+CHR(10) )
ENDIF
ENDIF
*-- Finde die Tabellen des aktuellen DBC
OPEN DATAB (tcto+lcdbc)
IF !EMPTY(DBC())
= ADBOBJECTS(ladbcalttables, "table")
ENDIF
CLOSE DATABASES
*-- Finde die Tabellen des neuen DBC
OPEN DATAB (tcfrom+lcdbc)
IF !EMPTY(DBC())
= ADBOBJECTS(ladbcnewtables, "table")
ENDIF
CLOSE DATABASES
*-- Finde heraus ob alte tabellen nicht mehr in dem neuen DBC vorhanden sind
OPEN DATAB (tcto+lcdbc)
SET DATAB TO (tcto+lcdbc)
= ADIR(lafromfile,tcfrom+"*.dbf", "A")
= ADIR(latofile,tcto +"*.dbf", "A")
LOCAL lcdeletefile
FOR i=1 TO ALEN(latofile,1)
*-- ist tabelle in neuen DBC
IF ASCAN(lafromfile, latofile(i,1)) = 0
DO CASE
CASE ASCAN(ladbcalttables, STRTRAN(latofile(i,1), ".DBF", "")) > 0
FREE TABLE STRTRAN(latofile(i,1), ".DBF", "")
IF lnascfile != -1
=FWRITE(lnascfile,CHR(9)+ "Not used table ==> " + tcto + UPPER(latofile(i,1)) + CHR(13)+CHR(10))
ENDIF
*!* remove table strtran(laToFile(i,1), ".DBF", "") delete
CASE ASCAN(ladbcalttables, STRTRAN(latofile(i,1), ".DBF", "")) = 0
IF lnascfile != -1
=FWRITE(lnascfile,CHR(9)+ "Not used table ==> " + tcto + UPPER(latofile(i,1)) + CHR(13)+CHR(10))
ENDIF
*!* lcDeleteFile = fullpath(tcto+laToFile[i,1])
*!* delete file (lcDeleteFile)
*!* delete file (strtran(lcDeleteFile, ".DBF", ".CDX"))
*!* delete file (strtran(lcDeleteFile, ".DBF", ".FPT"))
ENDCASE
ENDIF
ENDFOR
RELEASE lcdeletefile
RELEASE ARRAY lafromfile, latofile
CLOSE DATABASES
*!* Check and update all files
lnhowmany = ADIR(lafile,lcsavedir+"\*.dbf", "A")
DIMENSION laupdated[lnHowMany,1]
LOCAL lcfiletodelete
lcfiletodelete = ""
*-- vfx_needupdate wird verändert
FOR j = 1 TO lnhowmany
lcto = IIF(ASCAN(lavfxfiles,lafile[j,1]) > 0, tcvfxpath, tcto)
lnneedupdate = vfx_needupdate(lafile[j,1], lcsavedir, lcto, @ladbcalttables, @ladbcnewtables)
DO CASE
CASE lnneedupdate = 0
*no update need, delete in temporary directory
lcfiletodelete = FULLPATH(lcsavedir+"\"+lafile[j,1])
DELETE FILE (lcfiletodelete)
DELETE FILE (STRTRAN(lcfiletodelete, ".DBF", ".CDX"))
DELETE FILE (STRTRAN(lcfiletodelete, ".DBF", ".FPT"))
CASE lnneedupdate = 1
*update, append data from client directory into savedir directory
lnfilehandle = FOPEN(lcto+lafile[j,1],2)
IF lnfilehandle < 0
** Bingo: Error :((
lcommit = .F.
EXIT
ENDIF
laupdated[j] = lafile[j,1]
WAIT WINDOW msg_updating+" " + lafile[j,1] + " ..." NOWAIT
IF lnascfile != -1
=FWRITE(lnascfile,CHR(9)+UPPER(lcto+lafile[j,1]) + CHR(13)+CHR(10))
ENDIF
LOCAL lcmagicid
lcmagicid = ;
CHR(2) +" "+;
CHR(3) +" "+;
CHR(48) +" "+;
CHR(67) +" "+;
CHR(99) +" "+;
CHR(131)+" "+;
CHR(203)+" "+;
CHR(245)+" "+;
CHR(251)
=FSEEK(lnfilehandle,0,0)
IF (FREAD(lnfilehandle,1) $ lcmagicid)
** It'a a xBase File
CLOSE DATA ALL
** Rename BackLink to avoid database name conflict
RENAME (tcto+"\"+lcolddbcname+".dbc") TO (tcto+"\"+lcnewdbcname+".dbc")
RENAME (tcto+"\"+lcolddbcname+".dct") TO (tcto+"\"+lcnewdbcname+".dct")
RENAME (tcto+"\"+lcolddbcname+".dcx") TO (tcto+"\"+lcnewdbcname+".dcx")
IF FILE(lcto+lafile[j,1])
IF !EMPTY(readdbclink(lnfilehandle))
= writedbclink(lnfilehandle,lcnewdbcname+".dbc")
ENDIF
ENDIF
=FCLOSE(lnfilehandle)
*!* Append data...
WAIT WINDOW msg_append+" " + UPPER(lafile[j,1]) NOWAIT
USE (lcsavedir+"\"+lafile[j,1]) IN 0 ALIAS _worktable
IF FILE(lcto+lafile[j,1])
APPEND FROM (lcto+lafile[j,1])
ENDIF
USE IN _worktable
lnfilehandle = FOPEN(lcto+lafile[j,1],2)
IF !EMPTY(readdbclink(lnfilehandle))
= writedbclink(lnfilehandle,lcolddbcname+".dbc")
ENDIF
CLOSE DATA ALL
RENAME (tcto+"\"+lcnewdbcname+".dbc") TO (tcto+"\"+lcolddbcname+".dbc")
RENAME (tcto+"\"+lcnewdbcname+".dct") TO (tcto+"\"+lcolddbcname+".dct")
RENAME (tcto+"\"+lcnewdbcname+".dcx") TO (tcto+"\"+lcolddbcname+".dcx")
ENDIF
=FCLOSE(lnfilehandle)
CASE lnneedupdate = 2
*!* new, nothing to do here, the file will be copied from the temporary directory into the client directory
CASE lnneedupdate = 3
laupdated[j] = lafile[j,1]
WAIT WINDOW msg_updating+" " + lafile[j,1] + " ..." NOWAIT
IF lnascfile != -1
=FWRITE(lnascfile,CHR(9)+UPPER(lcto+lafile[j,1]) + CHR(13)+CHR(10))
ENDIF
*!* Append data...
WAIT WINDOW msg_append+" " + UPPER(lafile[j,1]) NOWAIT
USE (lcsavedir+"\"+lafile[j,1]) IN 0 ALIAS _worktable
SELECT _worktable
IF FILE(lcto+lafile[j,1])
APPEND FROM (lcto+lafile[j,1])
ENDIF
USE IN _worktable
CLOSE DATA ALL
ENDCASE
NEXT
*!* Update of all tables finished.
CLOSE DATA ALL
SET DATABASE TO
SET MESSAGE TO ''
SET MESSAGE TO
*!* Restore data from temporary directory
lnhowmany = ADIR(lafile,lcsavedir+"\*.*", "A")
WAIT WINDOW msg_restore+" " NOWAIT
FOR j = 1 TO lnhowmany
IF ".LOG" $ lafile[j,1]
LOOP
ENDIF
IF ".KEY" $ lafile[j,1]
LOOP
ENDIF
lcto = IIF(ASCAN(lavfxfiles,lafile[j,1]) > 0, tcvfxpath, tcto)
COPY FILE (lcsavedir+"\"+lafile[j,1]) TO (lcto+lafile[j,1])
NEXT
IF !lcommit OR __vfx_error
IF lnascfile != -1
=FWRITE(lnascfile,"------------------------------------------------"+CHR(13)+CHR(10)+;
"update error on " + TTOC(DATETIME()) +CHR(13)+CHR(10)+;
"------------------------------------------------"+CHR(13)+CHR(10) )
ENDIF
lcommit = .F.
ENDIF
*!* Delete saved data
WAIT WINDOW msg_delete NOWAIT
FOR j = 1 TO lnhowmany
ERASE (lcsavedir+"\"+lafile[j,1])
NEXT
RD (lcsavedir)
IF tofoxapp.lsavedatabeforeupdate
*!* Delete Backup directory
lnhowmany = ADIR(lafile,lcbackupdir+"\*.*", "A")
FOR j = 1 TO lnhowmany
ERASE (lcbackupdir+"\"+lafile[j,1])
NEXT
RD (lcbackupdir)
IF tcto <> tcvfxpath
*!* Delete VFX_Backup directory
lnhowmany = ADIR(lafile,lcvfxbackupdir+"\*.*", "A")
FOR j = 1 TO lnhowmany
ERASE (lcvfxbackupdir+"\"+lafile[j,1])
NEXT
RD (lcvfxbackupdir)
ENDIF
ENDIF
WAIT CLEAR
IF lnascfile != -1
=FWRITE(lnascfile,"------------------------------------------------"+CHR(13)+CHR(10)+;
"update finished on " + TTOC(DATETIME()) +CHR(13)+CHR(10)+;
"------------------------------------------------"+CHR(13)+CHR(10)+CHR(13)+CHR(10))
ENDIF
IF lnascfile != -1
=FCLOSE(lnascfile)
ENDIF
__vfx_error = .F.
RELEASE __vfx_error
ON ERROR &lcerror
ENDIF
SET MESSAGE TO ''
SET MESSAGE TO
WAIT CLEAR
IF lnfile != -1
=FCLOSE(lnfile)
ERASE(tcto+"UPD$CTRL.KEY")
ENDIF
SET SAFETY &lcsafety
CLOSE DATA ALL
ENDIF
RETURN .T.
ENDFUNC
PARAMETERS tctablename, tcfrom, tcto, taalttables, tanewtables
*-- Parameter kompatibilität
IF TYPE("taAltTables") = "L" OR TYPE("taAltTables") = "U"
DIMENSION taalttables(1)
ENDIF
IF TYPE("taNewTables") = "L" OR TYPE("taNewTables") = "U"
DIMENSION tanewtables(1)
ENDIF
LOCAL lnneedupdate
lnneedupdate = 0
IF FILE(tcto+tctablename)
DO CASE
*-- AltDBC(Table) = FREE and New(Table) = NOT FREE
CASE ASCAN(taalttables,STRTRAN(tctablename,".DBF", "")) = 0 AND ASCAN(tanewtables,STRTRAN(tctablename,".DBF", "")) <> 0
lnneedupdate = 3
RETURN (lnneedupdate)
*-- AltDBC(Table) = NOT FREE and New(Table) = FREE
CASE ASCAN(taalttables,STRTRAN(tctablename,".DBF", "")) <> 0 AND ASCAN(tanewtables,STRTRAN(tctablename,".DBF", "")) = 0
lnneedupdate = 3
RETURN (lnneedupdate)
OTHERWISE
*-- do nothing
ENDCASE
USE (tcfrom+"\"+tctablename) IN 0 ALIAS _tempnew SHARED AGAIN
SELECT _tempnew
=AFIELDS(__new)
USE (tcto+tctablename) IN 0 ALIAS _tempold SHARED AGAIN
IF !USED("_tempold")
USE (tcto+tctablename) IN 0 ALIAS _tempold SHARED AGAIN
ENDIF
IF !USED("_tempold")
USE (tcto+tctablename) IN 0 ALIAS _tempold SHARED AGAIN
ENDIF
SELECT _tempold
=AFIELDS(__old)
FOR ii = 1 TO 999
IF (EMPTY(KEY(ii,"_tempnew")) AND !EMPTY(KEY(ii,"_tempold"))) OR ;
(!EMPTY(KEY(ii,"_tempnew")) AND EMPTY(KEY(ii,"_tempold"))) OR ;
(KEY(ii,"_tempnew") <> KEY(ii,"_tempold")) OR ;
(TAG(ii,"_tempnew") <> TAG(ii,"_tempold")) OR ;
(IDXCOLLATE(ii,"_tempnew") <> IDXCOLLATE(ii,"_tempold")) OR ;
(DESCENDING(ii,"_tempnew") # DESCENDING(ii,"_tempold")) OR ;
(PRIMARY(ii,"_tempnew") # PRIMARY(ii,"_tempold")) OR ;
(CANDIDATE(ii,"_tempnew") # CANDIDATE(ii,"_tempold"))
lnneedupdate = 1
EXIT
ENDIF
IF EMPTY(KEY(ii,"_tempnew")) OR EMPTY(KEY(ii,"_tempold"))
EXIT
ENDIF
ENDFOR
IF lnneedupdate = 0
FOR ii = 1 TO MAX(ALEN(__new), ALEN(__old))
IF ALEN(__new) <> ALEN(__old) OR ;
__new[asubscript(__new, ii, 1), asubscript(__new, ii, 2)] <> ;
__old[asubscript(__old, ii, 1), asubscript(__old, ii, 2)]
lnneedupdate = 1
EXIT
ENDIF
ENDFOR
ENDIF
USE IN _tempnew
USE IN _tempold
ELSE
lnneedupdate = 2
ENDIF
RETURN (lnneedupdate)
ENDFUNC
DO CASE
CASE tnerror = 0
* Delete index marker.
RETURN .T.
CASE tnerror = 114
* Delete destroyed index files.
DELETE FILE (tcto+STRTRAN(tctablename,".DBF",".CDX"))
RETURN .T.
CASE tnerror = 1558
* Ignore error message caused by tables that are no more part of the new DBC.
RETURN .T.
CASE tnerror = 1707
* Delete index marker.
RETURN .T.
CASE tnerror = 1884
WAIT WINDOW msg_uniquekey TIMEOUT 1
__vfx_error = .T.
OTHERWISE
= MESSAGEBOX(MESSAGE(),48,msg_attention)
__vfx_error = .T.
ENDCASE
ENDFUNC
LOCAL loform, loformx, lcformname
loform = .NULL.
lcformname = tochildform.NAME
FOR j = 1 TO _SCREEN.FORMCOUNT
IF pemstatus(_SCREEN.FORMS[j],"_VFXClassName",5)
IF pemstatus(_SCREEN.FORMS[j],"oFormList",5)
loformx = _SCREEN.FORMS[j].oformlist.getchild(lcformname)
IF !ISNULL(loformx)
IF COMPOBJ(loformx,tochildform)
loform = _SCREEN.FORMS[j]
EXIT
ENDIF
ENDIF
ENDIF
ENDIF
NEXT
RETURN loform
ENDFUNC
LOCAL lcbuffer, j
lcbuffer = ''
j = 1
IF !EMPTY(ALIAS())
DO WHILE !EMPTY(RELATION(j))
lcbuffer = lcbuffer + RELATION(j)+" into " +TARGET(j)+','
j = j + 1
ENDDO
IF !EMPTY(lcbuffer)
lcbuffer = LOWER(LEFT(lcbuffer,LEN(lcbuffer)-1))
ENDIF
ENDIF
RETURN lcbuffer
ENDFUNC
lcxlsfile = goprogram.creportdir+"x"+SUBSTR(SYS(2015),4,7)
lcxlsfile = FULLPATH(lcxlsfile)
COPY TO (lcxlsfile) XL5
LOCAL lo
lo = CREATEOBJECT("excel")
IF VARTYPE(lo)="O"
lo.openexcel(.F., .T.)
IF VARTYPE(lo.excel)="O"
lo.addworkbook(lcxlsfile)
lo.activateworkbook(1)
lo.autoformat()
lo.setwindowstate(-4137)
ENDIF
ENDIF
DELETE FILE (lcxlsfile + ".xls")
RELEASE lo
ENDFUNC && CopytoExcel
LPARAMETERS tctext, tnvalue, tctitle, tcbuttontext1, tcbuttontext2, tcbuttontext3, tltimer, tntimeout
LOCAL lnreturn
IF VARTYPE(goprogram)="O"
DO FORM vfxaskfm WITH tctext, tnvalue, tctitle, tcbuttontext1, tcbuttontext2,;
tcbuttontext3, tltimer, tntimeout TO lnreturn
ELSE
DO FORM FORM\vfxaskfm WITH tctext, tnvalue, tctitle, tcbuttontext1, tcbuttontext2,;
tcbuttontext3, tltimer, tntimeout TO lnreturn
ENDIF
RETURN lnreturn
*-------------------------------------------------------
* Function....: getaudit()
* Called by...:
*
* Abstract....: Gets information from the audit trail.
*
* Returns.....: Textstring.
*
* Parameters..: Tablename, Recordid
*
* Notes.......:
*-------------------------------------------------------
LPARAMETERS tctablename, tnid
LOCAL lcalias, lcretval, lcscanstr, lnlastcatid, ltlastdatetime, lcdeletestring
lcalias = ALIAS()
lcretval = ""
lnlastcatid = 0
ltlastdatetime = {^9999.01.01}
lcdeletestring = ""
USE vfxaudit SHARED AGAIN IN 0 ALIAS tempaudit
IF TYPE("tnid")="C"
SELECT * FROM tempaudit ;
WHERE UPPER(TABLE)+recordid = PADR(UPPER(tctablename),8)+tnid ;
ORDER BY DATETIME ;
INTO CURSOR temp
ELSE
SELECT * FROM tempaudit ;
WHERE UPPER(TABLE)+recordid = PADR(UPPER(tctablename),8)+STR(tnid,10) ;
ORDER BY DATETIME ;
INTO CURSOR temp
ENDIF
SCAN
lcretval = changes + CHR(13) + "______________________" + CHR(13) + lcretval
ENDSCAN
USE IN tempaudit
RETURN lcretval
_audit("I")
ENDFUNC
_audit("U")
ENDFUNC
_audit("D")
ENDFUNC
LPARAMETERS tcType
IF TYPE("pldoaudit")<>"U" AND !pldoaudit
RETURN .T.
ENDIF
IF TYPE("gu_user")="U"
LOCAL gu_user
gu_user = getwinuser()
ENDIF
LOCAL lcalias, lcdbf, lcrecordid, lcchange, lddatetime, lnpknum, lcinsert;
lcfieldstate, lcfield, lcmemo, j, llchangepoolingcode, llchangeaddressname, llchangeparent, llchangemaster
lcalias = ALIAS()
lcdbf = DBF(lcalias)
lcdbf = STRTRAN(SUBSTR(lcdbf,RAT("\",lcdbf)+1),".DBF","")
lnpknum = getpknum()
IF lnpknum = 0
MESSAGEBOX("Cannot find the Primary Key for Table " + TRIM(lcdbf) + "." + CHR(13) + ;
"please contact the system administrator!", 16, _SCREEN.CAPTION)
RETURN .F.
ENDIF
lcrecordid = _tochar(EVAL(KEY(lnpknum)))
lddatetime = DATETIME()
lcfieldstate = SUBSTR(GETFLDSTATE(-1),2)
DO CASE
CASE tcType="I"
lcinsert = "Record has been inserted by " + TRIM(gu_user) + " at " + TTOC(lddatetime) + CHR(13)+CHR(10)
FOR j = 1 TO LEN(lcfieldstate)
lcfield = FIELD(j)
IF INLIST(SUBSTR(lcfieldstate,j,1),'2','4')
lcinsert = lcinsert + CHR(13)+CHR(10) + FIELD(j) + ": " + ;
STRTRAN(TRIM(_tochar(EVAL(lcfield))),CHR(10),"")
ENDIF
NEXT
INSERT INTO vfxaudit (TABLE, recordid, USER, DATETIME, changes) ;
VALUES (lcdbf, lcrecordid, gu_user, lddatetime, lcinsert)
CASE tcType="U"
lcchange = ""
FOR j = 1 TO LEN(lcfieldstate)
lcfield = FIELD(j)
IF INLIST(SUBSTR(lcfieldstate,j,1),'2','4')
IF CURSORGETPROP('Buffering') > 1
IF OLDVAL(lcfield) <> EVAL(lcfield)
lcchange = lcchange + CHR(13)+CHR(10) + FIELD(j) + ": " + ;
STRTRAN(TRIM(_tochar(OLDVAL(lcfield))),CHR(10),"") + " >>> " + ;
STRTRAN(TRIM(_tochar(EVAL(lcfield))),CHR(10),"")
ENDIF
ELSE
lcchange = lcchange + CHR(13)+CHR(10) + FIELD(j) + ": ??? >>> " + ;
STRTRAN(TRIM(_tochar(EVAL(lcfield))),CHR(10),"")
ENDIF
ENDIF
NEXT
IF !EMPTY(lcchange)
lcchange = "Record has been updated by " + TRIM(gu_user) + " at " + TTOC(lddatetime) + CHR(13)+CHR(10) + ;
lcchange
ENDIF
IF !EMPTY(lcchange)
INSERT INTO vfxaudit (TABLE, recordid, USER, DATETIME, changes) ;
VALUES (lcdbf, lcrecordid, gu_user, lddatetime, lcchange)
ENDIF
CASE tcType="D"
INSERT INTO vfxaudit (TABLE, recordid, USER, DATETIME, changes) ;
VALUES (lcdbf, lcrecordid, gu_user, lddatetime, ;
"record has been deleted by " + TRIM(gu_user) + " at " + TTOC(lddatetime) + CHR(13)+CHR(10))
ENDCASE
ENDFUNC
LOCAL lcretval, lctype
lcretval = ""
lctype = TYPE("tuParam")
DO CASE
CASE lctype = "C"
lcretval = tuparam
CASE INLIST(lctype, "N", "B", "Y")
lcretval = STR(tuparam)
CASE lctype = "L"
lcretval = IIF(tuparam, "T", "F")
CASE lctype = "D"
lcretval = DTOC(tuparam)
CASE lctype = "T"
lcretval = TTOC(tuparam)
ENDCASE
RETURN lcretval
ENDFUNC
RETURN SUBSTR(SYS(0),AT("#",SYS(0))+2)
LOCAL i, lnretval
lnretval = 0
FOR i = 1 TO 254
IF PRIMARY(i)
lnretval = i
EXIT
ENDIF
IF EMPTY(KEY(i))
EXIT
ENDIF
NEXT
RETURN lnretval
LPARAMETERS tnstart
LOCAL i, lnretval
IF TYPE("tnstart")#"N"
tnstart=1
ENDIF
lnretval = 0
FOR i = tnstart TO 254
IF CANDIDATE(i)
lnretval = i
EXIT
ENDIF
IF EMPTY(KEY(i))
EXIT
ENDIF
NEXT
RETURN lnretval
IF EMPTY(_SCREEN.ACTIVEFORM.cfavoritescx)
RETURN .F.
ENDIF
LOCAL lnolddatasession, lcpopup, lxid, lcdescr, lnelement, lcmenu, lcfieldname
lnolddatasession = SET("datasession")
SET DATASESSION TO _SCREEN.ACTIVEFORM.DATASESSIONID
IF EOF() OR BOF()
SET DATASESSION TO lnolddatasession
RETURN
ENDIF
WITH _SCREEN.ACTIVEFORM
lcpopup = .cfavoritescx
lcbitmap = JUSTFNAME(.ICON)
IF EMPTY(.cfavoritemenu)
lcmenu = _SCREEN.ACTIVEFORM.CAPTION
ELSE
lcmenu = .cfavoritemenu
ENDIF
IF AT(".",lcbitmap)>1
lcbitmap=LEFT(lcbitmap,AT(".",lcbitmap)-1)
ENDIF
IF EMPTY(.cfavoriteid)
lnpknum = getpknum()
IF lnpknum = 0
RETURN .F.
ENDIF
lcfieldname=KEY(lnpknum)
lcfieldname=STRTRAN(lcfieldname,"UPPER(","")
lcfieldname=STRTRAN(lcfieldname,"LOWER(","")
lcfieldname=STRTRAN(lcfieldname,"STR(","")
lcfieldname=STRTRAN(lcfieldname,")","")
IF TYPE(ALLTRIM(.cworkalias)+"."+lcfieldname)#"U"
lxid=EVAL(ALLTRIM(.cworkalias)+"."+lcfieldname)
ELSE
RETURN .F.
ENDIF
ELSE
lxid=EVAL(.cfavoriteid)
ENDIF
IF EMPTY(.cfavoritedescr)
lcdescr = converttochar(EVAL(FIELD(1)))
ELSE
lcdescr = EVAL(.cfavoritedescr)
ENDIF
ENDWITH
IF EMPTY(lcpopup) OR EMPTY(lxid) OR EMPTY(lcbitmap)
SET DATASESSION TO lnolddatasession
RETURN .F.
ENDIF
* Zufallszahl ermitteln
barid=INT(SECONDS()*1000)
IF !POPUP(lcpopup)
DEFINE BAR barid OF favorites PROMPT lcmenu AFTER 3
ON BAR barid OF favorites ACTIVATE POPUP (lcpopup)
DEFINE POPUP (lcpopup) MARGIN RELATIVE COLOR SCHEME 4
ENDIF
RELEASE BAR barid OF (lcpopup)
DEFINE BAR barid OF (lcpopup) PROMPT TRIM(lcdescr) BEFORE _MFIRST
ON SELECTION BAR barid OF (lcpopup) gotofavorite(POPUP(), BAR(), .F., .T.)
DO CASE
CASE CNTBAR(lcpopup) = 10
* Zufallsahl ermitteln
x = INT(SECONDS()*1000)
RELEASE BAR GETBAR(lcpopup, 10) OF (lcpopup)
DEFINE BAR x OF (lcpopup) PROMPT "More Favorites ..."
ON SELECTION BAR x OF (lcpopup) runmorefavorites(POPUP())
CASE CNTBAR(lcpopup) = 11
RELEASE BAR GETBAR(lcpopup, 10) OF (lcpopup)
ENDCASE
lnelement = ASCAN( goprogram.afavorites, lcpopup+";"+converttochar(lxid)+";")
IF ((lnelement = 0) AND !EMPTY( goprogram.afavorites[1]))
DIMENSION goprogram.afavorites[alen( goProgram.aFavorites,1)+1]
ELSE
ADEL( goprogram.afavorites, MAX(1,lnelement))
ENDIF
=AINS( goprogram.afavorites,1)
* SCX-Name(=Popupname);ID;Text;Icon;Menüname;Bar#
goprogram.afavorites[1] = lcpopup+";"+converttochar(lxid)+";"+lcdescr+";"+lcbitmap+";"+lcmenu+";"+converttochar(barid)
SET DATASESSION TO lnolddatasession
ENDPROC
IF EMPTY(tcform) OR EMPTY(barid)
RETURN
ENDIF
LOCAL llformopen, lni, lcname, lcid
lcid=""
FOR z=1 TO ALEN(goprogram.afavorites)
IF VAL(getarg(goprogram.afavorites[z],6))=barid
lcid=getarg(goprogram.afavorites[z],2)
EXIT
ENDIF
NEXT
IF EMPTY(lcid)
RETURN .F.
ENDIF
llformopen = .F.
FOR lni = 1 TO _SCREEN.FORMCOUNT
IF UPPER(_SCREEN.FORMS(lni).NAME) = "FRM"+UPPER(tcform) AND ;
_SCREEN.FORMS(lni).nformstatus = 0 AND ;
(!tlnewinstanceischildform OR EMPTY(_SCREEN.FORMS(lni).ccalledby))
llformopen = .T.
lcname=_SCREEN.FORMS(lni).NAME
IF _SCREEN.FORMS(lni).viafavorite(lcid)
ACTIVATE WINDOW (lcname)
ENDIF
EXIT
ENDIF
ENDFOR
IF !llformopen AND !tlnotopenform
goprogram.runform(tcform)
_SCREEN.ACTIVEFORM.viafavorite(lcid)
ENDIF
RETURN (llformopen AND tlnotopenform)
ENDPROC
IF TYPE("gu_favorites") == "U"
RETURN
ENDIF
WITH goprogram
gu_favorites = ""
IF !EMPTY(.afavorites[1])
FOR lni = 1 TO ALEN(.afavorites,1)
IF lni = 1
gu_favorites = .afavorites[lni]
ELSE
gu_favorites = gu_favorites + CHR(13) + .afavorites[lni]
ENDIF
ENDFOR
ENDIF
ENDWITH
ENDPROC
LOCAL lni,lcname,lxid,lcmenu
IF TYPE("gu_favorites") == "U"
RETURN
ENDIF
FOR lni=1 TO ALEN(goprogram.afavorites)
IF TYPE("goProgram.aFavorites[lni]")="C"
barid=VAL(getarg(goprogram.afavorites[lni],6))
RELEASE BAR barid OF favorites
lcname=getarg(goprogram.afavorites[lni],1)
RELEASE POPUP (lcname)
ENDIF
ENDFOR
goprogram.afavorites[1] = .F.
FOR lni = 1 TO MEMLINES(gu_favorites)
DIMENSION goprogram.afavorites[lni]
goprogram.afavorites[lni] = MLINE(gu_favorites, lni)
ENDFOR
FOR lni = 1 TO MEMLINES(gu_favorites)
IF !POPUP(getarg(goprogram.afavorites[lni],1))
lcname=getarg(goprogram.afavorites[lni],1)
lxid=VAL(getarg(goprogram.afavorites[lni],2))
lcmenu=getarg(goprogram.afavorites[lni],5)
barid=VAL(getarg(goprogram.afavorites[lni],6))
DEFINE BAR barid OF favorites PROMPT (lcmenu) AFTER 3
ON BAR barid OF favorites ACTIVATE POPUP (lcname)
DEFINE POPUP (lcname) MARGIN RELATIVE COLOR SCHEME 4
ENDIF
DO CASE
CASE CNTBAR(getarg(goprogram.afavorites[lni],1)) < 9
lnbar = VAL(getarg(goprogram.afavorites[lni],6))
lcbar = getarg(goprogram.afavorites[lni],1)
lcprompt = TRIM(getarg(goprogram.afavorites[lni],3))
DEFINE BAR lnbar OF (lcbar) PROMPT lcprompt
ON SELECTION BAR lnbar OF (lcbar) gotofavorite(POPUP(), BAR(), .F., .T.)
CASE CNTBAR(getarg(goprogram.afavorites[lni],1)) = 9
lnbar = INT(SECONDS()*1000)
lcbar = getarg(goprogram.afavorites[lni],1)
DEFINE BAR lnbar OF (lcbar) PROMPT "More Favorites ..."
ON SELECTION BAR lnbar OF (lcbar) runmorefavorites(POPUP())
ENDCASE
ENDFOR
ENDPROC
LOCAL loform
loform = CREATEOBJECT("cManageFavorites")
loform.SHOW()
RELEASE loform
ENDPROC
LPARAMETERS lcpopup
LOCAL loform
loform = CREATEOBJECT("cMoreFavorites", lcpopup)
loform.SHOW()
RELEASE loform
ENDPROC
IF ISNULL(toform) .OR. TYPE("toForm") <> "O"
RETURN .F.
ENDIF
IF ISNULL(toform.DATAENVIRONMENT) .OR. TYPE("toForm.dataenvironment") <> "O"
RETURN .F.
ENDIF
IF ISNULL(tctodbc) .OR. EMPTY(tctodbc) .OR. TYPE("tcToDbc") <> "C"
LOCAL lcdbc, llretval
lcdbc = ""
IF !EMPTY(DBC())
lcdbc = ALLTRIM(DBC())
ELSE
IF !ISNULL(goprogram) .AND. TYPE("goProgram") == "O"
lcdbc = ALLTRIM(goprogram.cdatadir) + "\" + ALLTRIM(goprogram.cmaindatabase)
ENDIF
ENDIF
lcdbc = IIF(".DBC" $ UPPER(lcdbc), UPPER(lcdbc), UPPER(lcdbc)+".DBC")
IF EMPTY(lcdbc)
RETURN .F.
ENDIF
tctodbc = lcdbc
ENDIF
IF ISNULL(tcfromdbc) .OR. EMPTY(tcfromdbc) .OR. TYPE("tcFromDbc") <> "C"
tcfromdbc = ""
ENDIF
IF EMPTY(JUSTPATH(tcfromdbc)) .AND. PARAMETERS() = 3
RETURN .F.
ENDIF
IF EMPTY(JUSTPATH(tctodbc))
RETURN .F.
ENDIF
LOCAL lcfrompath, lctopath, lctmppath, lcvfxpath
lcfrompath = JUSTPATH(TRIM(tcfromdbc)) + "\"
lctopath = JUSTPATH(TRIM(tctodbc)) + "\"
lcvfxpath = ""
lctmppath = ""
IF !ISNULL(goprogram.cvfxdir) AND !EMPTY(goprogram.cvfxdir)
lcvfxpath = JUSTPATH(TRIM(goprogram.cvfxdir)) + "\"
lcvfxpath = lcvfxpath + IIF(RIGHT(TRIM(goprogram.cvfxdir),1) = "\", "", "\")
IF LEFT(lcvfxpath,2) = ".."
lctmppath = FULLPATH("")
CD..
lcvfxpath = IIF(LEFT(lcvfxpath,1) = "..\", SUBSTR(lcvfxpath,4), SUBSTR(lcvfxpath,3))
lcvfxpath = FULLPATH(lcvfxpath)
CD (lctmppath)
ELSE
lcvfxpath = FULLPATH(lcvfxpath)
ENDIF
ENDIF
IF !EMPTY(lcfrompath)
IF LEFT(lcfrompath,2) = ".."
lctmppath = FULLPATH("")
CD..
lcfrompath = IIF(LEFT(lcfrompath,1) = "..\", SUBSTR(lcfrompath,4), SUBSTR(lcfrompath,3))
lcfrompath = FULLPATH(lcfrompath)
CD (lctmppath)
IF DIRECTORY(lcfrompath)
tcfromdbc = lcfrompath + JUSTFNAME(tcfromdbc)
ELSE
RETURN .F.
ENDIF
ELSE
lcfrompath = FULLPATH(lcfrompath)
ENDIF
ENDIF
IF !EMPTY(lctopath)
IF LEFT(lctopath,2) = ".."
lctmppath = FULLPATH("")
CD..
lctopath = IIF(LEFT(lctopath,1) = "..\", SUBSTR(lctopath,4), SUBSTR(lctopath,3))
lctopath = FULLPATH(lctopath)
CD (lctmppath)
IF DIRECTORY(lctopath)
tctodbc = lctopath + JUSTFNAME(tctodbc)
ELSE
RETURN .F.
ENDIF
ELSE
lctopath = FULLPATH(lctopath)
ENDIF
ENDIF
IF !EMPTY(tcfromdbc)
tcfromdbc = UPPER(ALLTRIM(tcfromdbc))
tcfromdbc = IIF(".DBC" $ tcfromdbc, tcfromdbc, tcfromdbc+".DBC")
ENDIF
tctodbc = UPPER(ALLTRIM(tctodbc))
tctodbc = IIF(".DBC" $ tctodbc, tctodbc, tctodbc+".DBC")
IF tcfromdbc == tctodbc
RETURN .T.
ENDIF
LOCAL ARRAY lacursorobj(1)
lacursorobj = .NULL.
IF AMEMBERS(lacursorobj,toform.DATAENVIRONMENT,2) > 0
LOCAL i, locursorobj
FOR i = 1 TO ALEN(lacursorobj,1)
locursorobj = EVAL("toform.DataEnvironment."+lacursorobj(i))
IF TYPE("loCursorObj") == "O"
IF UPPER(locursorobj.BASECLASS) == "CURSOR"
IF !EMPTY(locursorobj.DATABASE) && it's free table?
IF EMPTY(tcfromdbc)
locursorobj.DATABASE = lctopath + JUSTFNAME(tctodbc)
ELSE
IF UPPER(ALLTRIM(locursorobj.DATABASE)) == lcfrompath + JUSTFNAME(tcfromdbc)
locursorobj.DATABASE = lctopath + JUSTFNAME(tctodbc)
ENDIF
ENDIF
ELSE
IF goprogram.isfreevfxtable(locursorobj.CURSORSOURCE)
lctmppath = lcvfxpath
ELSE
lctmppath = lctopath
ENDIF
IF UPPER(TRIM(JUSTPATH(locursorobj.CURSORSOURCE))) + "\" <> UPPER(TRIM(lctmppath))
LOCAL lccursorsource
lccursorsource = ""
lccursorsource = lccursorsource + TRIM(lctmppath)
lccursorsource = lccursorsource + IIF(RIGHT(lccursorsource,1) = "\", "", "\")
lccursorsource = lccursorsource + TRIM(JUSTFNAME(locursorobj.CURSORSOURCE))
locursorobj.CURSORSOURCE = lccursorsource
ENDIF
ENDIF
ENDIF
ENDIF
ENDFOR
ENDIF
RETURN .T.
ENDFUNC
IF ISNULL(toform) .OR. TYPE("toForm") <> "O"
RETURN .F.
ENDIF
IF ISNULL(toform.DATAENVIRONMENT) .OR. TYPE("toForm.dataenvironment") <> "O"
RETURN .F.
ENDIF
IF ISNULL(tcdbc) .OR. EMPTY(tcdbc) .OR. TYPE("tcToDbc") <> "C"
LOCAL lcdbc, llretval
lcdbc = ""
IF !EMPTY(DBC())
lcdbc = ALLTRIM(DBC())
ELSE
IF !ISNULL(goprogram) .AND. TYPE("goProgram") == "O"
LOCAL lcdatapath, lctmppath
lcdatapath = TRIM(goprogram.cdatadir) + "\"
lctmppath = ""
IF LEFT(lcdatapath,2) = ".."
lctmppath = FULLPATH("")
CD..
lcdatapath = IIF(LEFT(lcdatapath,1) = "..\", SUBSTR(lcdatapath,4), SUBSTR(lcdatapath,3))
lcdatapath = FULLPATH(lcdatapath)
CD (lctmppath)
IF !DIRECTORY(lcdatapath)
lcdatapath = ""
ENDIF
ELSE
lcdatapath = FULLPATH(lcdatapath)
ENDIF
IF !EMPTY(lcdatapath)
lcdbc = lcdatapath + ALLTRIM(goprogram.cmaindatabase)
ELSE
lcdbc = ""
ENDIF
ENDIF
ENDIF
IF EMPTY(lcdbc)
RETURN .F.
ENDIF
lcdbc = IIF(".DBC" $ UPPER(lcdbc), UPPER(lcdbc), UPPER(lcdbc)+".DBC")
tcdbc = lcdbc
ENDIF
LOCAL ARRAY lacursorobj(1)
lacursorobj = .NULL.
IF AMEMBERS(lacursorobj,toform.DATAENVIRONMENT,2) > 0
LOCAL i, locursorobj
FOR i = 1 TO ALEN(lacursorobj,1)
locursorobj = EVAL("toForm.DataEnvironment."+lacursorobj(i))
IF TYPE("loCursorObj") == "O"
IF UPPER(locursorobj.BASECLASS) == "CURSOR"
IF !EMPTY(locursorobj.DATABASE)
IF UPPER(ALLTRIM(locursorobj.DATABASE)) <> tcdbc
llretval = .T.
EXIT
ENDIF
ELSE
LOCAL lctmppath
IF goprogram.isfreevfxtable(locursorobj.CURSORSOURCE)
lctmppath = goprogram.cvfxdir
ELSE
lctmppath = FULLPATH(JUSTPATH(tcdbc)) + "\"
ENDIF
IF UPPER(FULLPATH(TRIM(JUSTPATH(locursorobj.CURSORSOURCE)))) + "\" <> UPPER(TRIM(lctmppath))
llretval = .T.
EXIT
ENDIF
ENDIF
ENDIF
ENDIF
ENDFOR
ENDIF
RETURN llretval
ENDFUNC
LOCAL lcwindir
lcwindir = ""
lcwindir = STRTRAN(GETENV("windir") + "\", "\\", "\")
IF EMPTY(lcwindir)
RETURN .F.
ENDIF
IF !FILE((lcwindir) + "foxuser.dbf")
COPY FILE "_foxuser.dbf" TO (lcwindir) + "foxuser.dbf"
COPY FILE "_foxuser.fpt" TO (lcwindir) + "foxuser.fpt"
ENDIF
ENDFUNC
LPARAMETERS tcsql
LOCAL lcretvalue
lcretvalue = tcsql
LOCAL lnargcount, lcsymbol, lcvalue, lctext, k
lnargcount = OCCURS('?',tcsql)
IF lnargcount > 0
LOCAL lnpos
FOR lnpos=1 TO lnargcount
lcsymbol = SUBSTR(tcsql,AT('?',tcsql,lnpos)+1)
lctext = ''
FOR k = 1 TO LEN(lcsymbol)
IF LOWER(SUBSTR(lcsymbol,k,1)) $ "abcdefghijklmnopqrstuvwxyz0123456789_"
lctext = lctext + SUBSTR(lcsymbol,k,1)
ELSE
EXIT
ENDIF
NEXT
IF !EMPTY(lctext)
lcretvalue = STRTRAN(lcretvalue, "?"+ALLTRIM(lctext), "null")
ENDIF
NEXT
ENDIF
RETURN lcretvalue
LPARAMETERS tcdsn
IF EMPTY(NVL(tcdsn,""))
tcdsn = .NULL.
ENDIF
RETURN IIF(EMPTY(NVL(tcdsn,"")), -1, SQLCONNECT(tcdsn, "", ""))
LPARAMETERS tnconnection, tcsql, tccursor, tlnodisperror
SET MESSAGE TO TRIM(LEFT(tcsql, 255))
LOCAL lnok
IF !EMPTY(tccursor)
lnok = sqlexec(tnconnection, tcsql, tccursor)
ELSE
lnok = sqlexec(tnconnection, tcsql)
ENDIF
IF VARTYPE(lnok)<> "N" OR lnok <= 0
LOCAL laerror[1,7]
AERROR(laerror)
IF !tlnodisperror
DO CASE
CASE laerror[1,5] = 8115
=MESSAGEBOX(MSG_SERVERERROR8115,16,MSG_ERRORWRITINGTOSERVER)
OTHERWISE
=MESSAGEBOX(MSG_SERVERERROR + CHR(13) + CHR(13) + ;
laerror[1,3] + CHR(13) + CHR(13) + ;
MSG_CONTACTADMIN,16,MSG_ERRORWRITINGTOSERVER)
ENDCASE
ENDIF
PUBLIC glastvfxsqlexecerror
glastvfxsqlexecerror = laerror[1,3]
ENDIF
SET MESSAGE TO
RETURN IIF(VARTYPE(lnok)="N", lnok, -1)
DEFINE CLASS cconnectionmgr AS CUSTOM
HIDDEN aconnections[1]
HIDDEN cdsnname, cuserid, cpassword, cconnectionname
*---------------------
* initialisierung
THIS.aconnections[1] = -1
THIS.cconnectionname = IIF(EMPTY(NVL(tcconnectionname,"")), .NULL., tcconnectionname)
THIS.cdsnname = IIF(EMPTY(NVL(tcdsnname,"")), .NULL., tcdsnname)
THIS.cuserid = IIF(EMPTY(NVL(tcuserid,"")), .NULL., tcuserid)
THIS.cpassword = IIF(EMPTY(NVL(tcpassword,"")), .NULL., tcpassword)
*-- this.add(this.getConnection())
ENDPROC
LOCAL lnconnectioncount, lnconn
lnconnectioncount = ALEN(THIS.aconnections,1)
LOCAL lnsqlconnection
lnsqlconnection = -1
* Nach einer freien SQL Connection suchen
FOR lnconn = 1 TO lnconnectioncount
IF NVL(THIS.aconnections[lnConn],0) > 0 AND !sqlgetprop(THIS.aconnections[lnConn], "ConnectBusy")
lnsqlconnection = THIS.aconnections[lnConn]
EXIT
ENDIF
NEXT
IF (lnsqlconnection = -1)
* Keine freie SQL Connection wurde gefunden
* Eine neue SQL Connection aufbauen
lnsqlconnection = THIS.createnewconnection()
ENDIF
RETURN lnsqlconnection
ENDFUNC
* Count number of existing Connections
LOCAL lnconnectioncount
lnconnectioncount = 0
IF (tnsqlconnection > 0)
* Connection is valid
IF ! ISNULL(THIS.aconnections[1])
lnconnectioncount = ALEN(THIS.aconnections, 1)
ENDIF
lnconnectioncount = lnconnectioncount + 1
DIMENSION THIS.aconnections[lnConnectionCount]
THIS.aconnections[lnConnectionCount] = tnsqlconnection
ENDIF
RETURN lnconnectioncount
ENDFUNC
LOCAL lnconnectioncount, lnconn
lnconnectioncount = ALEN(THIS.aconnections,1)
FOR lnconn = 1 TO lnconnectioncount
IF NVL(THIS.aconnections[lnConn], 0) > 1
sqldisconnect(THIS.aconnections[lnConn])
THIS.aconnections[lnConn] = -1
ENDIF
NEXT
ENDPROC
THIS.cconnectionname = tcconnectionname
ENDPROC
THIS.cdsnname = tcdsnname
ENDPROC
THIS.cuserid = tcuserid
ENDPROC
THIS.cpassword = tcpassword
ENDPROC
RETURN THIS.cconnectionname
ENDPROC
RETURN THIS.cdsnname
ENDPROC
RETURN THIS.cuserid
ENDPROC
RETURN THIS.cpassword
ENDPROC
RELEASE THIS
ENDPROC
* Alle SQL-Connections wieder freigeben
THIS.FREE()
ENDPROC
LOCAL lcvfxsysidalias, lctablealias, lctablename, lnmaxid
LOCAL lcoldonerror, llerror, lnprimarykey
lcoldonerror = ON("error")
ON ERROR llerror = .T.
lcvfxsysidalias = "VFXSYSID" + SYS(2015)
USE vfxsysid IN 0 ALIAS (lcvfxsysidalias) EXCLUSIVE
SELECT (lcvfxsysidalias)
ON ERROR &lcoldonerror
IF (llerror)
MESSAGEBOX(MSG_VFXSYSIDNOTEXCL, 64, MSG_REFRESHID)
ELSE
LOCAL lcolddeleted
lcolddeleted = SET("DELETED")
SET DELETED OFF
SCAN
lctablealias = ALLTRIM(keyname) + SYS(2015)
lctablename = ALLTRIM(keyname)
SET MESSAGE TO lctablename
IF FILE(lctablename+".dbf")
USE (lctablename) IN 0 ALIAS (lctablealias) AGAIN SHARED
SELECT (lctablealias)
lnprimarykey = getpknum()
IF !EMPTY(lnprimarykey)
SET ORDER TO lnprimarykey DESCENDING
LOCATE
lnmaxid = EVALUATE(FIELD(lnprimarykey))
SELECT (lcvfxsysidalias)
IF VAL(VALUE) < lnmaxid
REPLACE VALUE WITH PADL(TRANSFORM(lnmaxid),MAXLEN,"0")
ENDIF
ENDIF
USE IN (lctablealias)
ENDIF
ENDSCAN
SET DELETED &lcolddeleted
SET MESSAGE TO
ENDIF
IF USED(lcvfxsysidalias)
USE IN (lcvfxsysidalias)
MESSAGEBOX(MSG_IDSYNCHCOMPLETED, 64, _SCREEN.CAPTION)
ENDIF
RETURN
*--
* idsynch function to synchronize vfxsysid in c/s environment. dbf Version see above
*--
SET POINT TO "."
IF MESSAGEBOX(MSG_ASKSYNCH,36,_SCREEN.CAPTION) <> idyes
RETURN
ENDIF
LOCAL lnselect, lcdecimals, lnconnection, lcsql, lnok, llok
llok = .T.
lnconnection = vfxsqlconnect()
IF lnconnection < 0
=MESSAGEBOX(MSG_NOCONNECTION,16,_SCREEN.CAPTION)
RETURN .F.
ELSE
** öffne vfxsysid
lnselect = SELECT()
SELECT 0
USE vfxsysid ALIAS _vfxsysid EXCL AGAIN
sqldisconnect(lnconnection)
USE IN _vfxsysid
SELECT (lnselect)
=MESSAGEBOX(MSG_IDSYNCHCOMPLETED, 64,_SCREEN.CAPTION)
ENDIF
RETURN .T.
LPARAMETERS tnconnection, tckeyname, tctablename, tckeyfieldname
lcsql = "select max(" + tckeyfieldname + ") _max from " + tctablename
lnok = vfxsqlexec(tnconnection, lcsql, "__Cursor")
IF lnok <= 0
llok = .F.
ELSE
SELECT _vfxsysid
LOCATE FOR keyname = PADR(tckeyname,LEN(keyname))
IF !FOUND()
APPEND BLANK
REPLACE keyname WITH tckeyname
ENDIF
IF INT(VAL(_vfxsysid.VALUE)) <> NVL(__cursor._max, 0)
IF !EMPTY(NVL(__cursor._max, 0))
REPLACE VALUE WITH RIGHT("0000000000" + ALLTRIM(STR(__cursor._max,10,0)), 10)
ELSE
REPLACE VALUE WITH "0000000000"
ENDIF
ENDIF
USE IN "__Cursor"
ENDIF
ENDFUNC
LOCAL loparentform
loparentform = .NULL.
DO WHILE TYPE("toControl.parent") # "U"
IF LOWER(tocontrol.PARENT.BASECLASS) = "form"
loparentform = tocontrol.PARENT
EXIT
ENDIF
* walk up
tocontrol = tocontrol.PARENT
ENDDO
RETURN loparentform
ENDFUNC
LOCAL lnZ,lnY,lcZ
lcZ=""
lnZ=0
IF LOWER(tcObj.baseclass)="pageframe" && activepage!
lnZ=m.lnZ+1
LOCAL laValues[lnZ,2]
laValues[lnZ,1]=tcObj.tabindex
laValues[lnZ,2]=collectoledata(tcObj.pages[tcObj.activepage])
ELSE
FOR EACH oObj IN tcObj.controls
IF PEMSTATUS(oObj,"value",5)
IF PEMSTATUS(oObj,"tabindex",5)
lnZ=m.lnZ+1
LOCAL laValues[lnZ,2]
laValues[lnZ,1]=oObj.tabindex
laValues[lnZ,2]=TRANSFORM(oObj.value)
ENDIF
ENDIF
IF LOWER(oObj.baseclass)="container"
lnZ=m.lnZ+1
LOCAL laValues[lnZ,2]
laValues[lnZ,1]=oObj.tabindex
laValues[lnZ,2]=collectoledata(oObj)
ENDIF
ENDFOR
ENDIF
IF m.lnZ>0
=ASORT(laValues,1)
FOR lnY=1 TO m.lnZ
lcZ=m.lcZ+laValues[m.lnY,2]+CHR(13)
NEXT
ENDIF
RETURN m.lcZ
LPARAMETERS toPageframe
LOCAL loPage
FOR EACH oPage IN toPageframe.Pages
IF oPage.PageOrder = toPageframe.ActivePage
loPage = oPage
EXIT
ENDIF
ENDFOR
RETURN loPage
*-------------------------------------------------------
* Function....: previewon
* Called by...:
*
* Abstract....: Store the position of the preview toolbar
*
* Notes.......:
*-------------------------------------------------------
IF VERSION(2)=2
RETURN .T.
ENDIF
LOCAL lcTempresource,llUse,lnSelect
lnSelect=SELECT()
lcTempresource="X"+SUBSTR(SYS(2015),4,7)
CREATE TABLE (lcTempresource) FREE;
(type c(12), id c(12), name m, readonly l, ckval n(6,0), data m,updated d)
IF USED("vfxres")
llUse=.F.
ELSE
llUse=.T.
USE (goprogram.cvfxdir+"vfxres") SHARED AGAIN IN 0
ENDIF
IF SEEK(UPPER(gu_user)+"VFX_PREVIEW_TOOLBAR","vfxres","user")
INSERT INTO (lcTempresource) VALUES (;
SUBSTR(vfxres.objname,20,12),;
SUBSTR(vfxres.objname,32,12),;
vfxres.index,;
vfxres.descending,;
VAL(SUBSTR(vfxres.objname,44,6)),;
vfxres.layout,;
DATE())
ENDIF
IF llUse
USE IN vfxres
ENDIF
USE IN (lcTempresource)
SET RESOURCE TO (lcTempresource)
SELECT(lnSelect)
RETURN .T.
*-------------------------------------------------------
* Function....: previewoff
* Called by...:
*
* Abstract....: Store the position of the preview toolbar
*
* Notes.......:
*-------------------------------------------------------
IF VERSION(2)=2
RETURN .T.
ENDIF
LOCAL lcTempresource,lnSelect
lnSelect=SELECT()
lcTempresource=SYS(2005)
SET RESOURCE OFF
USE (lcTempresource) IN 0 ALIAS tempresource
SELECT tempresource
LOCATE FOR id="TTOOLBAR "
IF FOUND()
IF USED("vfxres")
llUse=.F.
ELSE
llUse=.T.
USE (goprogram.cvfxdir+"vfxres") SHARED AGAIN IN 0
ENDIF
IF !SEEK(UPPER(gu_user)+"VFX_PREVIEW_TOOLBAR","vfxres","user")
SELECT vfxres
APPEND BLANK
ENDIF
REPLACE user WITH gu_user,;
objname WITH "VFX_PREVIEW_TOOLBAR"+tempresource.type+tempresource.id+STR(tempresource.ckval,6),;
index WITH tempresource.name,;
descending WITH tempresource.readonly,;
layout WITH tempresource.data IN vfxres
IF llUse
USE IN vfxres
ENDIF
ENDIF
USE IN tempresource
lcTempresource=LEFT(lcTempresource,LEN(lcTempresource)-4)
DELETE FILE (lcTempresource+".dbf")
DELETE FILE (lcTempresource+".fpt")
SELECT(lnSelect)
RETURN .T.