*in init of grid
WITH This
LOCAL i, lcCaption, lnAlignment, llWordWrap
lcCaption = ""
FOR i = 1 TO .COLUMNCOUNT
IF TYPE('.columns(i).Header1')="O"
lcCaption = .Columns(i).header1.caption
lnAlignment = .Columns(i).header1.Alignment
llWordWrap = .Columns(i).header1.WordWrap
.columns(i).RemoveObject('Header1')
.Columns(i).NewObject('Header2','SortHeader',gcDefaultDir+"\code\cls_GridSortHeader.prg")
.Columns(i).header2.caption = lcCaption
.Columns(i).header2.alignment = lnAlignment
.Columns(i).header2.WordWrap = llWordWrap
ENDIF
ENDFOR
ENDWITH
* code to create the new sortheaderclass
DEFINE CLASS SortHeader AS Header
lSortAZ = .F.
cControlSource = ""
cGridAlias = ""
lTagA = .F.
lTagD = .F.
*******************************************************************************
Function Init
LOCAL lcControlSource
LOCAL lnLeftPar, lnRightPar,lnNumbers
lnNumbers = 0
WITH this
* in grids controlsource some like allt(transform(table.field)) might exist
* only consider value between inner brackets, if any
lcControlSource = .Parent.controlsource
lnNumbers = OCCURS('(', lcControlSource)
IF lnNumbers > 0
lnLeftPar = ATC('(', lcControlSource,lnNumbers)
lnRightPar = ATC( ')',lcControlSource,1)
lnLength = lnRightPar - lnLeftPar
lcControlSource = SUBSTR(lcControlSource,lnLeftPar+1, lnLength-1)
ENDIF
* .cControlSource = JUSTEXT(.Parent.controlsource)
* .cGridAlias = JUSTSTEM(.Parent.controlsource)
.cControlSource = JUSTEXT(lcControlSource)
.cGridAlias = JUSTSTEM(lcControlSource)
ENDWITH
********************************************************************************
Function Click
LOCAL lcControlSource, lcTagName, lnBuffermode, lnSourceType, ;
lnRecord, lcAlias, lnLastRecord, lnOldSelect, lcType
WITH this
lcControlSource = ""
lcTagName = ""
lnSourceType = 0
lcAlias = .cGridAlias
lnOldSelect = SELECT()
lcType = ""
SELECT &lcAlias
* table with no records need no sort
IF RECCOUNT() = 0
* reset alias
SELECT (lnOldSelect)
RETURN
ENDIF
* what alias are we dealing with? view or table ?
lnSourceType = CURSORGETPROP("SourceType",ALIAS())
lnBufferMode = CURSORGETPROP("Buffering")
lnRecord = RECNO()
* controlsource of column involved
lcControlSource = ALLTRIM(.cControlSource)
IF UPPER(.parent.CurrentControl) <> 'TEXT1'
SELECT (lnOldSelect)
RETURN
ENDIF
* veldtype
lcType = VARTYPE(EVALUATE(lcControlsource))
IF !.lSortAZ
lcTagName = LEFT(lcControlSource,9) + "A"
* a tag exists
IF .lTagA
SET ORDER TO TAG &lcTagname
ELSE
* create a tag but at first be aware of tablebuffering is active
DO CASE
* we are having a view; so tablebuffering has to set to 3
CASE lnSourceType = 1 AND (lnBuffermode = 1 OR lnBuffermode = 3 OR lnBuffermode = 5)
=CURSORsetPROP("buffering",3)
* for tables tablebuffering 1 is fine (no buffering)
CASE lnSourceType = 3 AND lnBuffermode <> 1
=CURSORsetPROP("buffering",3)
ENDCASE
* create index tag sort ascending
* workaround as C-field seems to fail for index if length is 254
IF lcType = 'C'
INDEX on LEFT(&lcControlSource,200) TAG &lcTagname ASCENDING
ELSE
INDEX on &lcControlSource TAG &lcTagname ASCENDING
ENDIF
* put buffering back to what is was before
=CURSORSETPROP("Buffering",lnBufferMode)
ENDIF
* .lTagA is telling about the existance of an expected tag
.lTagA = .T.
ELSE
* same comments in here, but now we want a descending sort
lcTagName = LEFT(lcControlSource,9) + "D"
IF .lTagD
SET ORDER TO TAG &lcTagname
ELSE
DO CASE
CASE lnSourceType = 1 AND (lnBuffermode = 3 OR lnBuffermode = 5)
=CURSORsetPROP("buffering",3)
CASE lnSourceType = 3 AND lnBuffermode <> 1
=CURSORsetPROP("buffering",3)
ENDCASE
IF lcType = 'C'
INDEX on LEFT(&lcControlSource,200) TAG &lcTagname DESCENDING
ELSE
INDEX on &lcControlSource TAG &lcTagname DESCENDING
ENDIF
=CURSORSETPROP("Buffering",lnBufferMode)
ENDIF
.lTagD = .T.
ENDIF
*SET STEP ON
* cycle through all columns and reset header-backcolor; also remove any pictures
FOR i = 1 TO .parent.parent.columncount
.parent.parent.columns(i).header2.backcolor = thisform.backcolor
.parent.parent.columns(i).header2.picture = ""
ENDFOR
* give the header you clicked-on a different color and put a graphic on it showing sortdirection
.backcolor = RGB(128,128,128)
* .backcolor = RGB(255,0,0)
.picture = IIF(.lSortAZ,"arrowup.bmp","arrowdown.bmp")
* toggle sortdirection
.lSortAZ = !.lSortAZ
* refresh the grid
.Parent.parent.refresh()
IF lnRecord > 0
*
IF this.Parent.Parent.lKeepCurrentRecord && this.parent.parent = the grid
GO lnRecord
ELSE
GO top
ENDIF
ENDIF
* reset alias
SELECT (lnOldSelect)
ENDWITH
ENDDEFINE
***************************************************************************
* eof