Level Extreme platform
Subscription
Corporate profile
Products & Services
Support
Legal
Français
Subclassing headers
Message
General information
Forum:
Visual FoxPro
Category:
Classes - VCX
Miscellaneous
Thread ID:
00163637
Message ID:
00164317
Views:
28
Here is some code I use. Save it as _GrdSort.Prg. In the click event of the header eneter _GrdSort(This). You can programmatically add this to every header using the function AddSort below

* PROGRAM _grdsort.prg
* This Program will Sort a Grid, Using the specified Header ( Control Source )
* Date 1998/09/02
* Call this procedure from the Click event of a Grid Header
* Example 1 = _GrdSort(THIS)
* Example 2 = _GrdSort(THIS, .T., 30)
PARAMETER toHeader, tlAsk, tnMaxLen


IF TYPE("toHeader") <> "O"
WAIT WINDOW "Sorting of Data, Not Possible "
RETURN
ENDIF

IF tlAsk = .T.
lnCheck = MessageBox(toHeader.Caption, 17, "Sort by Column")
IF lnCheck <> 1
RETURN
ENDIF
ENDIF

tnMaxLen = IIF(EMPTY(tnMaxLen), 20, tnMaxLen)
lnRecNo = RecNo()
lcControlSource = toHeader.Parent.ControlSource

lnAT = AT(".", lcControlSource) && Extract Field Name from the Control Source
lcFieldName = IIF(lnAT >0, UPPER(SUBSTR(lcControlSource,lnAT+1)), lcFieldName = UPPER(lcControlSource))

** Checking for a suitable existing index in the CDX file
lnIndexNo = 0
FOR n =1 TO 254
lcIndex = UPPER(SYS(14,n)) && Index Expression
IF EMPTY(lcIndex)
EXIT
ENDIF
IF lcFieldName $ lcIndex
lnAT = AT(lcFieldName, lcIndex)
lnNextChar = lnAT+ LEN(lcFieldName) && Position of Next Character after lcFieldName
lcNextChar = IIF(lnNextChar < LEN(lcIndex), SUBSTR(lcIndex, lnNextChar), " ") && Next Character after lcFieldName
*lnNextAsc = ASC(lcNextChar)
IF NOT(ISDIGIT(lcNextChar) OR ISALPHA(lcNextChar) OR lcNextChar = "-") && Not a valid Field Character
lnIndexNo = n
EXIT
ENDIF
ENDIF
NEXT
IF lnIndexNo > 0
lcLast = RIGHT(ALLTRIM(toHeader.Caption),4)
lcPlainCaption = IIF(lcLast = " - v" OR lcLast = " - ^", LEFT(ALLTRIM(toHeader.Caption), LEN(ALLTRIM(toHeader.Caption))-4), ALLTRIM(toHeader.Caption))
lnColCount=toHeader.Parent.Parent.ColumnCount
FOR lnCount=1 TO lnColCount
lcText =toHeader.Parent.Parent.Columns(lnCount).Header1.Caption
IF RIGHT(ALLTRIM(lcText),4)=" - v" .OR. RIGHT(ALLTRIM(lcText),4)=" - ^"
toHeader.Parent.Parent.Columns(lnCount).Header1.Caption=LEFT(ALLTRIM(lcText),(LEN(ALLTRIM(lcText))-LEN(" - ^")))
ENDIF
NEXT
IF lnIndexNo = TagNo() && If Current TagNo is Same as the Field NAme Passed in the Order is set Automaticaly
IF "DESCENDING" $ SET("ORDER")
toHeader.Caption = lcPlainCaption + " - ^"
SET ORDER TO lnIndexNo ASCENDING
ELSE
toHeader.Caption = lcPlainCaption + " - v"
SET ORDER TO lnIndexNo DESCENDING
ENDIF
ELSE
toHeader.Caption = lcPlainCaption + " - ^"
SET ORDER TO lnIndexNo ASCENDING
ENDIF
DO GrdRefresh
RETURN
ENDIF
IF NOT(TYPE(lcControlSource) $ "CMDNIL")
WAIT WINDOW "Cannot Sort by a field of type " + TYPE(lcFieldName) TIMEOUT 5
RETURN
ENDIF

** Creating a new TAG in a Temporary File
fTmpCdx = IIF(EMPTY(CDX(2)), SYS(3) + ".Tmp" , CDX(2)) && CDX(2) returns any existing secondary CDX files open

IF TYPE(lcFieldName) = "C"
IF LEN(EVAL(lcFieldName)) > tnMaxLen
lcExpr = UPPER(LEFT(lcFieldName,tnMaxLen))
ELSE
lcExpr = UPPER(lcFieldName)
ENDIF
ELSE
lcExpr = lcFieldName
ENDIF
IF TYPE(lcFieldName) = "M"
lcExpr = UPPER(LEFT(lcFieldName,tnMaxLen))
ENDIF

lcTmpTag = "T" +SYS(3)
WAIT WINDOW "Sorting by " + lcFieldName NOWAIT
lcFilter = IIF(TagNo() > 0, SYS(2021, TagNo()), "") && Previous Indexed Filter expression
IF EMPTY(lcFilter)
INDEX ON &lcExpr TAG (lcTmpTag) OF (fTmpCdx) && Do not change to EVAL(lcExpr)
ELSE
INDEX ON &lcExpr TAG (lcTmpTag) OF (fTmpCdx) FOR &lcFilter
ENDIF
*SET STEP ON
DO GrdRefresh
WAIT CLEAR
RETURN

************************************************
PROCEDURE GrdRefresh
* To Refresh the Grid after Setting new Order
*GO TOP
toHeader.Parent.SetFocus
toHeader.Parent.Parent.Refresh
IF lnRecNo > 0 AND lnRecNo =< RecCount()
GO lnRecNo && To Force a Screen Refresh
ENDIF
toHeader.Parent.Parent.Refresh
RETURN

***************************************************************************
PROCEDURE AddSort
lnGrid = ASELOBJ(loGrid) && gives a handle to the Currently selected Object
IF lnGrid = 0 OR UPPER(loGrid(1).BaseClass) <> "GRID"
WAIT WINDOW "Please select a grid object " TIMEOUT 10
RETURN
ENDIF

WITH loGrid
lnColumnCount = .ColumnCount
FOR n = 1 TO lnColumnCount
.Columns(n).Header1.WriteMethod("Click", "_GrdSort(THIS)")
NEXT
ENDWITH
RETURN
Previous
Next
Reply
Map
View

Click here to load this message in the networking platform