romfast/roaregistratura
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
6769eb61d1e27eb7cf738169d385daf19b39b361
roaregistratura/Clase/_table.vc2

3719 lines
94 KiB
Plaintext
Raw Blame History

*--------------------------------------------------------------------------------------------------------------------------------------------------------
* (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"
*<DefinedPropArrayMethod>
*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]
*</DefinedPropArrayMethod>
*<PropValue>
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.
*</PropValue>
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", ;
FontName = "MS Sans Serif", ;
FontSize = 9, ;
Height = 23, ;
Left = 14, ;
Name = "cmdAdd", ;
ReleaseErase = .F., ;
StatusBarText = ("Add this expression to the criteria list"), ;
TabIndex = 10, ;
Top = 245, ;
Width = 45
*< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" />
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 = "\<Delete", ;
FontName = "MS Sans Serif", ;
FontSize = 9, ;
Height = 23, ;
Left = 67, ;
Name = "cmdDelete", ;
ReleaseErase = .F., ;
StatusBarText = ("Remove the current item from the list"), ;
TabIndex = 11, ;
Top = 245, ;
Width = 45
*< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" />
ADD OBJECT 'cmdDown' AS _commandbutton WITH ;
AutoSize = .F., ;
Caption = "Do\<wn", ;
FontName = "MS Sans Serif", ;
FontSize = 9, ;
Height = 23, ;
Left = 256, ;
Name = "cmdDown", ;
ReleaseErase = .F., ;
StatusBarText = ("Move selected item down one row"), ;
TabIndex = 14, ;
Top = 245, ;
Width = 47
*< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" />
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 = "\<Or", ;
FontName = "MS Sans Serif", ;
FontSize = 9, ;
Height = 23, ;
Left = 134, ;
Name = "cmdOr", ;
ReleaseErase = .F., ;
StatusBarText = ("Add an OR condition to the list"), ;
TabIndex = 12, ;
Top = 245, ;
Width = 45
*< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" />
ADD OBJECT 'cmdReset' AS _commandbutton WITH ;
AutoSize = .F., ;
Caption = "\<Reset", ;
FontName = "MS Sans Serif", ;
FontSize = 9, ;
Height = 23, ;
Left = 325, ;
Name = "cmdReset", ;
ReleaseErase = .F., ;
StatusBarText = ("Clear the criteria list"), ;
TabIndex = 15, ;
Top = 245, ;
Width = 46
*< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" />
ADD OBJECT 'cmdUp' AS _commandbutton WITH ;
AutoSize = .F., ;
Caption = "\<Up", ;
FontName = "MS Sans Serif", ;
FontSize = 9, ;
Height = 23, ;
Left = 206, ;
Name = "cmdUp", ;
ReleaseErase = .F., ;
StatusBarText = ("Move selected item up one row"), ;
TabIndex = 13, ;
Top = 245, ;
Width = 47
*< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" />
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\<er"), ;
DisabledBackColor = 225,225,225, ;
FontName = "MS Sans Serif", ;
FontSize = 9, ;
Height = 15, ;
Left = 238, ;
Name = "lblOrder", ;
ReleaseErase = .F., ;
TabIndex = 3, ;
Top = 9, ;
Width = 28
*< END OBJECT: ClassLib="_base.vcx" BaseClass="label" />
ADD OBJECT 'lblTables' AS _label WITH ;
AutoSize = .T., ;
BackStyle = 0, ;
Caption = ("\<Table"), ;
DisabledBackColor = 225,225,225, ;
FontName = "MS Sans Serif", ;
FontSize = 9, ;
Height = 15, ;
Left = 7, ;
Name = "lblTables", ;
ReleaseErase = .F., ;
TabIndex = 1, ;
Top = 9, ;
Width = 29
*< END OBJECT: ClassLib="_base.vcx" BaseClass="label" />
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) && "<22>" -- 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"
*<DefinedPropArrayMethod>
*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).
*</DefinedPropArrayMethod>
*<PropValue>
AutoCenter = .T.
BorderStyle = 0
Caption = "Set Filter"
cfilter = (SPACE(254))
DoCreate = .T.
Height = 155
ioldselect = 0
ioldsession = 0
Name = "_filterexpr"
Width = 328
WindowType = 1
*</PropValue>
ADD OBJECT 'cmdApply' AS _commandbutton WITH ;
Caption = "\<Apply", ;
FontName = "MS Sans Serif", ;
Height = 23, ;
Left = 178, ;
Name = "cmdApply", ;
TabIndex = 4, ;
Top = 125, ;
Width = 68
*< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" />
ADD OBJECT 'cmdBuild' AS _commandbutton WITH ;
AutoSize = .F., ;
Caption = "\<Build Expression...", ;
FontName = "MS Sans Serif", ;
Height = 23, ;
Left = 10, ;
Name = "cmdBuild", ;
TabIndex = 3, ;
Top = 125, ;
Width = 104, ;
ZOrderSet = 3
*< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" />
ADD OBJECT 'cmdCancel' AS _commandbutton WITH ;
Cancel = .T., ;
Caption = "\<Cancel", ;
FontName = "MS Sans Serif", ;
Height = 23, ;
Left = 252, ;
Name = "cmdCancel", ;
TabIndex = 5, ;
Top = 125, ;
Width = 68
*< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" />
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 = "\<Edit", ;
FontName = "MS Sans Serif", ;
Height = 15, ;
Left = 8, ;
Name = "lblEdit", ;
TabIndex = 1, ;
Top = 4, ;
Width = 20
*< END OBJECT: ClassLib="_base.vcx" BaseClass="label" />
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"
*<DefinedPropArrayMethod>
*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.
*</DefinedPropArrayMethod>
*<PropValue>
BackStyle = 0
BorderWidth = 0
calias = ("")
cfindstring = ("")
Height = 28
Name = "_findbutton"
Width = 69
*</PropValue>
ADD OBJECT 'cmdTableFind' AS _commandbutton WITH ;
AutoSize = .T., ;
Caption = "\<Find", ;
Height = 27, ;
Left = 0, ;
Name = "cmdTableFind", ;
Top = 0, ;
Width = 42, ;
ZOrderSet = 0
*< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" />
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"
*<DefinedPropArrayMethod>
*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.
*</DefinedPropArrayMethod>
*<PropValue>
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
*</PropValue>
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 = "\<Match case", ;
FontName = "MS Sans Serif", ;
FontSize = 8, ;
Height = 15, ;
Left = 117, ;
Name = "chkMatchCase", ;
TabIndex = 7, ;
Top = 99, ;
Value = .F., ;
Width = 74
*< END OBJECT: ClassLib="_base.vcx" BaseClass="checkbox" />
ADD OBJECT 'chkSkipMemos' AS _checkbox WITH ;
AutoSize = .T., ;
Caption = "\<Skip memos", ;
FontName = "MS Sans Serif", ;
FontSize = 8, ;
Height = 15, ;
Left = 211, ;
Name = "chkSkipMemos", ;
TabIndex = 8, ;
Top = 99, ;
Value = .F., ;
Width = 75
*< END OBJECT: ClassLib="_base.vcx" BaseClass="checkbox" />
ADD OBJECT 'chkWrapAround' AS _checkbox WITH ;
AutoSize = .T., ;
BackStyle = 0, ;
Caption = "\<Wrap around", ;
FontName = "MS Sans Serif", ;
FontSize = 8, ;
Height = 15, ;
Left = 16, ;
Name = "chkWrapAround", ;
TabIndex = 6, ;
Top = 99, ;
Value = .F., ;
Width = 80
*< END OBJECT: ClassLib="_base.vcx" BaseClass="checkbox" />
ADD OBJECT 'cmdCancel' AS _commandbutton WITH ;
Cancel = .T., ;
Caption = "\<Cancel", ;
FontName = "MS Sans Serif", ;
FontSize = 8, ;
Height = 23, ;
Left = 305, ;
Name = "cmdCancel", ;
TabIndex = 10, ;
Top = 43, ;
Width = 63
*< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" />
ADD OBJECT 'cmdFind' AS _commandbutton WITH ;
Caption = "\<Find", ;
Default = .T., ;
FontName = "MS Sans Serif", ;
FontSize = 8, ;
Height = 23, ;
Left = 305, ;
Name = "cmdFind", ;
TabIndex = 9, ;
Top = 12, ;
Width = 63
*< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" />
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 = "\<Look for:", ;
FontName = "MS Sans Serif", ;
FontSize = 8, ;
Height = 15, ;
Left = 10, ;
Name = "lblFind", ;
TabIndex = 1, ;
Top = 14, ;
Width = 44
*< END OBJECT: ClassLib="_base.vcx" BaseClass="label" />
ADD OBJECT 'lblLookIn' AS _label WITH ;
AutoSize = .T., ;
BackStyle = 0, ;
BorderStyle = 0, ;
Caption = "Look \<in:", ;
FontName = "MS Sans Serif", ;
FontSize = 8, ;
Height = 15, ;
Left = 10, ;
Name = "lblLookIn", ;
TabIndex = 3, ;
Top = 51, ;
Width = 40
*< END OBJECT: ClassLib="_base.vcx" BaseClass="label" />
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"
*<PropValue>
calias = ("")
Height = 30
Name = "_findnextbuttons"
Width = 134
cmdTableFind.AutoSize = .F.
cmdTableFind.Name = "cmdTableFind"
cusTableFind.Left = 48
cusTableFind.Name = "cusTableFind"
cusTableFind.Top = 0
*</PropValue>
ADD OBJECT 'cmdTableFindNext' AS _commandbutton WITH ;
AutoSize = .T., ;
Caption = "Find \<Next", ;
Height = 27, ;
Left = 64, ;
Name = "cmdTableFindNext", ;
Top = 0, ;
Width = 69
*< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" />
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"
*<DefinedPropArrayMethod>
*m: refreshuiafterchange
*</DefinedPropArrayMethod>
*<PropValue>
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
*</PropValue>
ADD OBJECT 'cmdOK' AS _commandbutton WITH ;
AutoSize = .T., ;
Caption = "\<OK", ;
FontName = "MS Sans Serif", ;
Left = 65, ;
Name = "cmdOK", ;
Top = 48
*< END OBJECT: ClassLib="_base.vcx" BaseClass="commandbutton" />
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"
*<DefinedPropArrayMethod>
*m: lcycle_access
*m: lcycle_assign
*m: tablenav && Handles record navigation.
*p: lcycle && Controls movement when record pointer hits end or beginning of file.
*</DefinedPropArrayMethod>
*<PropValue>
BackStyle = 0
BorderWidth = 0
Height = 38
Name = "_nav2buttons"
Width = 78
*</PropValue>
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"
*<PropValue>
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"
*</PropValue>
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"
*<DefinedPropArrayMethod>
*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.
*</DefinedPropArrayMethod>
*<PropValue>
calias = ("")
Name = "_table"
*</PropValue>
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"
*<DefinedPropArrayMethod>
*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]
*</DefinedPropArrayMethod>
*<PropValue>
calias = ("")
ccontrolcharacter = ("~")
cfields = ("")
cfindstring = ("")
imemos = 0
Name = "_tablefind"
*</PropValue>
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"
*<DefinedPropArrayMethod>
*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.
*</DefinedPropArrayMethod>
*<PropValue>
Name = "_tablenav"
*</PropValue>
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="" />
*<DefinedPropArrayMethod>
*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.
*</DefinedPropArrayMethod>
*<PropValue>
Name = "_tablesort"
*</PropValue>
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
Reference in New Issue View Git Blame Copy Permalink