************************************************** *-- Class: grdsorting (c:\mmviscollect\libs\acustomcontrols.vcx) *-- ParentClass: cgrid (c:\mmortals\common30\libs\ccontrls.vcx) *-- BaseClass: grid *-- Time Stamp: 05/03/06 11:52:13 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 AllowHeaderSizing = .F. AllowRowSizing = .F. 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. *-- Holds grid's column controlsources and sizes cgridscript = "" 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. *-- 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 *---------------------------------------------------------------- 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 local lnCount, lcIndexExpr, lnIndexes, lcTagName local array laIndex[1] *lnIndexes = AIndexes(@laIndex, m.tcCursor) lnIndexes = tagcount("",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 *---------------------------------------------------------------- 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(m.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 *-- This method binds controls to grid's methods PROCEDURE initialize *---------------------- Location Section ------------------------ * Library: Acustomcontrols.vcx * Class: Grdsorting * Method: Initialize() *----------------------- Usage Section -------------------------- *) Description: *) * Scope: Public * Parameters: *$ Usage: *$ * Returns: *--------------------- Maintenance Section ---------------------- * Change Log: * CREATED 04/05/2006 - NN * MODIFIED *---------------------------------------------------------------- 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 loColumn.addproperty("cOriginalControlSource", m.loColumn.controlsource) for each loControl in m.loColumn.controls if upper(m.loControl.baseclass) = "HEADER" bindevent(m.loControl,"Click",this,"HeaderClick") loControl.addproperty("CurrentTag","") && Adds CurrentTag property if this.lCreateIndexes && Adds indexes on the fly this.CreateTag (m.loControl) endif else if upper(m.loControl.baseclass) = "TEXTBOX" bindevent(m.loControl,"DblClick",this,"DblClick") endif endif endfor endfor if this.lManualHighlight local lcDynamicBackColor, lcDynamicForeColor lcDynamicBackColor = "iif(recno(this.RecordSource)=this.nRecno,this.HighlightBackColor,this.BackColor)" lcDynamicForeColor = "iif(recno(this.RecordSource)=this.nRecno,this.HighlightForeColor,this.ForeColor)" this.setall("DynamicBackColor", m.lcDynamicBackColor, "Column") this.setall("DynamicForeColor", m.lcDynamicForeColor, "Column") this.highlightstyle = 0 endif if this.lSaveGridProperties this.SaveGridProperties() endif 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 with this .nRecno = recno(this.RecordSource) DEBUGOUT 'AfterRowColChange' if .lManualHighlight if inlist(.rowcolchange, 1, 3) && Row change .refresh() endif endif .RefreshToolbars() endwith dodefault(m.nColIndex) thisform.lockscreen = .f. 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 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. ELSE this.Initialize() endif 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 * MODIFIED 02/01/2006 - NN *---------------------------------------------------------------- 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) if chrtran(m.lcCursor,"+()-","")<> m.lcCursor ** The controlsource is not a simple expression - can not order return endif * 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 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 ENDDEFINE * *-- EndDefine: grdsorting **************************************************
