************************************************** *-- Class: grdsorting (c:\mmviscollect\libs\acustomcontrols.vcx) *-- ParentClass: cgrid (c:\mmortals\common30\libs\ccontrls.vcx) *-- BaseClass: grid *-- Time Stamp: 09/09/05 08:58:01 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) SelectedItemBackColor = 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. *-- This property tells wheither we need to update toolbar buttons or not lupdatetoolbar = .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 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.cOriginalControlSource) local lcOrder, lcRecSource, llDirection lcRecSource = this.recordsource llDirection = this.lAscending lcOrder = order(m.lcRecSource) && Saves current tag this.SetOrder(m.loCalledBy.parent.cOriginalControlSource, 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 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 IF toHeader.Alignment = 0 && Default toHeader.caption = PADR(ALLTRIM(m.toHeader.caption),100) && we want to show picture at the right endif 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: Creates index for the passed header's column's controlsource on the fly *) The code is taken from Vlad Grynchyshyn (with NN's minor modifications) * 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, lcOrder loSelect = createobject('CSelect', this.recordsource) lcOrder = order() with m.toHeader * calculate the expression for sorting lnLimitation = iif(set("Collate")=="MACHINE",240,120) lc__SortExpr = .parent.cOriginalControlSource * 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 if not empty(m.lcOrder) set order to (m.lcOrder) else set order to endif 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 05/03/2005 - NN *---------------------------------------------------------------- *!* IF !EMPTY( this.cGridscript ) *!* EXECSCRIPT(this.cGridscript ) *!* ENDIF FOR EACH loColumn IN .COLUMNS LOCAL loColumn FOR EACH loColumn IN this.Columns m.loColumn.CONTROLSOURCE = m.loColumn.cOriginalControlSource NEXT 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 *-- This method refreshes navigation buttons on the toolbar PROCEDURE refreshtoolbars *---------------------- Location Section ------------------------ * Library: Acustomcontrols.vcx * Class: Grdsorting * Method: Refreshtoolbars() *----------------------- Usage Section -------------------------- *) Description: *) * Scope: Public * Parameters: *$ Usage: *$ * Returns: *--------------------- Maintenance Section ---------------------- * Change Log: * CREATED 07/06/2005 - NN * MODIFIED *---------------------------------------------------------------- Local lcRecordSource, lcCondition With This lcRecordSource = .RecordSource If Vartype(Thisform.oToolbar) = "O" And ; lower(Thisform.cToolbar)='anavtoolbar' And ; type('thisform.oToolBar.cntNavButtons')='O' And ; thisform.oToolbar.cntNavButtons.Visible = .T. Thisform.lBOF = Bof(m.lcRecordSource) or RECCOUNT(m.lcRecordSource) = 0 Thisform.lEOF = Eof(m.lcRecordSource) lcCondition = "" Go Bottom In (m.lcRecordSource) If .nRecno = Recno(m.lcRecordSource) lcCondition = "EOF" Else Go Top In (m.lcRecordSource) If .nRecno = Recno(m.lcRecordSource) lcCondition = "BOF" Endif Endif If Between(.nRecno,1,Reccount(m.lcRecordSource)) Goto .nRecno In (m.lcRecordSource) Endif Thisform.oToolbar.cntNavButtons.Refresh(m.lcCondition, m.lcRecordSource) Endif Endwith 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, lnDirection, lnRelativeRow, lnI, lnJ *---------------------------------------------------------- *-- 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 THISFORM.LOCKSCREEN = .T. lnRecNo = RECNO(m.lcCursor) loSelect = CREATEOBJECT('CSelect', m.lcCursor) WITH THIS IF PCOUNT() < 2 OR EMPTY(m.tcTagName) OR TAGNO(m.tcTagName) = 0 tcTagName = .GetTagName(m.lcCursor, m.lcField) ENDIF ** Save current relative row lnRelativeRow = .RELATIVEROW *---------------------------------- *--- Determine ASCENDING/DESCENDING *---------------------------------- IF NOT EMPTY(m.tcTagName) IF NOT UPPER(m.tcTagName) == UPPER(.cTagName) *--- Default to ascending ---* .lAscending = .T. ELSE *--- Toggle ascending/descending ---* .lAscending = NOT .lAscending ENDIF *------------------------ *--- SET ORDER to the tag *------------------------ .cTagName = m.tcTagName lcAscDesc = IIF(.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. *--------------------------------------------------- .REFRESH() *-- CHANGE - NN - January 25, 2005 - 09:37:53 IF .lGoTopAfterSorting GO TOP IN (m.lcCursor) ELSE IF RECCOUNT(m.lcCursor) > 0 GOTO m.lnRecNo IN (m.lcCursor) ENDIF ENDIF .REFRESH() && again *-- CHANGE - NN - January 25, 2005 - 09:38:59 - added a new property IF .lUpdateToolbar *THISFORM.SetFilePos() && Note, that this code assumes existance of the SetFilePos method .RefreshToolbars() ENDIF ** Code from David Frankenbah IF ( m.lnRelativeRow != .RELATIVEROW ) * the record didn't wind up at the same grid row, so we scroll the grid lnDirection = IIF(m.lnRelativeRow > .RELATIVEROW, 0, 1 ) lnJ = ABS(m.lnRelativeRow - .RELATIVEROW ) FOR lnI = 1 TO lnJ .DOSCROLL( lnDirection ) ENDFOR * .REFRESH() && YAR ENDIF ENDIF ENDWITH THISFORM.LOCKSCREEN = .F. 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 m.loColumn.AddProperty("cOriginalControlSource",m.loColumn.ControlSource) 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 LOCAL lcRecordSource, lcCondition WITH THIS lcRecordSource = .RECORDSOURCE .nRecno = RECNO(m.lcRecordSource) IF .lManualHighlight IF INLIST(.ROWCOLCHANGE, 1, 3) && Row change .REFRESH() ENDIF ENDIF .RefreshToolbars() ENDWITH DODEFAULT(m.nColIndex) THISFORM.LOCKSCREEN = .F. ENDPROC ENDDEFINE * *-- EndDefine: grdsorting **************************************************
