**************************************************
*-- Class: grdsorting (c:\mmviscollect\libs\acustomcontrols.vcx)
*-- ParentClass: cgrid (c:\mmortals\common30\libs\ccontrls.vcx)
*-- BaseClass: grid
*-- Time Stamp: 04/01/05 10:47:05 AM
*-- Subclass of cGrid class which delegates Header click event to HeaderClick custom method (this method sorts by column's controlsource) and also delegates column's textboxes' DblClick to grid's DblClick
*
DEFINE CLASS grdsorting AS cgrid
HighlightBackColor = RGB(0,0,255)
HighlightStyle = 2
*-- This property tells, if we want to add visual representation of the sorting
lshowsortingarrows = .T.
*-- This property tells, if the grid's recordsource should be at the top after sorting
lgotopaftersorting = .T.
*-- If this property is set to true (default), then the indexes are created for every column in the grid
lcreateindexes = .T.
Name = "grdsorting"
*-- This property tells wheither we need to update toolbar buttons or not
lupdatetoolbar = .F.
*-- This property saves the header of the last sorted column
olastsorted = .F.
*-- If this property is set, use DynamicBackColor to set highlight
lmanualhighlight = .F.
*-- Holds grid's column controlsources and sizes
cgridscript = .F.
*-- If this property is set to true, then grid's properties are saved
lsavegridproperties = .F.
*-- This method is invoked when any grid's column header is clicked
PROCEDURE headerclick
*---------------------- Location Section ------------------------
* Library: Acustomcontrols.vcx
* Class: GrdSorting
* Method: HeaderClick()
*----------------------- Usage Section --------------------------
*) Description: Custom method which fires when Header is clicked (idea from Barbara Peisch)
*)
* Scope: Public
* Parameters:
*$ Usage:
*$
* Returns:
*--------------------- Maintenance Section ----------------------
* Change Log:
* CREATED 01/06/2005 - NN
* MODIFIED
*----------------------------------------------------------------
*SET COVERAGE TO Cover.log additive
LOCAL loCalledBy && as Object
AEVENTS[aCurEvent,0]
loCalledBy = aCurEvent[1] && should be a Header object
IF VARTYPE(m.loCalledBy)= "O" AND NOT EMPTY(m.loCalledBy.PARENT.CONTROLSOURCE)
LOCAL lcOrder, lcRecSource, llDirection
lcRecSource = THIS.RECORDSOURCE
llDirection = THIS.lAscending
lcOrder = ORDER(m.lcRecSource) && Saves current tag
THIS.SetOrder(m.loCalledBy.PARENT.CONTROLSOURCE, m.loCalledBy.CurrentTag)
IF THIS.lShowSortingArrows
* Check, if we changed the order
IF NOT ORDER(m.lcRecSource)== m.lcOrder OR m.llDirection <> THIS.lAscending
** Clear the picture of the previously sorted column
m.loCalledBy.CurrentTag = this.cTagName
THIS.ClearHeaderPictures()
THIS.SetHeaderPicture(m.loCalledBy)
ENDIF
ENDIF
ENDIF
*SET COVERAGE TO
this.MousePointer = 0
ENDPROC
*-- This method removes pictures from all the headers
PROCEDURE clearheaderpictures
*---------------------- Location Section ------------------------
* Library: Acustomcontrols.vcx
* Class: Grdsorting
* Method: ClearHeaderPictures()
*----------------------- Usage Section --------------------------
*) Description:
*)
* Scope: Public
* Parameters:
*$ Usage:
*$
* Returns:
*--------------------- Maintenance Section ----------------------
* Change Log:
* CREATED 01/24/2005 - NN
* MODIFIED
*----------------------------------------------------------------
*!* LOCAL liColumn
*!* FOR liColumn=1 to m.this.ColumnCount
*!* this.Columns[m.liColumn].Controls[1].ResetToDefault('picture')
*!* NEXT
IF VARTYPE(m.this.oLastSorted) = "O"
this.oLastSorted.ResetToDefault('picture')
ENDIF
ENDPROC
*-- This method sets picture for the Header object which is passed by reference
PROCEDURE setheaderpicture
*---------------------- Location Section ------------------------
* Library: Acustomcontrols.vcx
* Class: Grdsorting
* Method: Setheaderpicture()
*----------------------- Usage Section --------------------------
*) Description:
*)
* Scope: Public
* Parameters:
*$ Usage:
*$
* Returns:
*--------------------- Maintenance Section ----------------------
* Change Log:
* CREATED 01/25/2005 - NN
* MODIFIED
*----------------------------------------------------------------
LPARAMETERS toHeader, tcPicture
IF VARTYPE(m.toHeader) <> "O"
RETURN .f.
ENDIF
toHeader.caption = PADR(ALLTRIM(m.toHeader.caption),100) && we want to show picture at the right
toHeader.picture = IIF(not EMPTY(m.tcPicture), m.tcPicture, ;
IIF(this.lAscending, "UpArrow.bmp","DownArrow.bmp"))
this.oLastSorted = m.toHeader
ENDPROC
*-- Indexes a column on the fly
PROCEDURE createtag
*---------------------- Location Section ------------------------
* Library: Acustomcontrols.vcx
* Class: Grdsorting
* Method: Createtag()
*----------------------- Usage Section --------------------------
*) Description:
*)
* Scope: Public
* Parameters:
*$ Usage:
*$
* Returns:
*--------------------- Maintenance Section ----------------------
* Change Log:
* CREATED 02/07/2005 - NN
* MODIFIED
*----------------------------------------------------------------
* assuming alias for sorting is in current workarea
* assuming this method is called from the Sorting Manager code only from this class.
Lparameters toHeader
Local lc__SortExpr, lnLimitation, llNonStructural, loSelect
loSelect = Createobject('CSelect', This.RecordSource)
With m.toHeader
* calculate the expression for sorting
lnLimitation = Iif(Set("Collate")=="MACHINE",240,120)
lc__SortExpr = .Parent.ControlSource
* make basic checking for control source type
Local lcType, lnValLen, llIsField, lcTag, lcField, lcCursor
lcType = Type(m.lc__SortExpr)
llIsField = '.' $ m.lc__SortExpr And ;
used(Left(m.lc__SortExpr,At('.',m.lc__SortExpr)-1)) And ;
fsize(Substr(m.lc__SortExpr,At('.',m.lc__SortExpr)+1),Left(m.lc__SortExpr,At('.',m.lc__SortExpr)-1)) > 0
lcTag = ""
If m.llIsField
lcField = Justext("." + m.lc__SortExpr)
lcCursor = Juststem(m.lc__SortExpr)
lcTag = This.GetTagName (m.lcCursor, m.lcField)
Endif
If Empty(m.lcTag)
Do Case
Case m.lcType $ "GOPUS"
lc__SortExpr = ""
Case m.lcType == "C"
If m.llIsField
lnValLen = Min(Fsize(Substr(m.lc__SortExpr,At('.',m.lc__SortExpr)+1),Left(m.lc__SortExpr,At('.',m.lc__SortExpr)-1)),m.lnLimitation)
Else
lnValLen = m.lnLimitation
Endif
lc__SortExpr = "PADR(NVL(" + m.lc__SortExpr + ",'')," + Allt(Str(m.lnValLen))+")"
Case m.lcType == "M"
lc__SortExpr = "PADR(" + m.lc__SortExpr + "," + Allt(Str(m.lnLimitation))+")"
Otherwise
Do Case
Case m.lcType $ "DT"
lc__SortExpr = "NVL(" + m.lc__SortExpr + ",{})"
Case m.lcType == "L"
lc__SortExpr = "NVL(" + m.lc__SortExpr + ",.F.)"
Case m.lcType == "Y"
lc__SortExpr = "NVL(" + m.lc__SortExpr + ",$0)"
Otherwise
lc__SortExpr = "NVL(" + m.lc__SortExpr + ",0)"
Endcase
Endcase
&& create index tag
If !Empty(m.lc__SortExpr)
.CurrentTag = "T" + Substr(Alltrim(Sys(2015)), 4, 10) && generate unique tag name
Local lnRestoreBuffering
lnRestoreBuffering = CursorGetProp('Buffering')
If m.lnRestoreBuffering >= 4
&& OOPS - cannot index cursors in 5 buffering mode.
&& check that it does not contain modified records
If Getnextmodified(0) = 0
CursorSetProp('Buffering',Iif(m.lnRestoreBuffering=5,3,2))
Else
&& OOPS - we will not be able to index it...
.CurrentTag = ""
Endif
Endif
&& check how we should create index - structural or non-structural
llNonStructural = CursorGetProp('SourceType')=3 And (! Isexclusive() Or ;
!(CursorGetProp('Database')=="") Or !(Sys(2023) == Justpath(Dbf())) )
* it is a table for which either database is specified or file path is not in temporary folder
* or just alias is not opened in exclusive mode (file in temporary folder, but it is shared)
If !Empty(.CurrentTag)
&& disable errors
Local lc___OldError
Private m.ll__Error
ll__Error = .F.
lc___OldError = On("ERROR")
On Error m.ll__Error = .T.
Local llShowHere, lnOldRecNo
lnOldRecNo = Iif(Eof(),0,Recno())
llShowHere = .F.
If Reccount() > 1000
llShowHere = .T.
* .DispSortingMessage(.t.)
Endif
If m.llNonStructural
Index On ;
&lc__SortExpr ;
tag (.CurrentTag) Of (Sys(2023) + "\" + .CurrentTag) Additive
Else
Index On ;
&lc__SortExpr ;
tag (.CurrentTag) Additive
Endif
If m.llShowHere
* .DispSortingMessage(.f.)
Endif
If m.ll__Error && error occurred during indexing
.CurrentTag = "" && indicate no tag is created
Endif
* restore record number
If m.lnOldRecNo = 0
Go Bottom
If !Eof()
Skip
Endif
Else
Go (m.lnOldRecNo)
Endif
On Error &lc___OldError
If m.lnRestoreBuffering >= 4
CursorSetProp('Buffering',m.lnRestoreBuffering)
Endif
Endif
Else
.CurrentTag = ""
Endif
Else
.CurrentTag = m.lcTag
Endif
Endwith
ENDPROC
*-- Returns the tag name (if exists) for the passed field name
PROCEDURE gettagname
*---------------------- Location Section ------------------------
* Library: Acustomcontrols.vcx
* Class: Grdsorting
* Method: Gettagname()
*----------------------- Usage Section --------------------------
*) Description:
*)
* Scope: Public
* Parameters:
*$ Usage:
*$
* Returns:
*--------------------- Maintenance Section ----------------------
* Change Log:
* CREATED 02/10/2005 - NN
* MODIFIED
*----------------------------------------------------------------
Lparameters tcCursor, tcField
*----------------------------------------------
*--- A tag name was not passed. Try to find a
*--- tag for the current column's ControlSource
*--- Get the number of indexes for the cursor.
*----------------------------------------------
LOCAL lnCount, lcIndexExpr, lnIndexes, lcTagName
LOCAL ARRAY laIndex[1]
lnIndexes = AIndexes(@laIndex, m.tcCursor)
lcTagName = ""
*----------------------------------------------------------------
*-- See if the field name is in the leftmost part of an index
*-- expression OR simply within an UPPER() statement.
*-- If so, SET ORDER TO the index.
*----------------------------------------------------------------
For lnCount = 1 To m.lnIndexes
lcIndexExpr = Upper(Sys(14, m.lnCount, m.tcCursor))
*--------------------------------------------------
*--- Allow for character indexes that are simply
*--- surrounded by "UPPER()". Remove "UPPER()".
*--------------------------------------------------
If Left(m.lcIndexExpr,6) = 'UPPER('
lcIndexExpr = Substr(m.lcIndexExpr,7)
lcIndexExpr = Substr(m.lcIndexExpr,1,Len(m.lcIndexExpr)-1)
Endif
If m.lcIndexExpr = Upper(m.tcField)
lcTagName = Tag(m.lnCount, m.tcCursor)
*--- Index found...exit ---*
lnCount = m.lnIndexes + 1
Endif
Endfor
Return m.lcTagName
ENDPROC
*-- This method saves column's properties as a script
PROCEDURE savegridproperties
*---------------------- Location Section ------------------------
* Library: Acustomcontrols.vcx
* Class: Grdsorting
* Method: Savegridproperties()
*----------------------- Usage Section --------------------------
*) Description:
*)
* Scope: Public
* Parameters:
*$ Usage:
*$
* Returns:
*--------------------- Maintenance Section ----------------------
* Change Log:
* CREATED 03/30/2005 - WGB
* CHANGED - NN - March 31, 2005 - 09:53:29
*----------------------------------------------------------------
LOCAL lcGridScript, lcReference, loColumn
lcReference = SYS(1272, this)
lcReference = "_screen.ActiveForm." + SUBSTR(m.lcReference,AT(".",m.lcReference)+1)
SET TEXTMERGE ON
SET TEXTMERGE TO MEMVAR lcGridScript NOSHOW && TEXTMERGE begins on the next line.
\With <<m.lcReference>>
FOR EACH loColumn IN this.Columns
\.<<loColumn.name>>.ControlSource = "<<loColumn.ControlSource>>"
\.<<loColumn.name>>.width = <<loColumn.width>>
NEXT
\endwith
SET TEXTMERGE TO
SET TEXTMERGE OFF
this.cGridScript = m.lcGridScript
ENDPROC
*-- This method sets columns' properties
PROCEDURE resetgridproperties
*---------------------- Location Section ------------------------
* Library: Acustomcontrols.vcx
* Class: Grdsorting
* Method: Resetgridproperties()
*----------------------- Usage Section --------------------------
*) Description:
*)
* Scope: Public
* Parameters:
*$ Usage:
*$
* Returns:
*--------------------- Maintenance Section ----------------------
* Change Log:
* CREATED 03/30/2005 - WGB
* MODIFIED
*----------------------------------------------------------------
IF !EMPTY( this.cGridscript )
EXECSCRIPT(this.cGridscript )
ENDIF
ENDPROC
PROCEDURE BeforeRowColChange
*---------------------- Location Section ------------------------
* Library: Acustomcontrols.vcx
* Class: Grdsorting
* Method: Beforerowcolchange()
*----------------------- Usage Section --------------------------
*) Description:
*)
* Scope: Public
* Parameters:
*$ Usage:
*$
* Returns:
*--------------------- Maintenance Section ----------------------
* Change Log:
* CREATED 03/11/2005 - NN
* MODIFIED
*----------------------------------------------------------------
LPARAMETERS nColIndex
IF this.lManualHighlight
thisform.LockScreen = .t.
ENDIF
DODEFAULT(m.nColIndex)
ENDPROC
PROCEDURE setorder
*---------------------- Location Section ------------------------
* Library: Acustomcontrols.vcx
* Class: Grdsorting
* Method: SetOrder()
*----------------------- Usage Section --------------------------
*) Description:
*) This method checks if there is a tag for the current
*) column's RowSource (specified in tcControlSource),
*) and if so, sets the order to it AND sets cGrid.cTagName
*) to the tag name of the index. If the optional second
*) parameter is passed, it simply issues a SET ORDER
*) on the tag.
*
* Scope: Public
* Parameters:
* 1. tcControlSource - Name of the ControlSource
* 2. tcTagName - (optional)Name of an index tag to
* be used to SET ORDER
*
*$ Usage: Typically called from the Click() method of
* a grid header.
*
* Returns: Logical .T. by default
*--------------------- Maintenance Section ----------------------
* Change Log:
* MODIFIED 10/27/97 - KJM
* Moved this method up the hierarchy from CSetOrderGrid
* to CGrid so that SetOrder functionality is available
* to all grids in the framework. CSetOrderGrid, although
* no longer necessary is left in the framework for
* backward compatibility.
* Also enhanced the code to allow for index expressions
* that are simply surrounded by an UPPER() statement.
* MODIFIED 04/16/98 - KJM
* Added a second tcTagName parameter. If a value has
* been passed ignore the tcControlSource parameter for
* now (may be used in the future) and set the ORDER
* to the specified tag.
* MODIFIED 07/10/99 - KJM
* Enhanced this method so that clicking on a column
* header toggles the ascending/descending order of
* the currently selected column.
* MODIFIED 11/01/99 - KJM
* Check if RECCOUNT() > 0 before issuing GOTO lnRecNo
* MODIFIED 10/05/00 - KJM
* Added a call to ThisForm.SetFilePos() so the
* navigation toolbar gets properly refreshed.
* MODIFIED 06/25/02 - KJM
* Changed "IF NOT tcTagName == UPPER(This.cTagName)"
* to "IF NOT UPPER(tcTagName) == UPPER(This.cTagName)"
*-----------------------------------------------------------------
* MODIFIED 01/25/2005 - NN -
* Added two new grid properties to not refresh toolbars and to go top after sorting
* Also do not sort if empty grid
*----------------------------------------------------------------
LPARAMETERS tcControlSource, tcTagName
LOCAL lcField, lcCursor, lcAscDesc, lnRecNo, loSelect
*----------------------------------------------------------
*-- Get the field and cursor name for the ControlSource
*----------------------------------------------------------
lcField = JUSTEXT("." + m.tcControlSource)
lcCursor = JUSTSTEM(m.tcControlSource)
* Change by NN
IF RECCOUNT(m.lcCursor) = 0 && empty cursor, why bother?
RETURN
ENDIF
lnRecNo = RECNO(m.lcCursor)
loSelect = CREATEOBJECT('CSelect', m.lcCursor)
IF PCOUNT() < 2 OR EMPTY(m.tcTagName) OR TAGNO(m.tcTagName) = 0
tcTagName = this.GetTagName(m.lcCursor, m.lcField)
ENDIF
*----------------------------------
*--- Determine ASCENDING/DESCENDING
*----------------------------------
IF NOT EMPTY(m.tcTagName)
IF NOT UPPER(m.tcTagName) == UPPER(THIS.cTagName)
*--- Default to ascending ---*
THIS.lAscending = .T.
ELSE
*--- Toggle ascending/descending ---*
THIS.lAscending = NOT THIS.lAscending
ENDIF
*------------------------
*--- SET ORDER to the tag
*------------------------
THIS.cTagName = m.tcTagName
lcAscDesc = IIF(THIS.lAscending, 'ASCENDING', 'DESCENDING')
SET ORDER TO TAG (m.tcTagName) IN (m.lcCursor) &lcAscDesc
*---------------------------------------------------
*--- Refresh the grid and restore the record pointer
*--- If done in the reverse order (GOTO, Refresh),
*--- the grid is visually on the wrong record.
*---------------------------------------------------
THIS.REFRESH()
*-- CHANGE - NN - January 25, 2005 - 09:37:53
IF THIS.lGoTopAfterSorting
GO TOP IN (m.lcCursor)
ELSE
IF RECCOUNT(m.lcCursor) > 0
GOTO m.lnRecNo IN (m.lcCursor)
ENDIF
ENDIF
*-- CHANGE - NN - January 25, 2005 - 09:38:59 - added a new property
IF THIS.lUpdateToolbar
THISFORM.SetFilePos() && Note, that this code assumes existance of the SetFilePos method
ENDIF
ENDIF
ENDPROC
PROCEDURE Init
*---------------------- Location Section ------------------------
* Library: Acustomcontrols.vcx
* Class: Grdsorting
* Method: Init()
*----------------------- Usage Section --------------------------
*) Description: (ideas from message #946490 by Barbara Peisch)
*)
* Scope: Public
* Parameters:
*$ Usage:
*$
* Returns:
*--------------------- Maintenance Section ----------------------
* Change Log:
* CREATED 01/06/2005 - NN
* MODIFIED 01/10/05 - JMW Changed the variable names to
* Hungarian notation.
* MODIFIED 03/11/2005 - NN
*----------------------------------------------------------------
IF NOT DODEFAULT()
RETURN .f.
ENDIF
LOCAL loColumn, loControl
* Delegate header's click to grid's HeaderClick custom method
* and column's textbox DblClick to grid's DblClick
FOR EACH loColumn IN THIS.COLUMNS
FOR EACH loControl IN loColumn.CONTROLS
IF UPPER(loControl.BASECLASS) = "HEADER"
BINDEVENT(loControl,"Click",THIS,"HeaderClick")
m.loControl.AddProperty("CurrentTag","") && Adds CurrentTag property
IF this.lCreateIndexes && Adds indexes on the fly
this.CreateTag (m.loControl)
endif
ELSE
IF UPPER(loControl.BASECLASS) = "TEXTBOX"
BINDEVENT(loControl,"DblClick",THIS,"DblClick")
ENDIF
ENDIF
ENDFOR
ENDFOR
IF this.lManualHighlight
this.SetAll("DynamicBackColor","iif(recno(this.RecordSource)=this.nRecno,this.HighlightBackColor,this.BackColor)", "Column")
this.SetAll("DynamicForeColor","iif(recno(this.RecordSource)=this.nRecno,this.HighlightForeColor,this.ForeColor)", "Column")
this.HighlightStyle = 0
ENDIF
IF this.lSaveGridProperties
this.SaveGridProperties()
ENDIF
ENDPROC
PROCEDURE Destroy
*---------------------- Location Section ------------------------
* Library: Acustomcontrols.vcx
* Class: Grdsorting
* Method: Destroy()
*----------------------- Usage Section --------------------------
*) Description:
*)
* Scope: Public
* Parameters:
*$ Usage:
*$
* Returns:
*--------------------- Maintenance Section ----------------------
* Change Log:
* CREATED 02/03/2005 - NN
* MODIFIED
*----------------------------------------------------------------
this.oLastSorted = null
RETURN DODEFAULT()
ENDPROC
PROCEDURE AfterRowColChange
*---------------------- Location Section ------------------------
* Library: Acustomcontrols.vcx
* Class: Grdsorting
* Method: Afterrowcolchange()
*----------------------- Usage Section --------------------------
*) Description:
*)
* Scope: Public
* Parameters:
*$ Usage: Sets highlight by using DynamicBackColor
*$
* Returns:
*--------------------- Maintenance Section ----------------------
* Change Log:
* CREATED 03/11/2005 - NN
* MODIFIED
*----------------------------------------------------------------
LPARAMETERS nColIndex
this.nRecno = RECNO(this.RecordSource)
IF this.lManualHighlight
IF INLIST(this.RowColChange, 1, 3) && Row change
this.Refresh()
ENDIF
ENDIF
DODEFAULT(m.nColIndex)
thisform.LockScreen = .f.
ENDPROC
*-- This method re-creates indexes used for sorting. It should be called explicitly after re-creating grid's recorsource
PROCEDURE recreateindexes
*---------------------- Location Section ------------------------
* Library: Acustomcontrols.vcx
* Class: Grdsorting
* Method: Recreateindexes()
*----------------------- Usage Section --------------------------
*) Description:
*)
* Scope: Public
* Parameters:
*$ Usage:
*$
* Returns:
*--------------------- Maintenance Section ----------------------
* Change Log:
* CREATED 04/01/2005 - NN
* MODIFIED
*----------------------------------------------------------------
LOCAL loColumn, loControl
FOR EACH loColumn IN THIS.COLUMNS
FOR EACH loControl IN loColumn.CONTROLS
IF UPPER(loControl.BASECLASS) = "HEADER"
this.CreateTag (m.loControl)
ENDIF
ENDFOR
ENDFOR
ENDPROC
ENDDEFINE
*
*-- EndDefine: grdsorting
**************************************************
