*-------------------------------------------------------------------------------------------------------------------------------------------------------- * (EN) AUTOGENERATED - ATTENTION!! - NOT INTENDED FOR EXECUTION!! USE ONLY FOR MERGING CHANGES AND STORING WITH SCM TOOLS!! *-------------------------------------------------------------------------------------------------------------------------------------------------------- *< FOXBIN2PRG: Version="1.21" SourceFile="_table.vcx" CPID="1252" /> (Solo para binarios VFP 9 / Only for VFP 9 binaries) * * DEFINE CLASS _filterdialog AS _form OF "_base.vcx" *< CLASSDATA: Baseclass="form" Timestamp="" Scale="Pixels" Uniqueid="" /> *-- OBJECTDATA items order determines ZOrder / El orden de los items OBJECTDATA determina el ZOrder *< OBJECTDATA: ObjPath="shpExpressionFrame" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="shpFilterFrame" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="lblOrder" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="lblTables" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="lblCriteria" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cboOperator" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="edtSought" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cmdAdd" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="lstQueryParts" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cboOrder" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cboTables" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cmdOK" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cmdReset" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cmdCancel" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cmdDelete" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cmdUp" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cmdDown" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cmdOr" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cboFieldname" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cusTable" UniqueID="" Timestamp="" /> #INCLUDE "_table.h" * *m: brackets *m: cleanparens *m: editquery *m: fset *m: nobrack *m: notag *m: ontag *m: qreset *m: qset *m: setaction *m: setinitialqueryparts *m: setrowsources *m: settags *m: setupfilter && This takes the conditions listed in the dialog and rationalizes them into a filter expression (it also applies the NORMALIZE() function to the expression). *p: cfilter && This is the filter expression. *p: coldexact *p: ibact *p: iqptr *p: iquerymax *p: iselect *p: ocaller *a: adbfs[1,0] *a: aflds[1,0] *a: aquery[1,0] *a: atags[1,0] * * AutoCenter = .T. BorderStyle = 0 Caption = ("Filter Conditions ") cfilter = ("") ClipControls = .F. Closable = .T. coldexact = ("OFF") DoCreate = .T. FontName = "MS Sans Serif" FontSize = 8 HalfHeightCaption = .F. Height = 326 ibact = 0 iqptr = 0 iquerymax = 50 iselect = 0 MaxButton = .F. MinButton = .T. Movable = .T. Name = "_filterdialog" ocaller = .NULL. Width = 389 ZoomBox = .F. * ADD OBJECT 'cboFieldname' AS _combobox WITH ; BorderStyle = 1, ; Enabled = .T., ; FontBold = .F., ; FontName = "MS Sans Serif", ; FontSize = 9, ; Height = 20, ; Left = 12, ; Name = "cboFieldname", ; ReleaseErase = .F., ; RowSource = "", ; RowSourceType = 5, ; Sorted = .F., ; SpecialEffect = 0, ; Style = 2, ; TabIndex = 5, ; Top = 46, ; Value = 1, ; Width = 108 *< END OBJECT: ClassLib="_base.vcx" BaseClass="combobox" /> ADD OBJECT 'cboOperator' AS _combobox WITH ; Enabled = .T., ; FirstElement = 1, ; FontBold = .F., ; FontName = "MS Sans Serif", ; FontSize = 9, ; Height = 20, ; Left = 127, ; Name = "cboOperator", ; ReleaseErase = .F., ; RowSource = "=,<>,<,>,<=,>=,==,IN", ; RowSourceType = 1, ; Sorted = .T., ; SpecialEffect = 0, ; Style = 2, ; TabIndex = 6, ; Top = 46, ; Value = ("="), ; Width = 32 *< END OBJECT: ClassLib="_base.vcx" BaseClass="combobox" /> ADD OBJECT 'cboOrder' AS _combobox WITH ; BorderStyle = 1, ; Enabled = .T., ; FontBold = .F., ; FontName = "MS Sans Serif", ; FontSize = 9, ; Height = 20, ; Left = 271, ; Name = "cboOrder", ; ReleaseErase = .F., ; RowSourceType = 5, ; Sorted = .F., ; SpecialEffect = 0, ; Style = 2, ; TabIndex = 4, ; Top = 5, ; Value = 1, ; Width = 112 *< END OBJECT: ClassLib="_base.vcx" BaseClass="combobox" /> ADD OBJECT 'cboTables' AS _combobox WITH ; BorderStyle = 1, ; Enabled = .T., ; FontBold = .F., ; FontName = "MS Sans Serif", ; FontSize = 9, ; Height = 20, ; Left = 50, ; Name = "cboTables", ; ReleaseErase = .F., ; RowSourceType = 5, ; Sorted = .F., ; SpecialEffect = 0, ; Style = 2, ; TabIndex = 2, ; Top = 5, ; Value = 1, ; Width = 155 *< END OBJECT: ClassLib="_base.vcx" BaseClass="combobox" /> ADD OBJECT 'cmdAdd' AS _commandbutton WITH ; AutoSize = .F., ; Caption = "\ ADD OBJECT 'cmdCancel' AS _commandbutton WITH ; AutoSize = .F., ; Cancel = .T., ; Caption = "Cancel", ; FontName = "MS Sans Serif", ; FontSize = 9, ; Height = 25, ; Left = 204, ; Name = "cmdCancel", ; ReleaseErase = .F., ; TabIndex = 17, ; Top = 288, ; Width = 51 *< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" /> ADD OBJECT 'cmdDelete' AS _commandbutton WITH ; AutoSize = .F., ; Caption = "\ ADD OBJECT 'cmdDown' AS _commandbutton WITH ; AutoSize = .F., ; Caption = "Do\ ADD OBJECT 'cmdOK' AS _commandbutton WITH ; AutoSize = .F., ; Caption = "OK", ; FontName = "MS Sans Serif", ; FontSize = 9, ; Height = 25, ; Left = 128, ; Name = "cmdOK", ; ReleaseErase = .F., ; TabIndex = 16, ; Top = 288, ; Width = 51 *< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" /> ADD OBJECT 'cmdOr' AS _commandbutton WITH ; AutoSize = .F., ; Caption = "\ ADD OBJECT 'cmdReset' AS _commandbutton WITH ; AutoSize = .F., ; Caption = "\ ADD OBJECT 'cmdUp' AS _commandbutton WITH ; AutoSize = .F., ; Caption = "\ ADD OBJECT 'cusTable' AS _table WITH ; Left = 211, ; Name = "cusTable", ; Top = 4 *< END OBJECT: ClassLib="_table.vcx" BaseClass="custom" /> ADD OBJECT 'edtSought' AS _editbox WITH ; AllowTabs = .F., ; BorderStyle = 1, ; DisabledBackColor = 223,223,223, ; Enabled = .T., ; FontName = "MS Sans Serif", ; FontSize = 9, ; Format = "3K", ; Height = 20, ; Left = 164, ; Margin = 0, ; Name = "edtSought", ; ReleaseErase = .F., ; ScrollBars = 0, ; SpecialEffect = 0, ; TabIndex = 7, ; Top = 46, ; Width = 212 *< END OBJECT: ClassLib="_base.vcx" BaseClass="editbox" /> ADD OBJECT 'lblCriteria' AS _label WITH ; AutoSize = .T., ; Caption = (" Criteria "), ; DisabledBackColor = 225,225,225, ; FontName = "MS Sans Serif", ; FontSize = 9, ; Height = 15, ; Left = 13, ; Name = "lblCriteria", ; ReleaseErase = .F., ; TabIndex = 8, ; Top = 90, ; Width = 40 *< END OBJECT: ClassLib="_base.vcx" BaseClass="label" /> ADD OBJECT 'lblOrder' AS _label WITH ; AutoSize = .T., ; BackStyle = 0, ; Caption = ("Ord\ ADD OBJECT 'lblTables' AS _label WITH ; AutoSize = .T., ; BackStyle = 0, ; Caption = ("\ ADD OBJECT 'lstQueryParts' AS _listbox WITH ; Enabled = .F., ; FontName = "MS Sans Serif", ; FontSize = 9, ; Height = 126, ; IntegralHeight = .T., ; Left = 14, ; Name = "lstQueryParts", ; ReleaseErase = .F., ; RowSourceType = 5, ; SpecialEffect = 0, ; TabIndex = 9, ; Top = 107, ; Value = 1, ; Width = 359 *< END OBJECT: ClassLib="_base.vcx" BaseClass="listbox" /> ADD OBJECT 'shpExpressionFrame' AS _shape WITH ; BackStyle = 0, ; FillStyle = 1, ; Height = 46, ; Left = 5, ; Name = "shpExpressionFrame", ; ReleaseErase = .F., ; SpecialEffect = 0, ; Top = 34, ; Width = 379 *< END OBJECT: ClassLib="_base.vcx" BaseClass="shape" /> ADD OBJECT 'shpFilterFrame' AS _shape WITH ; BackStyle = 0, ; FillStyle = 1, ; Height = 179, ; Left = 4, ; Name = "shpFilterFrame", ; ReleaseErase = .F., ; SpecialEffect = 0, ; Top = 98, ; Width = 379 *< END OBJECT: ClassLib="_base.vcx" BaseClass="shape" /> PROCEDURE Activate LOCAL lidbc, liIndex LOCAL ARRAY laTemp[1,2] lidbc=AUSED(laTemp) THIS.iSelect = SELECT() THIS.cOldExact = SET("EXACT") SET EXACT OFF IF lidbc # ALEN(THIS.aDbfs) OR ; EMPTY(THIS.aDbfs[1]) && empty array will happen only the first time WAIT WINDOW NOWAIT LEFT(FILTER_CHECKING_OPEN_TABLES_LOC,254) IF lidbc = 0 USE ? IF EMPTY(ALIAS()) WAIT WINDOW LEFT(FILTER_CANCELLED_LOC,254) NOWAIT NODEFAULT RETURN .F. ELSE lidbc = 1 THIS.aDbfs[1] = PROPER(ALIAS()) THIS.cboTables.Requery() THIS.cboTables.Value = 1 ENDIF ELSE DIME THIS.aDbfs[lidbc] FOR liIndex = 1 TO lidbc THIS.aDbfs[liIndex] = PROPER(laTemp[liIndex,1]) ENDFOR THIS.cboTables.Requery() ENDIF WAIT CLEAR ENDIF IF EMPTY(ALIAS()) SELECT (THIS.aDbfs[1]) THIS.cboTables.Value = 1 ELSE THIS.cboTables.Value = ASCAN(THIS.aDbfs,PROPER(ALIAS())) ENDIF LOCAL lcFilter lcFilter = SET("FILTER") DO CASE CASE TYPE("THIS.oCaller.Name") = "C" THIS.SetInitialQueryParts(THIS.oCaller.cFilter) CASE THIS.SetupFilter() AND ; (THIS.cFilter == lcFilter) * don't touch CASE EMPTY(lcFilter) THIS.SetInitialQueryParts("") OTHERWISE THIS.SetInitialQueryParts(lcFilter) ENDCASE THIS.SetAction() ENDPROC PROCEDURE brackets LPARAMETERS tcx, tcb1, tcb2 LOCAL lcout, lii, lcv, lcx IF SUBSTR(tcx,1,1)=tcb1 AND SUBSTR(tcx,LEN(tcx),1)=tcb2 RETURN tcx ENDIF IF THIS.cboOperator.Value = "IN" RETURN tcb1 + tcx + tcb2 ENDIF lcout = "" lcx = tcx DO WHILE LEN(lcx) > 0 lii = AT(",", lcx) IF lii = 0 lcv = lcx lcx = "" ELSE lcv = SUBSTR(lcx,1,lii-1) lcx = IIF(lii=LEN(lcx),"",SUBSTR(lcx,lii+1)) ENDIF IF LEN(lcout) > 0 lcout = lcout + "," ENDIF lcout = lcout + tcb1 + lcv + tcb2 ENDDO RETURN lcout ENDPROC PROCEDURE cleanparens LPARAMETERS piItem *- *- remove parens from filter *- Called from cmdDelete:Click and THISFORM:Init *- LOCAL i, lcItem lcItem = THISFORM.aQuery[piItem] DO WHILE .T. *- there may be multiple sets of parentheses, so loop through *- till we get rid of all of them DO CASE CASE OCCURS("(", lcItem) == OCCURS(")",lcItem) *- ignore, since same number of left and right parens are on this item EXIT CASE LEFT(lcItem,1) == "(" *- scan forward, looking for matching ")" FOR i = piItem TO ALEN(THISFORM.aquery,1) IF RIGHT(THISFORM.aQuery[i],1) == ")" THISFORM.aQuery[i] = LEFT(THISFORM.aquery[i],LEN(THISFORM.aquery[i]) - 1) lcItem = IIF(i == piItem, THISFORM.aQuery[i], lcItem) EXIT ENDIF NEXT lcItem = SUBSTR(lcItem,2) && strip left paren CASE RIGHT(lcItem,1) == ")" *- scan backward, looking for matching "(" FOR i = piItem TO 1 STEP -1 IF LEFT(THISFORM.aQuery[i],1) == "(" THISFORM.aQuery[i] = SUBSTR(THISFORM.aquery[i],2) lcItem = IIF(i == piItem, THISFORM.aQuery[i], lcItem) EXIT ENDIF NEXT lcItem = LEFT(lcItem, LEN(lcItem) - 1) && strip right paren OTHERWISE *- nothing to do EXIT ENDCASE ENDDO RETURN ENDPROC PROCEDURE Deactivate LOCAL lcExact lcExact = THIS.cOldExact SET EXACT &lcExact SELECT (THIS.iSelect) ENDPROC PROCEDURE editquery LPARAMETERS tcx LOCAL lcvar, lii, lcorig, lcout, lcv, lcx lcorig = tcx lii = AT(" ", tcx) IF lii = 0 RETURN lcorig ENDIF lcvar = SUBSTR(tcx,1,lii-1) lcx = SUBSTR(tcx,lii+1) lii = AT(" ", lcx) THIS.cboOperator.Value = SUBSTR(lcx,1,lii-1) lcx = SUBSTR(lcx,lii+1) IF THIS.cboOperator.Value # "IN" RETURN lcorig ENDIF lcout = "(" DO WHILE LEN(lcx) > 0 lii = AT(",", lcx) IF lii = 0 lcv = lcx lcx = "" ELSE lcv = SUBSTR(lcx,1,lii-1) lcx = IIF(lii=LEN(lcx),"",SUBSTR(lcx,lii+1)) ENDIF IF RIGHT(lcout,1) # "(" lcout = lcout + " OR " ENDIF lcout = lcout + lcvar + "=" + lcv ENDDO lcout = lcout + ")" RETURN lcout ENDPROC PROCEDURE fset LOCAL lcx, lctyp IF THIS.aQuery(THIS.lstQueryParts.Value) = "*OR*" STORE .F. TO THIS.cboFieldName.Enabled, ; THIS.edtSought.Enabled, ; THIS.cboOperator.Enabled ELSE THIS.cbofieldname.Enabled = .T. IF THIS.cboFieldname.Value = 0 THIS.cboFieldname.Value = 1 THIS.cboOperator.Value = "=" THIS.edtSought.Value = "" ENDIF lcx = THIS.NoTag(THIS.aFlds[THIS.cbofieldname.Value]) lctyp = TYPE(lcx) STORE (lcTyp # "L") TO ; THIS.cboOperator.Enabled, ; THIS.edtSought.Enabled ENDIF ENDPROC PROCEDURE Init LPARAMETERS toCaller IF NOT DODEFAULT() RETURN .F. ENDIF IF TYPE("toCaller.Name") = "C" AND ; PEMSTATUS(toCaller,"SetFilter",5) && this dialog is really only supposed && to be called by a parent dialog, but && what the heck, if you don't call it this way && we will set the filter directly... THIS.oCaller = toCaller ENDIF DIME THIS.aQuery[THIS.iQueryMax] THIS.aQuery = " " THIS.iqptr = 0 THIS.edtSought.Value = "" THIS.cboOperator.Value = "=" THIS.SetRowSources() IF SYSTEM_LARGEFONTS THIS.SetAll("FontName",DIALOG_LARGEFONT_NAME) ENDIF RETURN ENDPROC PROCEDURE nobrack LPARAMETERS tcx LOCAL lii,lcy,lcC lcy = "" FOR lii = 1 TO LEN(tcx) lcC = SUBSTR(tcx,lii,1) IF NOT lcC$"'{}" lcy = lcy + lcC ENDIF ENDFOR RETURN lcy ENDPROC PROCEDURE notag LPARAMETERS tcX LOCAL lcX lcX = SUBSTR(tcx,2) RETURN lcX ENDPROC PROCEDURE ontag LPARAMETERS tcx LOCAL lcX lcx = IIF(ASCAN(THIS.aTags,tcx)#0,"*"," ") + tcx RETURN lcx ENDPROC PROCEDURE qreset THIS.aQuery = " " THIS.iQptr = 0 THIS.lstQueryParts.Value = 1 THIS.cboOperator.Value = "=" THIS.edtSought.Value = "" THIS.edtSought.Refresh() THIS.SetAction() ENDPROC PROCEDURE qset LOCAL lcx, lii, lcFieldname, liDot IF BETWEEN(1,THIS.lstQueryParts.Value,THIS.iQptr) lcx = THIS.aQuery(THIS.lstQueryParts.Value) IF lcx = CHR(205) && "�" -- should it be "=" ?? RETURN ENDIF lii = AT(" ",lcx) liDot = AT(".",lcx) IF lii <= 1 THIS.cboOperator.Value = "=" THIS.edtSought.Value = "" IF TYPE(lcx) = "U" OR liDot = 0 OR ; UPPER(SUBSTR(lcx,1,liDot)) # UPPER(ALIAS())+"." THIS.cboFieldname.Value = 1 ELSE THIS.cboFieldname.Value = ASCAN(THIS.aFlds,THIS.OnTag(SUBSTR(lcx,liDot+1))) ENDIF ELSE lcFieldName = SUBSTR(lcx,1,lii-1) IF TYPE(lcFieldName) = "U" OR liDot = 0 OR ; UPPER(SUBSTR(lcFieldName,1,liDot)) # UPPER(ALIAS())+"." THIS.cboFieldName.Value = 1 ELSE THIS.cboFieldName.Value = ASCAN(THIS.aFlds,THIS.OnTag(SUBSTR(lcFieldName,liDot+1))) ENDIF lcx = SUBSTR(lcx,lii+1) lii = AT(" ",lcx) THIS.cboOperator.Value = SUBSTR(lcx,1,lii-1) THIS.edtSought.Value = THIS.Nobrack(SUBSTR(lcx,lii+1)) ENDIF THIS.cboFieldName.Refresh THIS.cboOperator.Refresh THIS.edtSought.Refresh ENDIF ENDPROC PROCEDURE setaction DO CASE CASE THIS.iQptr = 0 STORE .F. TO THIS.cmdReset.Enabled, ; THIS.cmdOr.Enabled, ; THIS.cmdOK.Enabled, ; THIS.lstQueryParts.Enabled, ; THIS.cmdDelete.Enabled, ; THIS.cmdUp.Enabled, ; THIS.cmdDown.Enabled CASE THIS.lstQueryParts.Value > THIS.iQptr THIS.cmdOr.Enabled = ; (THIS.lstQueryParts.Value = THIS.iQptr + 1) STORE .F. TO THIS.cmdDelete.Enabled, ; THIS.cmdUp.Enabled, ; THIS.cmdDown.Enabled STORE .T. TO THIS.cmdReset.Enabled, ; THIS.cmdOK.Enabled, ; THIS.lstQueryParts.Enabled OTHERWISE STORE .T. TO THIS.cmdReset.Enabled, ; THIS.cmdOK.Enabled, ; THIS.cmdOr.Enabled, ; THIS.lstQueryParts.Enabled, ; THIS.cmdDelete.Enabled THIS.cmdUp.Enabled = ; (THIS.iQptr # 1 AND THIS.lstQueryParts.Value # 1) THIS.cmdDown.Enabled = ; (THIS.iQptr # 1 AND THIS.iQptr # THIS.lstQueryParts.Value) ENDCASE ENDPROC PROCEDURE setinitialqueryparts LPARAMETERS tcQueryString ASSERT EMPTY(tcQueryString) OR VARTYPE(tcQueryString) = "C" DIME THIS.aQuery[THIS.iQueryMax] THIS.cFilter = "" THIS.aQuery = " " THIS.iqptr = 0 IF EMPTY(tcQueryString) THIS.lstQueryParts.Value = 1 THIS.lstQueryParts.Enabled = .F. RETURN ENDIF LOCAL lcQueryString, lcThisPart, liThisChar, ; lcStringLength, lcThisChar, lcDelimiters lcQueryString = NORMALIZE(tcQueryString) liThisChar = 0 liStringLength = LEN(lcQueryString) STORE "" TO lcThisPart, lcThisChar, lcDelimiters DO WHILE .T. liThisChar = liThisChar + 1 lcThisChar = SUBSTR(lcQueryString,liThisChar,1) lcThisPart = lcThisPart + lcThisChar IF INLIST(lcThisChar,["], ['],"[", "]" ) IF (INLIST(lcThisChar,["],[']) AND ; RIGHT(lcDelimiters,1) = lcThisChar) OR ; (lcThisChar = "]" AND ; RIGHT(lcDelimiters,1) = "[") * finishing an expression lcDelimiters = LEFT(lcDelimiters, LEN(lcDelimiters)-1) ELSE IF lcThisChar # "]" lcDelimiters = lcDelimiters + lcThisChar ENDIF ENDIF ENDIF DO CASE CASE LEN(lcDelimiters) > 0 * we're in an expression CASE RIGHT(lcThisPart,4) = ".OR." lcThisPart = LEFT(lcThisPart,LEN(lcThisPart)-4) THIS.iQptr = THIS.iQptr + 1 THIS.aQuery(THIS.iQptr) = lcThisPart THIS.iQptr = THIS.iQptr + 1 THIS.aQuery(THIS.iQptr) = "*OR*" lcThisPart = "" CASE RIGHT(lcThisPart,5) = ".AND." lcThisPart = LEFT(lcThisPart,LEN(lcThisPart)-5) THIS.iQptr = THIS.iQptr + 1 THIS.aQuery(THIS.iQptr) = lcThisPart lcThisPart = "" OTHERWISE * continue ENDCASE IF liThisChar = liStringLength OR ; THIS.iQptr = THIS.iQueryMax EXIT ENDIF ENDDO * final "part" THIS.iQptr = THIS.iQptr + 1 THIS.aQuery(THIS.iQptr) = lcThisPart THIS.lstQueryParts.Value = THIS.iQptr+1 THIS.lstQueryParts.Enabled = .T. ENDPROC PROCEDURE setrowsources THIS.cboFieldName.RowSource = "THISFORM.aFlds" THIS.cboOrder.RowSource = "THISFORM.aTags" THIS.cboTables.RowSource = "THISFORM.aDbfs" THIS.lstQueryParts.RowSource = "THISFORM.aQuery" ENDPROC PROCEDURE settags THIS.aTags[1] = "Record#" LOCAL iFl DIME THIS.aTags[TAGCOUNT()+1] FOR iFl = 2 TO (ALEN(THIS.aTags)) THIS.aTags(iFl) = TAG(iFl-1) ENDFOR DIME THIS.aFlds[FCOUNT()] FOR ifl = 1 TO ALEN(THIS.aFlds) IF TYPE(FIELD(ifl)) = "G" THIS.aFlds[ifl] = "\"+FIELD(ifl) ELSE THIS.aFlds[ifl] = ; THIS.OnTag(FIELD(ifl)) ENDIF ENDFOR ENDPROC PROCEDURE setupfilter && This takes the conditions listed in the dialog and rationalizes them into a filter expression (it also applies the NORMALIZE() function to the expression). LOCAL lcx, lii, lnstime, lnetime, lcy, lik, liempty, liSelect, lcAlias lcx = "" IF THISFORM.iQptr # 0 FOR lik = 1 TO THISFORM.iQptr IF THISFORM.aQuery(lik)#"*OR*" lcx = "("+THISFORM.EditQuery(TRIM(THISFORM.aQuery(lik))) EXIT ENDIF ENDFOR FOR lii = lik+1 TO THISFORM.iQptr IF THISFORM.aQuery(lii) = "*OR*" IF THISFORM.aQuery(lii-1) = "*OR*" LOOP ENDIF lcx = lcx + ") OR (" ELSE IF THISFORM.aQuery(lii-1) # "*OR*" lcx = lcx + " AND " ENDIF lcx = lcx + THISFORM.EditQuery(TRIM(THISFORM.aQuery(lii))) ENDIF ENDFOR lcx = lcx + ")" liempty = RAT(' OR ()',lcx) IF liempty#0 lcx = SUBSTR(lcx,1,liempty-1) ENDIF IF LEN(lcx) > FILTER_MAX_FILTER WAIT WINDOW LEFT(FILTER_TOO_LONG_LOC,254) NOWAIT RETURN 0 ENDIF liSelect = SELECT() lcAlias = "C"+SYS(2015) lnstime = SECONDS() SELECT COUNT(*) AS myTally, .T. ; FROM (ALIAS()) WHERE &lcx ; INTO CURSOR (lcAlias) lnetime = SECONDS() lcy = ALLTRIM(TRANS(myTally,"9,999,999"))+" "+ FILTER_RECORDS_LOC+", " lcy = lcy + ALLTRIM(TRANS(lnetime-lnstime,"999.99")) + " "+FILTER_SECONDS_LOC+"." USE IN (lcAlias) SELECT (liSelect) WAIT WINDOW LEFT(lcy,254) NOWAIT TIMEOUT 2 ENDIF IF EMPTY(lcx) STORE "" TO THISFORM.cfilter ELSE STORE NORMALIZE(lcx) TO THISFORM.cFilter ENDIF ENDPROC PROCEDURE cboOrder.Valid LOCAL lcx lcx = ALLTRIM(THISFORM.aTags[THISFORM.cboOrder.Value]) IF UPPER(lcx) = "RECORD#" SET ORDER TO ELSE SET ORDER TO (lcx) ENDIF GO TOP ENDPROC PROCEDURE cboTables.InteractiveChange SELECT (THISFORM.aDbfs[THIS.Value]) THISFORM.SetTags() THISFORM.cboOrder.Requery() THISFORM.cboFieldname.Requery() THISFORM.cboOrder.Value = IIF(LEN(ORDER())=0,1,ASCAN(THISFORM.aTags,ORDER())) THISFORM.cboFieldname.Value = 1 THISFORM.FSet() ENDPROC PROCEDURE cboTables.ProgrammaticChange THIS.InteractiveChange() ENDPROC PROCEDURE cmdAdd.Click LOCAL lcx, lcy, lcz, lctyp, lctyp2 IF THISFORM.iQptr = THISFORM.iQueryMax ?? CHR(7) WAIT WINDOW LEFT(FILTER_QUERY_LIST_FULL_LOC,254) NOWAIT RETURN 0 ENDIF lcx = ALIAS()+"."+THISFORM.NoTag(TRIM(THISFORM.aFlds[THISFORM.cboFieldname.Value])) lcy = ALLTRIM(THISFORM.edtSought.Value) lctyp = TYPE(lcx) IF EMPTY(lcy) AND NOT lctyp = "L" ?? CHR(7) WAIT WINDOW LEFT(FILTER_MISSING_VALUE_LOC,254) NOWAIT THISFORM.edtSought.SetFocus() * this shouldn't happen anymore * because of the programmatic/interactive change stuff * on edtSought, but JIC. RETURN 0 ENDIF DO CASE CASE INLIST(lctyp,"C","M") lcy = THISFORM.Brackets(lcy,"'","'") CASE INLIST(lctyp,"D","T") lcy = THISFORM.Brackets(lcy,"{","}") CASE INLIST(lctyp,"N","Y","I") IF AT('"',lcy)#0 WAIT WINDOW LEFT(FILTER_NUMERIC_NO_QUOTES_LOC,254) NOWAIT RETURN 0 ENDIF lctyp2 = TYPE(lcy) IF NOT INLIST(lctyp2,"N","Y","I") WAIT WINDOW LEFT(FILTER_NUMERIC_REQUIRED_LOC,254) NOWAIT RETURN 0 ENDIF ENDCASE IF lctyp = "L" lcz = lcx ELSE lcz = lcx + " " + THISFORM.cboOperator.Value + " " + lcy ENDIF IF BETWEEN(1,THISFORM.lstQueryParts.Value,THISFORM.iQptr) THISFORM.aQuery(THISFORM.lstQueryParts.Value) = lcz ELSE THISFORM.iQptr = THISFORM.iQptr + 1 THISFORM.aQuery(THISFORM.iQptr) = lcz ENDIF THISFORM.lstQueryParts.Value = THISFORM.iQptr+1 THISFORM.lstQueryParts.Enabled = .T. THISFORM.SetAction() ENDPROC PROCEDURE cmdCancel.Click THISFORM.Release() ENDPROC PROCEDURE cmdDelete.Click THISFORM.ibact = 1 *- clean up parens THISFORM.cleanparens(THISFORM.lstQueryParts.Value) = ADEL(THISFORM.aQuery,THISFORM.lstQueryParts.Value) THISFORM.aQuery(THISFORM.iQueryMax) = " " THISFORM.iQptr = THISFORM.iQptr - 1 THISFORM.lstQueryParts.Value = ; MIN(THISFORM.lstQueryParts.Value,THISFORM.iQptr+1) THISFORM.Qset() THISFORM.SetAction() THISFORM.lstQueryParts.Refresh ENDPROC PROCEDURE cmdDown.Click LOCAL lcx THISFORM.ibact = 3 IF THISFORM.lstQueryParts.Value < THISFORM.iQptr lcx = THISFORM.aQuery(THISFORM.lstQueryParts.Value+1) THISFORM.aQuery(THISFORM.lstQueryParts.Value+1) = ; THISFORM.aQuery(THISFORM.lstQueryParts.Value) THISFORM.aQuery(THISFORM.lstQueryParts.Value) = lcx THISFORM.lstQueryParts.Value = THISFORM.lstQueryParts.Value + 1 ENDIF THISFORM.Setaction() THISFORM.lstQueryParts.Refresh ENDPROC PROCEDURE cmdOK.Click THISFORM.SetUpFilter() IF TYPE("THISFORM.oCaller.Name") = "C" AND ; PEMSTATUS(THISFORM.oCaller,"setfilter",5) THISFORM.oCaller.SetFilter(THISFORM.cFilter) ELSE * set it directly after deciding that it is okay to do it * using the _table object IF THISFORM.cusTable.CurrentTableAllowsNavigation(ALIAS()) LOCAL lcFilter lcFilter = THISFORM.cFilter SET FILTER TO &lcFilter LOCATE THISFORM.cusTable.RefreshLastWindowAfterChange() ENDIF ENDIF THISFORM.Release() ENDPROC PROCEDURE cmdOr.Click LOCAL lii THISFORM.ibact = 4 IF THISFORM.lstQueryParts.Value < THISFORM.iQptr FOR lii = THISFORM.iQptr TO THISFORM.lstQueryParts.Value+1 STEP -1 THISFORM.aQuery(lii+1) = THISFORM.aQuery(lii) ENDFOR THISFORM.aQuery(THISFORM.lstQueryParts.Value + 1) = "*OR*" THISFORM.lstQueryParts.Value = THISFORM.lstQueryParts.Value + 2 ELSE THISFORM.aQuery(THISFORM.iQptr+1) = "*OR*" THISFORM.lstQueryParts.Value = THISFORM.iQptr + 2 ENDIF THISFORM.iQptr = THISFORM.iQptr + 1 THISFORM.SetAction() THISFORM.lstQueryParts.Refresh ENDPROC PROCEDURE cmdReset.Click THISFORM.aQuery = " " THISFORM.iQptr = 0 THISFORM.lstQueryParts.Value = 1 THISFORM.cboOperator.Value = "=" THISFORM.edtSought.Value = "" THISFORM.SetAction() *THISFORM.edtSought.Refresh ENDPROC PROCEDURE cmdUp.Click LOCAL lcx THISFORM.iBact= 2 IF THISFORM.lstQueryParts.Value > 1 AND ; THISFORM.lstQueryParts.Value <= THISFORM.iQptr lcx = THISFORM.aQuery(THISFORM.lstQueryParts.Value-1) THISFORM.aQuery(THISFORM.lstQueryParts.Value-1) = ; THISFORM.aQuery(THISFORM.lstQueryParts.Value) THISFORM.aQuery(THISFORM.lstQueryParts.Value) = lcx THISFORM.lstQueryParts.Value = THISFORM.lstQueryParts.Value - 1 ENDIF THISFORM.SetAction() THISFORM.lstQueryParts.Enabled = .T. ENDPROC PROCEDURE edtSought.InteractiveChange THISFORM.cmdAdd.Enabled = (NOT EMPTY(THIS.Value)) ENDPROC PROCEDURE edtSought.ProgrammaticChange THIS.InteractiveChange() ENDPROC PROCEDURE edtSought.Valid IF "'"$THIS.Value WAIT WINDOW LEFT(FILTER_NO_SINGLE_QUOTES_LOC,254) NOWAIT RETURN 0 ENDIF THIS.InteractiveChange() ENDPROC PROCEDURE lstQueryParts.InteractiveChange THIS.Valid() ENDPROC PROCEDURE lstQueryParts.ProgrammaticChange THIS.Valid() ENDPROC PROCEDURE lstQueryParts.Valid THISFORM.SetAction() THISFORM.QSet() THISFORM.FSet() ENDPROC ENDDEFINE DEFINE CLASS _filterexpr AS _form OF "_base.vcx" *< CLASSDATA: Baseclass="form" Timestamp="" Scale="Pixels" Uniqueid="" /> *-- OBJECTDATA items order determines ZOrder / El orden de los items OBJECTDATA determina el ZOrder *< OBJECTDATA: ObjPath="cusTable" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="edtFilterExpression" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cmdBuild" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cmdApply" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cmdCancel" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="lblEdit" UniqueID="" Timestamp="" /> #INCLUDE "_table.h" * *m: cfilter_access *m: setfilter && Sets the value of the cFilter property. This method is primarily useful when _FilterDialog is called modally to do further work on the expression to be built. *m: setfilterontable && If the current table allows navigation according to the dialog's _table member, this method applies the current filter to the current alias, issues a LOCATE to refresh the filter. *p: cfilter && The filter expression. *p: ioldselect && Old work area. *p: ioldsession && Old data session. *p: ladvanced && This is used to toggle _FilterExpr between two modes (_FilterDialog and GETEXPR). * * AutoCenter = .T. BorderStyle = 0 Caption = "Set Filter" cfilter = (SPACE(254)) DoCreate = .T. Height = 155 ioldselect = 0 ioldsession = 0 Name = "_filterexpr" Width = 328 WindowType = 1 * ADD OBJECT 'cmdApply' AS _commandbutton WITH ; Caption = "\ ADD OBJECT 'cmdBuild' AS _commandbutton WITH ; AutoSize = .F., ; Caption = "\ ADD OBJECT 'cmdCancel' AS _commandbutton WITH ; Cancel = .T., ; Caption = "\ ADD OBJECT 'cusTable' AS _table WITH ; Height = 15, ; Left = 298, ; Name = "cusTable", ; Top = 5, ; Width = 24 *< END OBJECT: ClassLib="_table.vcx" BaseClass="custom" /> ADD OBJECT 'edtFilterExpression' AS _editbox WITH ; ControlSource = "THISFORM.cFilter", ; FontName = "MS Sans Serif", ; Height = 99, ; IntegralHeight = .T., ; Left = 8, ; MaxLength = 254, ; Name = "edtFilterExpression", ; TabIndex = 2, ; Top = 19, ; Value = (""), ; Width = 312, ; ZOrderSet = 2 *< END OBJECT: ClassLib="_base.vcx" BaseClass="editbox" /> ADD OBJECT 'lblEdit' AS _label WITH ; AutoSize = .T., ; Caption = "\ PROCEDURE cfilter_access LOCAL lcValue IF EMPTY(THIS.cFilter) lcValue = SPACE(254) ELSE lcValue = STRTRAN(ALLTRIM(THIS.cFilter),CHR(13),SPACE(1)) lcValue = STRTRAN(lcValue,CHR(9),SPACE(1)) lcValue = STRTRAN(lcValue,CHR(10),SPACE(1)) ENDIF RETURN lcValue ENDPROC PROCEDURE Init LOCAL loControl IF NOT DODEFAULT() RETURN .F. ENDIF LOCAL ARRAY laCheck[1] IF EMPTY(ALIAS()) THIS.iOldSession = SET("DATASESSION") IF EMPTY(AUSED(laCheck)) DO CASE CASE TYPE("_SCREEN.ActiveForm.Parent") = "O" SET DATASESSION TO _SCREEN.ActiveForm.Parent.DataSessionID CASE TYPE("_SCREEN.ActiveForm") = "O" SET DATASESSION TO _SCREEN.ActiveForm.DataSessionID OTHERWISE * no other real choices ENDCASE IF NOT EMPTY(AUSED(laCheck)) THIS.iOldSelect = SELECT() SELECT (laCheck[1,1]) ELSE SET DATASESSION TO THIS.iOldSession RETURN .F. ENDIF ELSE THIS.iOldSelect = SELECT() SELECT (laCheck[1,1]) ENDIF ENDIF THIS.Caption = STRTRAN(SETFILTER_CAPTION_LOC,"\<","") THIS.cmdBuild.Caption = SETFILTER_BUILDEXPR_LOC THIS.cmdApply.Caption = SETFILTER_APPLY_LOC THIS.cmdCancel.Caption = SETFILTER_CANCEL_LOC THIS.lblEdit.Caption = SETFILTER_EDIT_LOC IF SYSTEM_LARGEFONTS LOCAL lcStandardFont lcStandardFont = UPPER(DIALOG_SMALLFONT_NAME) FOR EACH loControl IN THIS.Controls IF PEMSTATUS(loControl,"FontName",5) AND ; UPPER(loControl.FontName) == lcStandardFont loControl.FontName = DIALOG_LARGEFONT_NAME ENDIF ENDFOR * Note: no recursion here. ENDIF THIS.SetFilter(SET("FILTER")) ENDPROC PROCEDURE setfilter && Sets the value of the cFilter property. This method is primarily useful when _FilterDialog is called modally to do further work on the expression to be built. LPARAMETERS tcValue LOCAL lcFilter IF VARTYPE(tcValue) = "C" AND TYPE(tcValue) = "L" lcFilter = tcValue ELSE lcFilter = SPACE(THIS.edtFilterExpression.MaxLength) ENDIF STORE lcFilter TO THIS.cFilter, ; THIS.edtFilterExpression.Value ENDPROC PROCEDURE setfilterontable && If the current table allows navigation according to the dialog's _table member, this method applies the current filter to the current alias, issues a LOCATE to refresh the filter. IF THIS.cusTable.CurrentTableAllowsNavigation(ALIAS()) LOCAL lcFilter lcFilter = THISFORM.cFilter SET FILTER TO &lcFilter LOCATE THIS.cusTable.RefreshLastWindowAfterChange() ENDIF ENDPROC PROCEDURE Unload IF NOT EMPTY(THIS.iOldSession) SET DATASESSION TO THIS.iOldSession ENDIF IF NOT EMPTY(THIS.iOldSelect) SELECT (THIS.iOldSelect) ENDIF ENDPROC PROCEDURE cmdApply.Click THISFORM.SetFilterOnTable() THISFORM.Release() ENDPROC PROCEDURE cmdBuild.Click IF THISFORM.lAdvanced LOCAL lcFilter GETEXPR THISFORM.Caption ; TO lcFilter ; TYPE [L; SETFILTER_INVALID_LOC] ; DEFAULT THISFORM.cFilter IF TYPE(lcFilter) = "L" THISFORM.cFilter = lcFilter THISFORM.edtFilterExpression.Refresh ENDIF ELSE LOCAL lcfile, loForm lcfile = FULLPATH(THISFORM.ClassLibrary) loForm = NEWOBJECT("_FilterDialog",lcFile,"",THISFORM) IF TYPE("loForm.Name") = "C" loForm.Show(1) THISFORM.edtFilterExpression.Refresh() ENDIF ENDIF ENDPROC PROCEDURE cmdCancel.Click THISFORM.Release() ENDPROC PROCEDURE edtFilterExpression.Valid LOCAL llReturn, lcValue lcValue = STRTRAN(ALLTRIM(THIS.Value),CHR(13),SPACE(1)) lcValue = STRTRAN(lcValue,CHR(9),SPACE(1)) lcValue = STRTRAN(lcValue,CHR(10),SPACE(1)) DO CASE CASE EMPTY(lcValue) llReturn = .T. CASE LEN(lcValue) > THIS.MaxLength WAIT WINDOW LEFT(SETFILTER_MAXLENGTH_LOC,254) NOWAIT CASE TYPE(lcValue) # "L" WAIT WINDOW LEFT(SETFILTER_INVALID_LOC,254) NOWAIT OTHERWISE llReturn = .T. THISFORM.cFilter = lcValue ENDCASE RETURN IIF(llReturn,.T.,0) ENDPROC ENDDEFINE DEFINE CLASS _findbutton AS _container OF "_base.vcx" *< CLASSDATA: Baseclass="container" Timestamp="" Scale="Pixels" Uniqueid="" /> *-- OBJECTDATA items order determines ZOrder / El orden de los items OBJECTDATA determina el ZOrder *< OBJECTDATA: ObjPath="cmdTableFind" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cusTableFind" UniqueID="" Timestamp="" /> #INCLUDE "_table.h" * *m: calias_access *m: calias_assign *m: cfindstring_access *m: cfindstring_assign *m: dofind && This is ordinarily the only method you need to call to do search. *m: lfindagain_access *m: lfindagain_assign *m: lmatchcase_access *m: lmatchcase_assign *m: lskipmemos_access *m: lskipmemos_assign *m: lwraparound_access *m: lwraparound_assign *m: setbuttonui *m: skipfield && This method allows you to eliminate any particular field or fields from the search. *p: calias && The data source to search in. *p: cfindstring && The string to search for. Defaults to a null string. *p: lfindagain && This determines whether the class will perform a SKIP before its next check, allowing you to move through a file finding successive instances of a string. *p: lmatchcase && Case-sensitivity. *p: lskipmemos && Whether to skip searching in memo fields. *p: lwraparound && Whether to continue searching from beginning if end of file reached. * * BackStyle = 0 BorderWidth = 0 calias = ("") cfindstring = ("") Height = 28 Name = "_findbutton" Width = 69 * ADD OBJECT 'cmdTableFind' AS _commandbutton WITH ; AutoSize = .T., ; Caption = "\ ADD OBJECT 'cusTableFind' AS _tablefind WITH ; Left = 48, ; Name = "cusTableFind", ; Top = 0 *< END OBJECT: ClassLib="_table.vcx" BaseClass="custom" /> PROCEDURE calias_access RETURN THIS.cusTableFind.calias ENDPROC PROCEDURE calias_assign LPARAMETERS tcNewVal STORE tcNewVal TO THIS.cusTableFind.cAlias, THIS.cAlias THIS.SetButtonUI() ENDPROC PROCEDURE cfindstring_access RETURN THIS.cusTableFind.cfindstring ENDPROC PROCEDURE cfindstring_assign LPARAMETERS tcNewVal STORE tcNewVal TO THIS.cusTableFind.cFindString, THIS.cFindString THIS.SetButtonUI() ENDPROC PROCEDURE dofind && This is ordinarily the only method you need to call to do search. LPARAMETERS tcString, tcAlias THIS.cusTableFind.DoFind(tcString,tcAlias) THIS.SetButtonUI() ENDPROC PROCEDURE Init IF NOT DODEFAULT() RETURN .F. ENDIF * autosize the button for the larger caption, * then turn off the autosize THIS.cmdTableFind.AutoSize = .T. THIS.cmdTableFind.Caption = FIND_FINDNEXT_LOC THIS.cmdTableFind.AutoSize = .F. THIS.SetButtonUI() ENDPROC PROCEDURE lfindagain_access RETURN THIS.cusTableFind.lfindagain ENDPROC PROCEDURE lfindagain_assign LPARAMETERS tlNewVal STORE tlNewVal TO THIS.cusTableFind.lFindAgain, THIS.lFindAgain THIS.SetButtonUI() ENDPROC PROCEDURE lmatchcase_access RETURN THIS.cusTableFind.lmatchcase ENDPROC PROCEDURE lmatchcase_assign LPARAMETERS tlNewVal STORE tlNewVal TO THIS.cusTableFind.lMatchCase, THIS.lMatchCase THIS.SetButtonUI() ENDPROC PROCEDURE lskipmemos_access RETURN THIS.cusTableFind.lskipmemos ENDPROC PROCEDURE lskipmemos_assign LPARAMETERS tlNewVal STORE tlNewVal TO THIS.cusTableFind.lSkipMemos, THIS.lSkipMemos THIS.SetButtonUI() ENDPROC PROCEDURE lwraparound_access RETURN THIS.cusTableFind.lwraparound ENDPROC PROCEDURE lwraparound_assign LPARAMETERS tlNewVal STORE tlNewVal TO THIS.cusTableFind.lWrapAround, THIS.lWrapAround THIS.SetButtonUI() ENDPROC PROCEDURE setbuttonui THIS.cmdTableFind.Enabled = (NOT EMPTY(THIS.cAlias)) AND ; (NOT EMPTY(THIS.cFindString)) IF THIS.lFindAgain THIS.cmdTableFind.Caption = FIND_FINDNEXT_LOC ELSE THIS.cmdTableFind.Caption = FIND_FIND_LOC ENDIF ENDPROC PROCEDURE skipfield && This method allows you to eliminate any particular field or fields from the search. LPARAMETERS tcField THIS.cusTableFind.SkipField(tcField) THIS.SetButtonUI() ENDPROC PROCEDURE cmdTableFind.Click THIS.Parent.DoFind() ENDPROC ENDDEFINE DEFINE CLASS _finddialog AS _form OF "_base.vcx" *< CLASSDATA: Baseclass="form" Timestamp="" Scale="Pixels" Uniqueid="" /> *-- OBJECTDATA items order determines ZOrder / El orden de los items OBJECTDATA determina el ZOrder *< OBJECTDATA: ObjPath="lblFind" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="shpOptionFrame" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="lblOptions" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="chkMatchCase" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="chkWrapAround" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cmdFind" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cmdCancel" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cboFindString" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="chkSkipMemos" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="lblLookIn" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cboTables" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cusTableFind" UniqueID="" Timestamp="" /> #INCLUDE "_table.h" * *m: calias_access *m: calias_assign *m: cfindstring_access *m: cfindstring_assign *m: clearfindstrings *m: dofind *m: ladvanced_assign *m: lfindagain_access *m: lfindagain_assign *m: lmatchcase_access *m: lmatchcase_assign *m: lskipmemos_access *m: lskipmemos_assign *m: lwraparound_access *m: lwraparound_assign *m: refreshtablechoices *m: setfindbuttoncaption *m: setfindbuttonenable *m: skipfield *p: calias && The data source to search in. *p: cfindstring && The search string. *p: ladvanced && Whether to display advanced options in dialog. *p: lfindagain && This determines whether the class will perform a SKIP before its next check, allowing you to move through a file finding successive instances of a string. *p: lmatchcase && Case-sensitivity. *p: lskipmemos && Whether to skip searching in memo fields. *p: lwraparound && Whether to continue searching from beginning if end of file reached. * * AlwaysOnTop = .T. AutoCenter = .T. BorderStyle = 0 calias = ("") Caption = "Find" cfindstring = ("") DoCreate = .T. Height = 131 MaxButton = .F. MinButton = .F. Name = "_finddialog" ShowWindow = 1 Visible = .F. Width = 378 * ADD OBJECT 'cboFindString' AS _combobox WITH ; FontName = "MS Sans Serif", ; FontSize = 8, ; Height = 24, ; Left = 78, ; Name = "cboFindString", ; TabIndex = 2, ; Top = 11, ; Width = 216 *< END OBJECT: ClassLib="_base.vcx" BaseClass="combobox" /> ADD OBJECT 'cboTables' AS _combobox WITH ; FontName = "MS Sans Serif", ; FontSize = 8, ; Height = 24, ; Left = 78, ; Name = "cboTables", ; Style = 2, ; TabIndex = 4, ; Top = 48, ; Value = (THISFORM.cAlias), ; Width = 216 *< END OBJECT: ClassLib="_base.vcx" BaseClass="combobox" /> ADD OBJECT 'chkMatchCase' AS _checkbox WITH ; AutoSize = .T., ; BackStyle = 0, ; Caption = "\ ADD OBJECT 'chkSkipMemos' AS _checkbox WITH ; AutoSize = .T., ; Caption = "\ ADD OBJECT 'chkWrapAround' AS _checkbox WITH ; AutoSize = .T., ; BackStyle = 0, ; Caption = "\ ADD OBJECT 'cmdCancel' AS _commandbutton WITH ; Cancel = .T., ; Caption = "\ ADD OBJECT 'cmdFind' AS _commandbutton WITH ; Caption = "\ ADD OBJECT 'cusTableFind' AS _tablefind WITH ; Left = 324, ; Name = "cusTableFind", ; Top = 84 *< END OBJECT: ClassLib="_table.vcx" BaseClass="custom" /> ADD OBJECT 'lblFind' AS _label WITH ; AutoSize = .T., ; BackStyle = 0, ; BorderStyle = 0, ; Caption = "\ ADD OBJECT 'lblLookIn' AS _label WITH ; AutoSize = .T., ; BackStyle = 0, ; BorderStyle = 0, ; Caption = "Look \ ADD OBJECT 'lblOptions' AS _label WITH ; AutoSize = .T., ; BorderStyle = 0, ; Caption = "Options", ; FontName = "MS Sans Serif", ; FontSize = 8, ; Height = 15, ; Left = 15, ; Name = "lblOptions", ; TabIndex = 5, ; Top = 79, ; Width = 38 *< END OBJECT: ClassLib="_base.vcx" BaseClass="label" /> ADD OBJECT 'shpOptionFrame' AS _shape WITH ; BackStyle = 0, ; BorderStyle = 1, ; BorderWidth = 1, ; Height = 36, ; Left = 10, ; Name = "shpOptionFrame", ; SpecialEffect = 0, ; Top = 85, ; Width = 284 *< END OBJECT: ClassLib="_base.vcx" BaseClass="shape" /> PROCEDURE Activate IF NOT EMPTY(ALIAS()) THIS.RefreshTableChoices() STORE PROPER(ALIAS()) TO THIS.cboTables.Value, THIS.cboTables.DisplayValue ENDIF ENDPROC PROCEDURE calias_access RETURN THIS.cusTableFind.cAlias ENDPROC PROCEDURE calias_assign LPARAMETERS m.vNewVal THIS.cusTableFind.cAlias = m.vNewVal ENDPROC PROCEDURE cfindstring_access RETURN THIS.cusTableFind.cFindString ENDPROC PROCEDURE cfindstring_assign LPARAMETERS m.vNewVal STORE m.vNewVal TO THIS.cusTableFind.cFindString ENDPROC PROCEDURE clearfindstrings THIS.cboFindString.Clear() STORE "" TO THIS.cboFindString.Value, ; THIS.cboFindString.DisplayValue, ; THIS.cusTableFind.cFindString THIS.SetFindButtonCaption() THIS.SetFindButtonEnable() ENDPROC PROCEDURE dofind ENDPROC PROCEDURE Init LPARAMETERS tlAdvanced IF NOT DODEFAULT() RETURN .F. ENDIF IF PCOUNT() > 0 THIS.lAdvanced = tlAdvanced ELSE THIS.lAdvanced = THIS.lAdvanced * default to the value of the property, * but still synch up the positioning * of the objects on the form to the current state ENDIF * localize strings THIS.Caption = FIND_CAPTION_LOC THIS.lblFind.Caption = FIND_LOOKFOR_LOC THIS.lblOptions.Caption = FIND_OPTIONS_LOC THIS.chkWrapAround.Caption = FIND_WRAPAROUND_LOC THIS.chkMatchCase.Caption = FIND_MATCHCASE_LOC THIS.chkSkipMemos.Caption = FIND_SKIPMEMOS_LOC THIS.cmdFind.Caption = FIND_FIND_LOC THIS.cmdCancel.Caption = FIND_CANCEL_LOC THIS.lblLookIn.Caption = FIND_LOOKIN_LOC * bindings to member properties occurs * here rather than properties window * because of possible order conflicts (the * custom object may be created after some * of the members we wish to bind to its properties): THIS.cboFindString.ControlSource = "THISFORM.cusTableFind.cFindString" THIS.cboTables.ControlSource = "THISFORM.cusTableFind.cAlias" THIS.chkWrapAround.ControlSource = "THISFORM.cusTableFind.lWrapAround" THIS.chkSkipMemos.ControlSource = "THISFORM.cusTableFind.lSkipMemos" THIS.chkMatchCase.ControlSource = "THISFORM.cusTableFind.lMatchCase" IF SYSTEM_LARGEFONTS THIS.SetAll("FontName",DIALOG_LARGEFONT_NAME) ENDIF ENDPROC PROCEDURE ladvanced_assign LPARAMETERS m.vNewVal LOCAL lnMargin lnMargin = THIS.cmdFind.Top THIS.lAdvanced = m.vNewVal STORE THIS.lAdvanced TO ; THIS.cboTables.Visible, THIS.cboTables.Enabled, ; THIS.lblLookIn.Visible, THIS.lblLookIn.Enabled IF THIS.lAdvanced THIS.lblOptions.Top = THIS.cboTables.Top + THIS.cboTables.Height + lnMargin ELSE THIS.lblOptions.Top = THIS.cboTables.Top ENDIF THIS.shpOptionFrame.Top = THIS.lblOptions.Top + THIS.lblOptions.Height/2 THIS.SetAll("Top", ; THIS.shpOptionFrame.Top + ; ((THIS.shpOptionFrame.Height/2)-(THIS.chkMatchCase.Height/2)), ; "_checkbox") THIS.Height=THIS.shpOptionFrame.Top+THIS.shpOptionFrame.Height+lnMargin ENDPROC PROCEDURE lfindagain_access RETURN THIS.cusTableFind.lFindAgain ENDPROC PROCEDURE lfindagain_assign LPARAMETERS m.vNewVal THIS.cusTableFind.lFindAgain = m.vNewVal ENDPROC PROCEDURE lmatchcase_access RETURN THIS.cusTableFind.lMatchCase ENDPROC PROCEDURE lmatchcase_assign LPARAMETERS m.vNewVal THIS.cusTableFind.lMatchCase = m.vNewVal ENDPROC PROCEDURE lskipmemos_access RETURN THIS.cusTableFind.lSkipMemos ENDPROC PROCEDURE lskipmemos_assign LPARAMETERS m.vNewVal THIS.cusTableFind.lSkipMemos = m.vNewVal ENDPROC PROCEDURE lwraparound_access RETURN THIS.cusTableFind.lWrapAround ENDPROC PROCEDURE lwraparound_assign LPARAMETERS m.vNewVal THIS.cusTableFind.lWrapAround = m.vNewVal ENDPROC PROCEDURE refreshtablechoices IF THIS.lAdvanced THIS.cboTables.Refresh(.T.) ENDIF ENDPROC PROCEDURE setfindbuttoncaption IF THIS.cusTableFind.lFindAgain THIS.cmdFind.Caption = FIND_FINDNEXT_LOC ELSE THIS.cmdFind.Caption = FIND_FIND_LOC ENDIF ENDPROC PROCEDURE setfindbuttonenable THIS.cmdFind.Enabled = (NOT EMPTY(THIS.cusTableFind.cAlias)) AND ; (NOT EMPTY(THIS.cboFindString.DisplayValue)) ENDPROC PROCEDURE Show LPARAMETERS nStyle THIS.RefreshTableChoices() DO CASE CASE EMPTY(THIS.cusTableFind.cAlias) THIS.cusTableFind.cAlias = THIS.cusTableFind.GetCurrentAlias() CASE NOT USED(THIS.cusTableFind.cAlias) THIS.cusTableFind.cAlias = "" OTHERWISE * leave it alone ENDCASE THIS.SetFindButtonCaption() THIS.SetFindButtonEnable() IF NOT THIS.cmdFind.Enabled IF EMPTY(THIS.cFindString) KEYBOARD SPACE(1)+"{HOME}" ELSE KEYBOARD THIS.cFindString ENDIF ENDIF ENDPROC PROCEDURE skipfield LPARAMETERS tcField THIS.cusTableFind.SkipField(tcField) ENDPROC PROCEDURE cboFindString.InteractiveChange THISFORM.SetFindButtonEnable() ENDPROC PROCEDURE cboFindString.Valid WITH THIS IF NOT EMPTY(.DisplayValue) LOCAL liItem, llFound FOR liItem = 1 TO .ListCount IF .List(liItem) == .DisplayValue llFound = .T. EXIT ENDIF ENDFOR IF NOT llFound .AddItem(.DisplayValue,1) ENDIF ENDIF .Value = .DisplayValue ENDWITH ENDPROC PROCEDURE cboTables.Refresh LPARAMETERS tlForceRefresh IF THISFORM.lAdvanced IF tlForceRefresh THIS.Clear LOCAL aAliases[1,2], liAlias, liAliasCount liAliasCount = AUSED(aAliases) FOR liAlias = 1 TO liAliasCount THIS.AddItem(PROPER(aAliases[liAlias,1])) ENDFOR THIS.AddItem(SPACE(8)) ENDIF ENDIF ENDPROC PROCEDURE cmdCancel.Click THISFORM.Release() ENDPROC PROCEDURE cmdFind.Click THISFORM.cusTableFind.DoFind() ENDPROC PROCEDURE cusTableFind.calias_assign LPARAMETERS tcAlias DODEFAULT(tcAlias) LOCAL liAlias, llFound, llEmpty IF EMPTY(THIS.cAlias) THISFORM.Caption = FIND_CAPTION_LOC llEmpty = .T. ELSE THISFORM.Caption = FIND_FINDIN_LOC+" "+ PROPER(THIS.cAlias) ENDIF THISFORM.SetFindButtonEnable() THISFORM.SetFindButtonCaption() IF THISFORM.lAdvanced IF NOT llEmpty FOR liAlias = 1 TO THISFORM.cboTables.ListCount llFound = (THIS.cAlias == THISFORM.cboTables.List(liAlias)) IF llFound EXIT ENDIF ENDFOR ENDIF IF NOT (llFound OR llEmpty) THISFORM.cboTables.AddItem(THIS.cAlias) ENDIF STORE THIS.cAlias TO THISFORM.cboTables.Value, ; THISFORM.cboTables.DisplayValue THISFORM.cboTables.Refresh() ENDIF ENDPROC PROCEDURE cusTableFind.cfindstring_assign LPARAMETERS tcString DODEFAULT(tcString) THISFORM.SetFindButtonCaption() THISFORM.SetFindButtonEnable() ENDPROC PROCEDURE cusTableFind.dofind LPARAMETERS tcString, tcAlias IF DODEFAULT(tcString, tcAlias) THISFORM.cusTableFind.RefreshLastWindowAfterChange() ENDIF THISFORM.SetFindButtonEnable() THISFORM.SetFindButtonCaption() RETURN *!* * the commented version below can *!* * replace the above if "multiple find" *!* * is inadvisable on a modal dialog, *!* * for any reason, *!* * but it seems to be okay *!* IF DODEFAULT(tcString, tcAlias) *!* THISFORM.cusTableFind.RefreshLastWindowAfterChange() *!* IF THISFORM.WindowType = 1 *!* THISFORM.Release() *!* ENDIF *!* ELSE *!* IF THISFORM.WindowType = 1 *!* THISFORM.Release() *!* ELSE *!* THISFORM.SetFindButtonEnable() *!* THISFORM.SetFindButtonCaption() *!* ENDIF *!* ENDIF ENDPROC PROCEDURE cusTableFind.lfindagain_assign LPARAMETERS tlVal DODEFAULT(tlVal) THISFORM.SetFindButtonCaption() THISFORM.SetFindButtonEnable() ENDPROC PROCEDURE cusTableFind.lmatchcase_assign LPARAMETERS tlVal DODEFAULT(tlVal) THISFORM.SetFindButtonCaption() THISFORM.SetFindButtonEnable() ENDPROC PROCEDURE cusTableFind.lskipmemos_assign LPARAMETERS tlVal DODEFAULT(tlVal) THISFORM.SetFindButtonCaption() THISFORM.SetFindButtonEnable() ENDPROC PROCEDURE cusTableFind.lwraparound_assign LPARAMETERS tlVal DODEFAULT(tlVal) THISFORM.SetFindButtonCaption() THISFORM.SetFindButtonEnable() ENDPROC PROCEDURE cusTableFind.setfields DODEFAULT() THISFORM.SetFindButtonCaption() THISFORM.SetFindButtonEnable() ENDPROC PROCEDURE cusTableFind.skipfield LPARAMETERS tcField DODEFAULT(tcField) THISFORM.SetFindButtonCaption() THISFORM.SetFindButtonEnable() ENDPROC ENDDEFINE DEFINE CLASS _findnextbuttons AS _findbutton OF "_table.vcx" *< CLASSDATA: Baseclass="container" Timestamp="" Scale="Pixels" Uniqueid="" /> *-- OBJECTDATA items order determines ZOrder / El orden de los items OBJECTDATA determina el ZOrder *< OBJECTDATA: ObjPath="cmdTableFindNext" UniqueID="" Timestamp="" /> #INCLUDE "_table.h" * calias = ("") Height = 30 Name = "_findnextbuttons" Width = 134 cmdTableFind.AutoSize = .F. cmdTableFind.Name = "cmdTableFind" cusTableFind.Left = 48 cusTableFind.Name = "cusTableFind" cusTableFind.Top = 0 * ADD OBJECT 'cmdTableFindNext' AS _commandbutton WITH ; AutoSize = .T., ; Caption = "Find \ PROCEDURE Init IF NOT DODEFAULT() RETURN .F. ENDIF THIS.cmdTableFind.Caption = FIND_FIND_LOC THIS.cmdTableFindNext.Caption = FIND_FINDNEXT_LOC THIS.cmdTableFind.Width = THIS.cmdTableFindNext.Width THIS.cmdTableFindNext.Left = THIS.cmdTableFind.Width+2 THIS.Width = THIS.cmdTableFind.Width*2+2 ENDPROC PROCEDURE setbuttonui * override, so that the captions won't be re-set THIS.cmdTableFind.Enabled = (NOT EMPTY(THIS.cAlias)) AND ; (NOT EMPTY(THIS.cFindString)) THIS.cmdTableFindNext.Enabled = THIS.cmdTableFind.Enabled AND ; THIS.lFindAgain ENDPROC PROCEDURE cmdTableFind.Click THIS.Parent.lFindAgain = .F. DODEFAULT() ENDPROC PROCEDURE cmdTableFindNext.Click THIS.Parent.DoFind() ENDPROC ENDDEFINE DEFINE CLASS _gotodialog AS _form OF "_base.vcx" *< CLASSDATA: Baseclass="form" Timestamp="" Scale="Pixels" Uniqueid="" /> *-- OBJECTDATA items order determines ZOrder / El orden de los items OBJECTDATA determina el ZOrder *< OBJECTDATA: ObjPath="cusTableNav" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="spnGoTo" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cmdOK" UniqueID="" Timestamp="" /> #INCLUDE "_table.h" * *m: refreshuiafterchange * * AutoCenter = .T. BorderStyle = 0 Caption = "Go To Record" DoCreate = .T. Height = 81 KeyPreview = .T. MaxButton = .F. MinButton = .F. Name = "_gotodialog" ShowWindow = 1 Width = 164 WindowType = 1 * ADD OBJECT 'cmdOK' AS _commandbutton WITH ; AutoSize = .T., ; Caption = "\ ADD OBJECT 'cusTableNav' AS _tablenav WITH ; Left = 12, ; Name = "cusTableNav", ; Top = 0 *< END OBJECT: ClassLib="_table.vcx" BaseClass="custom" /> ADD OBJECT 'spnGoTo' AS _spinner WITH ; FontName = "MS Sans Serif", ; Format = "", ; Increment = 1.00, ; InputMask = "9999999999999999999", ; Left = 22, ; Name = "spnGoTo", ; Top = 12 *< END OBJECT: ClassLib="_base.vcx" BaseClass="spinner" /> PROCEDURE Init LOCAL llReturn, loControl llReturn = DODEFAULT() IF llReturn IF EMPTY(THIS.cusTableNav.cAlias) OR RECCOUNT(THIS.cusTableNav.cAlias) < 2 llReturn = .F. ELSE WITH THIS.spnGoTo STORE 1 TO .SpinnerLowValue, .KeyBoardLowValue STORE RECCOUNT(THIS.cusTableNav.cAlias) TO ; .SpinnerHighValue, .KeyBoardHighValue .Value = RECNO(THIS.cusTableNav.cAlias) .Value = MIN(.Value,.SpinnerHighValue) && EOF() ENDWITH ENDIF IF SYSTEM_LARGEFONTS LOCAL lcStandardFont lcStandardFont = UPPER(DIALOG_SMALLFONT_NAME) FOR EACH loControl IN THIS.Controls IF PEMSTATUS(loControl,"FontName",5) AND ; UPPER(loControl.FontName) == lcStandardFont loControl.FontName = DIALOG_LARGEFONT_NAME ENDIF ENDFOR * Note: no recursion here. ENDIF ENDIF RETURN llReturn ENDPROC PROCEDURE KeyPress LPARAMETERS nKeyCode, nShiftAltCtrl IF nKeyCode = 27 THIS.Release() ENDIF ENDPROC PROCEDURE refreshuiafterchange ENDPROC PROCEDURE cmdOK.Click THISFORM.cusTableNav.GoToRecord(THISFORM.spnGoTo.Value) * we may not have moved but we may have reverted data * so we have to refresh whether the pointer has * moved or not THISFORM.cusTableNav.RefreshLastWindowAfterChange() THISFORM.Release() ENDPROC PROCEDURE cusTableNav.Init LOCAL llReturn llReturn = DODEFAULT() IF llReturn THIS.cAlias = THIS.GetCurrentAlias() ENDIF RETURN llReturn ENDPROC ENDDEFINE DEFINE CLASS _nav2buttons AS _container OF "_base.vcx" *< CLASSDATA: Baseclass="container" Timestamp="" Scale="Pixels" Uniqueid="" /> *-- OBJECTDATA items order determines ZOrder / El orden de los items OBJECTDATA determina el ZOrder *< OBJECTDATA: ObjPath="cmgNav" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cusTableNav" UniqueID="" Timestamp="" /> #INCLUDE "_table.h" * *m: lcycle_access *m: lcycle_assign *m: tablenav && Handles record navigation. *p: lcycle && Controls movement when record pointer hits end or beginning of file. * * BackStyle = 0 BorderWidth = 0 Height = 38 Name = "_nav2buttons" Width = 78 * ADD OBJECT 'cmgNav' AS _commandgroup WITH ; BorderStyle = 1, ; Height = 37, ; Left = 8, ; Name = "cmgNav", ; Top = 1, ; Width = 64, ; ZOrderSet = 0, ; Command1.AutoSize = .T., ; Command1.Caption = "<", ; Command1.FontBold = .T., ; Command1.Left = 5, ; Command1.Name = "Command1", ; Command1.Top = 5, ; Command2.AutoSize = .T., ; Command2.Caption = ">", ; Command2.FontBold = .T., ; Command2.Height = 27, ; Command2.Left = 32, ; Command2.Name = "Command2", ; Command2.Top = 5, ; Command2.Width = 27 *< END OBJECT: ClassLib="_base.vcx" BaseClass="commandgroup" /> ADD OBJECT 'cusTableNav' AS _tablenav WITH ; Left = 0, ; Name = "cusTableNav", ; Top = 0 *< END OBJECT: ClassLib="_table.vcx" BaseClass="custom" /> PROCEDURE lcycle_access RETURN THIS.cusTableNav.lCycle ENDPROC PROCEDURE lcycle_assign LPARAMETERS m.vNewVal THIS.cusTableNav.lCycle= m.vNewVal ENDPROC PROCEDURE tablenav && Handles record navigation. LPARAMETERS tcAction IF EMPTY(tcAction) OR VARTYPE(tcAction) # "C" RETURN ENDIF DO CASE CASE UPPER(tcAction) = "NEXT" THIS.cusTableNav.GoNext() CASE UPPER(tcAction) = "PREVIOUS" THIS.cusTableNav.GoPrevious() OTHERWISE *whoops! ENDCASE ENDPROC PROCEDURE cmgNav.Command1.Click THIS.Parent.Parent.TableNav("PREVIOUS") ENDPROC PROCEDURE cmgNav.Command2.Click THIS.Parent.Parent.TableNav("NEXT") ENDPROC ENDDEFINE DEFINE CLASS _nav4buttons AS _nav2buttons OF "_table.vcx" *< CLASSDATA: Baseclass="container" Timestamp="" Scale="Pixels" Uniqueid="" /> *-- OBJECTDATA items order determines ZOrder / El orden de los items OBJECTDATA determina el ZOrder *< OBJECTDATA: ObjPath="cmdTop" UniqueID="" Timestamp="" /> *< OBJECTDATA: ObjPath="cmdBottom" UniqueID="" Timestamp="" /> #INCLUDE "_table.h" * Height = 37 Name = "_nav4buttons" Width = 133 cmgNav.Command1.Left = 33 cmgNav.Command1.Name = "Command1" cmgNav.Command1.TabIndex = 1 cmgNav.Command1.Top = 5 cmgNav.Command2.Left = 60 cmgNav.Command2.Name = "Command2" cmgNav.Command2.TabIndex = 2 cmgNav.Command2.Top = 5 cmgNav.Height = 36 cmgNav.Left = 8 cmgNav.Name = "cmgNav" cmgNav.TabIndex = 2 cmgNav.Width = 122 cusTableNav.Name = "cusTableNav" * ADD OBJECT 'cmdBottom' AS _commandbutton WITH ; AutoSize = .T., ; Caption = ">|", ; FontBold = .T., ; Height = 27, ; Left = 96, ; Name = "cmdBottom", ; TabIndex = 3, ; Top = 6, ; Width = 30 *< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" /> ADD OBJECT 'cmdTop' AS _commandbutton WITH ; AutoSize = .T., ; Caption = "|<", ; FontBold = .T., ; Height = 27, ; Left = 11, ; Name = "cmdTop", ; TabIndex = 1, ; Top = 6, ; Width = 30 *< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" /> PROCEDURE tablenav && Handles record navigation. LPARAMETERS tcAction IF EMPTY(tcAction) OR VARTYPE(tcAction) # "C" RETURN ENDIF DODEFAULT(tcAction) DO CASE CASE UPPER(tcAction) = "TOP" THIS.cusTableNav.GoTop() CASE UPPER(tcAction) = "BOTTOM" THIS.cusTableNav.GoBottom() OTHERWISE * ?? ENDCASE ENDPROC PROCEDURE cmdBottom.Click THIS.Parent.TableNav("BOTTOM") ENDPROC PROCEDURE cmdTop.Click THIS.Parent.TableNav("TOP") ENDPROC ENDDEFINE DEFINE CLASS _table AS _custom OF "_base.vcx" *< CLASSDATA: Baseclass="custom" Timestamp="" Scale="Pixels" Uniqueid="" /> #INCLUDE "_table.h" * *m: currentrowbufferedandchanged && Determines whether there is a change in the current control without actually doing a flush. *m: currenttableallowsnavigation && Evaluates whether the user needs to be presented with choices before leaving the current row. *m: currenttableallowsordering && Returns .F. if the current alias is a child of a relationship or if the current control is a grid that uses the Linkmaster/ChildOrder/RelationalExpr properties. *m: dotargetofrelationmessage && Abstract method. *m: flushcurrentcontrol && Flushes data when the user confirms a desire to do an update. *m: getcurrentalias && If the current value of the cAlias property is a currently-USED() table, this method RETURNs THIS.cAlias. *m: getcurrentboundfield && Returns an aliased field in an existing table or, if there is no current bound field, it returns an empty string. *m: getcurrentcontrol && Returns current control or NULL if there is no ActiveControl at the moment. *m: refreshlastwindowafterchange && This is similar to RefreshUIAfterChange method, but it is designed especially for use by modal dialogs that may be affecting tables bound to them. *m: refreshuiafterchange && Looks for an _SCREEN.ActiveForm.Parent (formset) or, failing that, simply a _SCREEN.ActiveForm to refresh. *m: settoactivesession && Looks for a _SCREEN.ActiveForm or _SCREEN.ActiveForm.Parent (formset) from which to derive an active DataSessionID, and SETs DATASESSION TO that session. *p: calias && Alias of data source. * * calias = ("") Name = "_table" * PROCEDURE currentrowbufferedandchanged && Determines whether there is a change in the current control without actually doing a flush. LPARAMETERS tcAlias ASSERT EMPTY(tcAlias) OR VARTYPE(tcAlias) = "C" AND USED(tcAlias) LOCAL lcAlias, llReturn, loCurrentControl, lcCurrentField IF EMPTY(tcAlias) lcAlias = THIS.GetCurrentAlias() ELSE lcAlias = tcAlias ENDIF IF (NOT EMPTY(lcAlias)) AND ; (EMPTY(RECCOUNT(lcAlias))) lcAlias = "" ENDIF IF (NOT EMPTY(lcAlias)) AND ; INLIST(CURSORGETPROP("BUFFERING",lcAlias), ; DB_BUFLOCKRECORD, ; DB_BUFOPTRECORD) lcCurrentField = THIS.GetCurrentBoundField() * return of GetCurrentBoundField() will always be aliased IF NOT EMPTY(lcCurrentField) IF UPPER(LEFT(lcCurrentField,LEN(lcAlias)+1)) == ; UPPER(lcAlias)+"." * check to see if we would need to flush the current control * to actually see a change: loCurrentControl = THIS.GetCurrentControl() IF (NOT ISNULL(loCurrentControl)) AND ; PEMSTATUS(loCurrentControl,"Value",5) AND ; (NOT EVAL(lcCurrentField) == loCurrentControl.Value) * we definitely have a change llReturn = .T. ENDIF ENDIF ENDIF IF NOT llReturn && yet llReturn = (GETFLDSTATE(-1,lcAlias) # ; REPL("1",FCOUNT(lcAlias)+1)) ENDIF ENDIF RETURN llReturn ENDPROC PROCEDURE currenttableallowsnavigation && Evaluates whether the user needs to be presented with choices before leaving the current row. LPARAMETERS tcAlias ASSERT EMPTY(tcAlias) OR VARTYPE(tcAlias) = "C" AND USED(tcAlias) LOCAL lcAlias, liReturn IF (NOT EMPTY(tcAlias)) AND USED(tcAlias) lcAlias = tcAlias ELSE lcAlias = THIS.GetCurrentAlias() ENDIF IF (NOT EMPTY(lcAlias)) AND ; (EMPTY(RECCOUNT(lcAlias))) lcAlias = "" ENDIF IF (NOT EMPTY(lcAlias)) AND ; THIS.CurrentRowBufferedAndChanged(lcAlias) IF INLIST(_VFP.Startmode,0,4) liReturn = MESSAGEBOX(TABLE_MESSAGE_ROW_CHANGED_LOC,; MB_ICONEXCLAMATION+MB_YESNOCANCEL, ; TABLE_MESSAGE_TITLE_ROW_CHANGED_LOC) ELSE lcAlias = "" ENDIF DO CASE CASE EMPTY(lcAlias) * we're in a server * and we shouldn't be moving * the record pointer here; * should make the determination * to revert or update somewhere else! CASE liReturn = IDYES THIS.FlushCurrentControl() IF NOT TABLEUPDATE(0,.T.,lcAlias) lcAlias = "" ENDIF CASE liReturn = IDNO =TABLEREVERT(.F.,lcAlias) OTHERWISE && cancel lcAlias = "" ENDCASE ENDIF RETURN (NOT EMPTY(lcAlias)) ENDPROC PROCEDURE currenttableallowsordering && Returns .F. if the current alias is a child of a relationship or if the current control is a grid that uses the Linkmaster/ChildOrder/RelationalExpr properties. LPARAMETERS tcAlias ASSERT EMPTY(tcAlias) OR VARTYPE(tcAlias) = "C" AND USED(tcAlias) LOCAL lcAlias, llReturn, loCurrentControl, ; loCurrentGrid, liIndex, liTables, liTarget, lcTarget LOCAL ARRAY laTables[1,2] IF (NOT EMPTY(tcAlias)) AND USED(tcAlias) lcAlias = tcAlias ELSE lcAlias = THIS.GetCurrentAlias() ENDIF IF (NOT EMPTY(lcAlias)) lcAlias = UPPER(lcAlias) llReturn = .T. * check for grid in a child relation loCurrentControl = THIS.GetCurrentControl() DO WHILE TYPE("loCurrentControl.Parent.Baseclass") = "C" loCurrentControl = loCurrentControl.Parent IF UPPER(loCurrentControl.Baseclass) == "GRID" loCurrentGrid = loCurrentControl EXIT ENDIF ENDDO IF TYPE("loCurrentGrid.Name") = "C" AND ; (NOT EMPTY(loCurrentGrid.LinkMaster+; loCurrentGrid.ChildOrder+; loCurrentGrid.RelationalExpr)) llReturn = .F. ENDIF ENDIF IF llReturn * check for a relational expression even though * this isn't a grid liTables = AUSED(laTables) FOR liIndex = 1 TO liTables liTarget = 1 lcTarget = UPPER(TARGET(1,laTables[liIndex,1])) DO WHILE NOT EMPTY(lcTarget) IF lcAlias == lcTarget llReturn = .F. EXIT ELSE liTarget = liTarget + 1 lcTarget = UPPER(TARGET(liTarget,laTables[liIndex,1])) ENDIF ENDDO IF NOT llReturn EXIT ENDIF ENDFOR ENDIF IF NOT llReturn THIS.DoTargetOfRelationMessage(lcAlias) ENDIF RETURN llReturn ENDPROC PROCEDURE dotargetofrelationmessage && Abstract method. LPARAMETERS tcAlias IF EMPTY(tcAlias) RETURN ENDIF ENDPROC PROCEDURE flushcurrentcontrol && Flushes data when the user confirms a desire to do an update. LPARAMETERS tcAlias ASSERT EMPTY(tcAlias) OR VARTYPE(tcAlias) = "C" AND USED(tcAlias) LOCAL lcAlias, llReturn, loCurrentControl, lcCurrentField IF EMPTY(tcAlias) lcAlias = THIS.GetCurrentAlias() ELSE lcAlias = tcAlias ENDIF IF (NOT EMPTY(lcAlias)) AND ; (EMPTY(RECCOUNT(lcAlias))) lcAlias = "" ENDIF IF (NOT EMPTY(lcAlias)) AND ; INLIST(CURSORGETPROP("BUFFERING",lcAlias), ; DB_BUFLOCKRECORD, ; DB_BUFOPTRECORD) lcCurrentField = THIS.GetCurrentBoundField() * return of GetCurrentBoundField() will always be aliased IF NOT EMPTY(lcCurrentField) IF UPPER(LEFT(lcCurrentField,LEN(lcAlias)+1)) == ; UPPER(lcAlias)+"." loCurrentControl = THIS.GetCurrentControl() IF (NOT ISNULL(loCurrentControl)) AND ; PEMSTATUS(loCurrentControl,"Value",5) loCurrentControl.Value = loCurrentControl.Value llReturn = .T. ENDIF ENDIF ENDIF ENDIF RETURN llReturn ENDPROC PROCEDURE getcurrentalias && If the current value of the cAlias property is a currently-USED() table, this method RETURNs THIS.cAlias. LOCAL lcAlias IF EMPTY(THIS.cAlias) OR NOT USED(THIS.cAlias) THIS.SetToActiveSession() lcAlias = ALIAS() ELSE lcAlias = THIS.cAlias ENDIF RETURN lcAlias ENDPROC PROCEDURE getcurrentboundfield && Returns an aliased field in an existing table or, if there is no current bound field, it returns an empty string. * this will always return an aliased field in an existing * table or it will return an empty string. LOCAL lcFieldName, loCurrentControl, iPos, lcAlias loCurrentControl = THIS.GetCurrentControl() IF ISNULL(loCurrentControl) OR (TYPE("loCurrentControl.ControlSource") # "C") IF NOT EMPTY(VARREAD()) * could be a browse... RETURN UPPER(ALIAS()+"."+VARREAD()) ELSE RETURN "" ENDIF ELSE lcFieldName = UPPER(loCurrentControl.ControlSource) ENDIF * is this a bound field we can find in the current list of tables? THIS.SetToActiveSession() iPos = AT(".",lcFieldName) lcAlias = ALIAS() DO CASE CASE OCCURS(".",lcFieldName) > 1 AND ; VARTYPE(lcFieldName) = "O" * we can't use a member object, * we're looking for a table attribute/column lcFieldName = "" CASE iPos <= 1 AND EMPTY(lcAlias) lcFieldName = "" CASE iPos = 0 iPos = LEN(lcAlias)+ 1 lcFieldName = lcAlias+"."+lcFieldName CASE iPos = 1 iPos = LEN(lcAlias)+ 1 lcFieldName = lcAlias+lcFieldName CASE iPos = 2 AND LEFT(lcFieldName,1) = "M" * we can't use a memvar lcFieldName = "" OTHERWISE * we may have an aliased field * or we may have a property -- * which is it?? IF NOT USED(SUBSTR(lcAlias,1,iPos-1)) lcFieldName = "" ENDIF ENDCASE * okay, now do we have something usable? IF NOT EMPTY(lcFieldName) IF TYPE(lcFieldName) = "U" lcFieldName = "" ENDIF ENDIF RETURN lcFieldName ENDPROC PROCEDURE getcurrentcontrol && Returns current control or NULL if there is no ActiveControl at the moment. LOCAL loRealActiveControl, liThisColumn, loActiveControl, loColumn loRealActiveControl = NULL IF TYPE("_SCREEN.ActiveForm.ActiveControl.BaseClass")= "C" loActiveControl = _SCREEN.ActiveForm.ActiveControl IF UPPER(loActiveControl.BaseClass) == "GRID" liThisColumn = loActivecontrol.ActiveColumn FOR EACH loColumn IN loActiveControl.Columns IF loColumn.ColumnOrder = liThisColumn IF TYPE("loColumn.CurrentControl") = "C" loRealActiveControl = ; EVAL("loColumn."+loColumn.CurrentControl) ELSE loRealActiveControl = loColumn ENDIF EXIT ENDIF ENDFOR ELSE loRealActiveControl = loActiveControl ENDIF ENDIF RETURN loRealActiveControl ENDPROC PROCEDURE refreshlastwindowafterchange && This is similar to RefreshUIAfterChange method, but it is designed especially for use by modal dialogs that may be affecting tables bound to them. LOCAL loForm, liForms, liThisForm, loThisForm liForms = _SCREEN.FormCount IF TYPE("THISFORM") = "O" loThisForm = THISFORM ELSE loThisForm = .NULL. ENDIF DO CASE CASE liForms > 1 * find the next one down in the stack, not counting toobars FOR liThisForm = 2 TO liForms loForm = _SCREEN.Forms(liThisForm) IF (NOT ISNULL(loThisForm)) AND loForm = loThisForm LOOP ENDIF IF UPPER(loForm.BaseClass) == "FORM" IF TYPE("loForm.Parent") = "O" loForm.Parent.Refresh() ELSE loForm.Refresh() ENDIF EXIT ENDIF ENDFOR CASE _SCREEN.Visible _SCREEN.Refresh() OTHERWISE * Not much we can do... ENDCASE ENDPROC PROCEDURE refreshuiafterchange && Looks for an _SCREEN.ActiveForm.Parent (formset) or, failing that, simply a _SCREEN.ActiveForm to refresh. DO CASE CASE TYPE("_SCREEN.ActiveForm.Parent") = "O" _SCREEN.ActiveForm.Parent.Refresh() CASE TYPE("_SCREEN.ActiveForm") = "O" _SCREEN.ActiveForm.Refresh() OTHERWISE IF NOT EMPTY(WONTOP()) SHOW WINDOW (WONTOP()) REFRESH ENDIF ENDCASE ENDPROC PROCEDURE settoactivesession && Looks for a _SCREEN.ActiveForm or _SCREEN.ActiveForm.Parent (formset) from which to derive an active DataSessionID, and SETs DATASESSION TO that session. LOCAL liSession liSession = SET("DATASESSION") * we may be calling from the menu or a toolbar: DO CASE CASE TYPE("_SCREEN.ActiveForm.DatasessionID") = "N" AND ; liSession # _SCREEN.ActiveForm.DatasessionID SET DATASESSION TO (_SCREEN.ActiveForm.DatasessionID) CASE TYPE("_SCREEN.ActiveForm.Parent.DatasessionID") = "N" AND ; liSession # _SCREEN.ActiveForm.Parent.DatasessionID SET DATASESSION TO (_SCREEN.ActiveForm.Parent.DatasessionID) OTHERWISE * we're in the right datasession already ENDCASE ENDPROC ENDDEFINE DEFINE CLASS _tablefind AS _table OF "_table.vcx" *< CLASSDATA: Baseclass="custom" Timestamp="" Scale="Pixels" Uniqueid="" /> #INCLUDE "_table.h" * *m: calias_assign *m: ccontrolcharacter_assign *m: cfindstring_assign *m: dofind && This is ordinarily the only method you need to call to do search. *m: lfindagain_assign *m: lmatchcase_assign *m: lskipmemos_assign *m: lwraparound_assign *m: setfields *m: showmessagenotfound *m: skipfield && This method allows you to eliminate any particular field or fields from the search. *p: ccontrolcharacter *p: cfields && List of fields to search. *p: cfindstring && The string to search for. Defaults to a null string. *p: imemos *p: lfindagain && This determines whether the class will perform a SKIP before its next check, allowing you to move through a file finding successive instances of a string. *p: lmatchcase && Case-sensitivity. *p: lskipmemos && Whether to skip searching of memos. *p: lwraparound && Whether to continue searching from beginning if end of file reached. *a: amemos[1,0] * * calias = ("") ccontrolcharacter = ("~") cfields = ("") cfindstring = ("") imemos = 0 Name = "_tablefind" * PROCEDURE calias_assign LPARAMETERS tcNewVal DO CASE CASE VARTYPE(tcNewVal) # "C" OR NOT USED(tcNewVal) THIS.cAlias = "" THIS.cFields = "" THIS.lFindAgain = .F. CASE THIS.cAlias == PROPER(tcNewVal) * do nothing OTHERWISE THIS.cAlias = PROPER(tcNewVal) THIS.SetFields() THIS.lFindAgain = .F. ENDCASE ENDPROC PROCEDURE ccontrolcharacter_assign LPARAMETERS tcNewVal IF VARTYPE(tcNewVal) # "C" OR EMPTY(tcNewVal) THIS.cControlCharacter = "~" ELSE IF LEFTC(tcNewVal,1) == THIS.cControlCharacter * do nothing ELSE * one character only THIS.cControlCharacter = LEFTC(tcNewVal,1) THIS.SetFields() ENDIF ENDIF ENDPROC PROCEDURE cfindstring_assign LPARAMETERS tcNewVal IF VARTYPE(tcNewVal) # "C" RETURN .F. ENDIF IF RTRIM(tcNewVal) == THIS.cFindString * do nothing ELSE STORE RTRIM(tcNewVal) TO THIS.cFindString THIS.lFindAgain = .F. ENDIF ENDPROC PROCEDURE dofind && This is ordinarily the only method you need to call to do search. LPARAMETERS tcFindString, tcAlias ASSERT EMPTY(tcFindString) OR VARTYPE(tcFindString) = "C" ASSERT EMPTY(tcAlias) OR VARTYPE(tcAlias) = "C" LOCAL llSuccess llSuccess = .T. IF NOT EMPTY(tcFindString) THIS.cFindString = tcFindString ENDIF IF EMPTY(THIS.cFindString) llSuccess = .F. ENDIF IF NOT EMPTY(tcAlias) THIS.cAlias = tcAlias ENDIF IF EMPTY(THIS.cAlias) THIS.cAlias = THIS.GetCurrentAlias() ENDIF IF NOT USED(THIS.cAlias) THIS.cAlias = "" ENDIF IF EMPTY(THIS.cAlias) llSuccess = .F. ENDIF IF llSuccess llSuccess = THIS.CurrentTableAllowsNavigation(THIS.cAlias) ENDIF IF llSuccess * now do the real work LOCAL liRecno, liSelect liSelect = SELECT() SELECT (THIS.cAlias) liRecno = RECNO() IF THIS.lFindAgain IF NOT EOF() SKIP ELSE LOCATE ENDIF ENDIF IF THIS.lMatchCase LOCATE REST FOR AT_C(THIS.cFindString,EVAL(THIS.cFields)) > 0 ELSE LOCATE REST FOR ATCC(THIS.cFindString,EVAL(THIS.cfields)) > 0 ENDIF IF EOF() AND THIS.lWrapAround IF THIS.lMatchCase LOCATE FOR AT_C(THIS.cFindString,EVAL(THIS.cFields)) > 0 ELSE LOCATE FOR ATCC(THIS.cFindString,EVAL(THIS.cFields)) > 0 ENDIF ENDIF IF EOF() THIS.ShowMessageNotFound() GO liRecno llSuccess = .F. ENDIF SELECT (liSelect) ENDIF THIS.lFindAgain = llSuccess RETURN llSuccess ENDPROC PROCEDURE lfindagain_assign LPARAMETERS tlNewVal THIS.lFindAgain = tlNewVal ENDPROC PROCEDURE lmatchcase_assign LPARAMETERS tlNewVal IF THIS.lMatchCase = tlNewVal * do nothing ELSE THIS.lMatchCase = tlNewVal THIS.lFindAgain = .F. ENDIF ENDPROC PROCEDURE lskipmemos_assign LPARAMETERS tlNewVal IF tlNewVal = THIS.lSkipMemos * do nothing ELSE THIS.lFindAgain = .F. THIS.lSkipMemos = tlNewVal THIS.SetFields() ENDIF ENDPROC PROCEDURE lwraparound_assign LPARAMETERS m.vNewVal THIS.lWrapAround = m.vNewVal ENDPROC PROCEDURE setfields IF VARTYPE(THIS.cAlias) # "C" OR NOT USED(THIS.cAlias) THIS.cFields = "" RETURN ENDIF LOCAL liIndex, lcThisField, lcThisFieldType THIS.iMemos = 0 THIS.cFields = "["+THIS.cControlCharacter+"]" DIME THIS.aMemos[1] THIS.aMemos[1] = .F. FOR liIndex = 1 TO FCOUNT(THIS.cAlias) lcThisField = FIELD(liIndex,THIS.cAlias) lcThisFieldType = TYPE(THIS.cAlias+"."+lcThisField) DO CASE CASE lcThisFieldType = "M" AND NOT THIS.lSkipMemos THIS.iMemos = THIS.iMemos + 1 DIME THIS.aMemos(THIS.iMemos) THIS.aMemos(THIS.iMemos) = lcThisField THIS.cFields = THIS.cFields+"+"+lcThisField+"+["+THIS.cControlCharacter+"]" CASE lcThisFieldType = "C" THIS.cFields = THIS.cFields+"+"+lcThisField+"+["+THIS.cControlCharacter+"]" CASE INLIST(lcThisFieldType,"N","I","Y") THIS.cfields = ; THIS.cfields+"+ ALLTRIM(STR("+lcThisField+",12,4))+["+THIS.cControlCharacter+"]" CASE lcThisFieldType = "D" THIS.cfields = ; THIS.cfields+"+ DTOC("+lcThisField+")+["+THIS.cControlCharacter+"]" CASE lcThisFieldType = "T" THIS.cfields = ; THIS.cfields+"+ TTOC("+lcThisField+")+["+THIS.cControlCharacter+"]" CASE lcThisFieldType = "L" THIS.cfields = ; THIS.cfields+"+ IIF("+lcThisField+",'.T.','.F.')+["+THIS.cControlCharacter+"]" OTHERWISE * a type we can't yet handle ENDCASE ENDFOR THIS.cFields = UPPER(STRTRAN(THIS.cFields,SPACE(1),"")) IF THIS.cFields == "["+THIS.cControlCharacter+"]" THIS.cAlias = "" ENDIF ENDPROC PROCEDURE showmessagenotfound IF INLIST(_VFP.StartMode,0,4) ?? CHR(7) WAIT WINDOW NOWAIT LEFT(FIND_NOFIND_LOC,254) ENDIF ENDPROC PROCEDURE skipfield && This method allows you to eliminate any particular field or fields from the search. LPARAMETERS tcField LOCAL llSkipped, lcThisField, lcThisFieldType lcThisField = "" IF VARTYPE(tcField) = "C" AND NOT(EMPTY(tcField)) lcThisFieldType = TYPE(THIS.cAlias+"."+tcField) DO CASE CASE INLIST(lcThisFieldType,"N","Y","I") lcThisField = "["+THIS.cControlCharacter+"]" + ; "+ ALLTRIM(STR("+ ; tcField + ; ",12,4))+["+THIS.cControlCharacter+"]" CASE INLIST(lcThisFieldType,"C","M") lcThisField = "["+THIS.cControlCharacter+"]+" + ; tcField + ; "+["+THIS.cControlCharacter+"]" CASE lcThisFieldType = "D" lcThisField = "["+THIS.cControlCharacter+"]" + ; "+DTOC("+tcField+")" + ; "+["+THIS.cControlCharacter+"]" CASE lcThisFieldType = "T" lcThisField = "["+THIS.cControlCharacter+"]" + ; "+TTOC("+tcField+")" + ; "+["+THIS.cControlCharacter+"]" CASE lcThisFieldType = "L" lcThisField = "["+THIS.cControlCharacter+"]" + ; "+ IIF("+tcField+",'.T.','.F.')"+ ; "+["+THIS.cControlCharacter+"]" ENDCASE lcThisField = UPPER(STRTRAN(lcThisField,SPACE(1),"")) IF NOT EMPTY(lcThisField) IF ATCC(lcThisField, THIS.cFields) > 0 THIS.cFields = STRTRAN(THIS.cFields,lcThisField,"["+THIS.cControlCharacter+"]") llSkipped = .T. IF LEFTC(THIS.cFields,1) = "+" THIS.cFields = SUBSTRC(THIS.cFields,2) ENDIF IF RIGHTC(THIS.cFields,1) = "+" THIS.cFields = SUBSTRC(THIS.cFields,1,LENC(THIS.cFields)-1) ENDIF IF EMPTY(THIS.cFields) OR ; THIS.cFields == "["+THIS.cControlCharacter+"]" THIS.cAlias = "" ENDIF THIS.lFindAgain = .F. ENDIF ENDIF ENDIF RETURN llSkipped ENDPROC ENDDEFINE DEFINE CLASS _tablenav AS _table OF "_table.vcx" *< CLASSDATA: Baseclass="custom" Timestamp="" Scale="Pixels" Uniqueid="" /> #INCLUDE "_table.h" * *m: dobottommessage *m: docyclebottommessage *m: docycletopmessage *m: dotopmessage *m: gobottom && Moves record pointer to last record. *m: gonext && Moves record pointer to next record. *m: goprevious && Moves record pointer to previous record. *m: gotop && Moves record pointer to first record. *m: gotorecord && Moves record pointer to a specified record. *p: lcycle && Controls movement when record pointer hits end or beginning of file. * * Name = "_tablenav" * PROCEDURE dobottommessage ENDPROC PROCEDURE docyclebottommessage ENDPROC PROCEDURE docycletopmessage ENDPROC PROCEDURE dotopmessage ENDPROC PROCEDURE gobottom && Moves record pointer to last record. LOCAL lcAlias lcAlias = THIS.GetCurrentAlias() IF THIS.CurrentTableAllowsNavigation(lcAlias) GO BOTTOM IN (lcAlias) THIS.RefreshUIAfterChange() ENDIF ENDPROC PROCEDURE gonext && Moves record pointer to next record. LOCAL lcAlias lcAlias = THIS.GetCurrentAlias() IF THIS.CurrentTableAllowsNavigation(lcAlias) SKIP IN (lcAlias) IF EOF(lcAlias) SKIP -1 IN (lcAlias) IF THIS.lCycle THIS.DoCycleTopMessage() THIS.GoTop() THIS.RefreshUIAfterChange() ELSE THIS.DoBottomMessage() ENDIF ELSE THIS.RefreshUIAfterChange() ENDIF ENDIF ENDPROC PROCEDURE goprevious && Moves record pointer to previous record. LOCAL lcAlias lcAlias = THIS.GetCurrentAlias() IF EMPTY(lcAlias) OR ; NOT THIS.CurrentTableAllowsNavigation(lcAlias) RETURN ENDIF DO CASE CASE (NOT BOF(lcAlias)) SKIP -1 IN (lcAlias) IF BOF(lcAlias) IF THIS.lCycle THIS.DoCycleBottomMessage() THIS.GoBottom() ELSE THIS.DoTopMessage() ENDIF ENDIF THIS.RefreshUIAfterChange() CASE BOF(lcAlias) IF THIS.lCycle THIS.DoCycleBottomMessage() THIS.GoBottom() THIS.RefreshUIAfterChange() ELSE THIS.DoTopMessage() ENDIF OTHERWISE ENDCASE ENDPROC PROCEDURE gotop && Moves record pointer to first record. LOCAL lcAlias lcAlias = THIS.GetCurrentAlias() IF THIS.CurrentTableAllowsNavigation(lcAlias) GO TOP IN (lcAlias) THIS.RefreshUIAfterChange() ENDIF ENDPROC PROCEDURE gotorecord && Moves record pointer to a specified record. LPARAMETERS tiRecord ASSERT PCOUNT() = 1 AND VARTYPE(tiRecord) = "N" LOCAL lcAlias lcAlias = THIS.GetCurrentAlias() IF THIS.CurrentTableAllowsNavigation(lcAlias) AND ; (RECCOUNT(lcAlias) >= tiRecord) GO tiRecord IN (lcAlias) THIS.RefreshUIAfterChange() ENDIF ENDPROC ENDDEFINE DEFINE CLASS _tablesort AS _table OF "_table.vcx" *< CLASSDATA: Baseclass="custom" Timestamp="" Scale="Pixels" Uniqueid="" /> * *m: dosort && DoSort([tcField] [,tcAlias] [,tcTag] [,tlDescending]) allows you to specify exactly what order in what table you would like to set -- or, if you prefer, which field in a given alias you would like to set order to. *m: getsorttag && Looks for an appropriate tagname by looking at key expressions in this table relevant to this fieldname. *m: removesort && Removes the current order (index tag). *p: ldescending && Whether order is ascending or descending. * * Name = "_tablesort" * PROCEDURE dosort && DoSort([tcField] [,tcAlias] [,tcTag] [,tlDescending]) allows you to specify exactly what order in what table you would like to set -- or, if you prefer, which field in a given alias you would like to set order to. LPARAMETERS tcField, tcAlias, tcTag, tlDescending THIS.SetToActiveSession() ASSERT EMPTY(tcField) OR ; (VARTYPE(tcField) = "C" AND ; TYPE(IIF(EMPTY(tcAlias),"",tcAlias+".")+tcField) # "U") ASSERT EMPTY(tcAlias) OR (VARTYPE(tcAlias) = "C" AND USED(tcAlias)) ASSERT EMPTY(tcAlias) OR (NOT EMPTY(tcField)) ASSERT EMPTY(tcTag) OR VARTYPE(tcTag) = "C" ASSERT VARTYPE(tlDescending) = "L" LOCAL lcField, lcAlias, liPos, lcTag, liSelect, llDescending IF PCOUNT() > 3 llDescending = tlDescending ELSE llDescending = THIS.lDescending ENDIF DO CASE CASE EMPTY(tcAlias) AND EMPTY(tcField) lcField = THIS.GetCurrentBoundField() * will be properly aliased if one can be found IF NOT EMPTY(lcField) liPos = AT(".",lcField) lcAlias = LEFT(lcField,liPos-1) lcField = SUBSTR(lcField,liPos+1) ELSE lcField = "" lcAlias = THIS.GetCurrentAlias() ENDIF CASE (NOT EMPTY(tcAlias)) AND USED(tcAlias) lcField = tcField lcAlias = tcAlias OTHERWISE lcField = tcField lcAlias = THIS.GetCurrentAlias() ENDCASE IF NOT THIS.CurrentTableAllowsOrdering(lcAlias) RETURN .F. ENDIF IF VARTYPE(tcTag) = "C" * the SELECTs are necessary * because TAGNO() doesn't work * on the non-selected area properly, * although it is doc'd to work... IF NOT EMPTY(lcAlias) liSelect = SELECT() SELECT (lcAlias) ENDIF IF NOT EMPTY(TAGNO(tcTag)) lcTag = tcTag ENDIF IF NOT EMPTY(lcAlias) SELECT (liSelect) ENDIF ENDIF IF EMPTY(lcTag) AND (TYPE(lcAlias+"."+lcField) = "U") RETURN .F. ENDIF IF EMPTY(lcTag) lcTag = THIS.GetSortTag(lcField,lcAlias) ENDIF IF NOT EMPTY(lcTag) IF EMPTY(lcAlias) lcAlias = "" ELSE lcAlias = "IN "+lcAlias ENDIF IF llDescending SET ORDER TO (lcTag) &lcAlias DESCENDING ELSE SET ORDER TO (lcTag) &lcAlias ASCENDING ENDIF THIS.RefreshUIAfterChange() ENDIF RETURN (NOT EMPTY(lcTag)) ENDPROC PROCEDURE getsorttag && Looks for an appropriate tagname by looking at key expressions in this table relevant to this fieldname. LPARAMETERS tcField, tcAlias ASSERT VARTYPE(tcAlias) = "C" AND USED(tcAlias) ASSERT TYPE(tcAlias+"."+tcField) # "U" LOCAL lcAlias, lcField, liTags, liSelect, lcKey, lcExact, lcTag, lcAliasedField, ; lnIndex lcAlias = UPPER(tcAlias) && must be passed! lcField = UPPER(tcField) && ditto! lcTag = "" liSelect = SELECT() lcExact = SET("EXACT") SELECT (lcAlias) SET EXACT OFF liTags = TAGCOUNT() lcAliasedField = UPPER(lcAlias)+"."+lcField IF liTags > 0 FOR lnIndex = 1 to liTags lcKey = UPPER(KEY(lnIndex)) IF TYPE(lcKey) # "U" * this test makes sure that the index expression * can be evaluated in the current environment * now test to see if we can use it for * the current purpose, with an inexact * comparison since that's all we need * for an adequate sort lcKey = NORMALIZE(lcKey) IF lcKey = lcField OR ; lcKey = lcAliasedField OR ; lcKey = "UPPER("+lcField+")" OR ; lcKey = "UPPER("+lcAliasedField+")" OR ; lcKey = "UPPER("+lcField+"+" OR ; lcKey = "UPPER("+lcAliasedField+"+" OR ; lcKey = "LOWER("+lcField+")" OR ; lcKey = "LOWER("+lcAliasedField+")" OR ; lcKey = "LOWER("+lcField+"+" OR ; lcKey = "LOWER("+lcAliasedField+"+" OR ; lcKey = "PROPER("+lcField+")" OR ; lcKey = "PROPER("+lcAliasedField+")" OR ; lcKey = "PROPER("+lcField+"+" OR ; lcKey = "PROPER("+lcAliasedField+"+" OR ; lcKey = "SUBSTR("+lcField+"," OR ; lcKey = "SUBSTR("+lcAliasedField+"," OR ; lcKey = "LEFT("+lcField+"," OR ; lcKey = "LEFT("+lcAliasedField+"," OR ; lcKey = "SUBSTRC("+lcField+"," OR ; lcKey = "SUBSTRC("+lcAliasedField+"," OR ; lcKey = "LEFTC("+lcField+"," OR ; lcKey = "LEFTC("+lcAliasedField+"," lcTag = UPPER(TAG(lnIndex)) EXIT ENDIF ENDIF ENDFOR ENDIF SET EXACT &lcExact SELECT (liSelect) RETURN lcTag ENDPROC PROCEDURE removesort && Removes the current order (index tag). LPARAMETERS tcAlias THIS.SetToActiveSession() ASSERT EMPTY(tcAlias) OR (VARTYPE(tcAlias) = "C" AND USED(tcAlias)) LOCAL lcAlias IF EMPTY(tcAlias) lcAlias = THIS.GetCurrentAlias() ELSE lcAlias = tcAlias ENDIF IF NOT USED(lcAlias) RETURN .F. ENDIF SET ORDER TO 0 IN (lcAlias) THIS.RefreshUIAfterChange() ENDPROC ENDDEFINE