Level Extreme platform
Subscription
Corporate profile
Products & Services
Support
Legal
Français
Click Grid control header to sorting the data in column
Message
 
General information
Forum:
Visual FoxPro
Category:
Coding, syntax & commands
Miscellaneous
Thread ID:
00708196
Message ID:
00709880
Views:
33
Hi Vincent,

I use the following Header class (it can automatically create necessary tag and it changes color depending on ascending/descending). The ideas and code borrowed from Sorting Grid Sample by Vlad Grynchyshyn. I liked my class better, because it's simpler:
********************************************************************
*  Description.......: myHeader.Definition
*  Calling Samples...:
*  Parameter List....: tcCaption
*  Ideas by..........: Cetin Basoz & David Frankenbach & Vlad Grynchyshyn
*  Modified by.......: Nadya Nosonovsky 07/26/2002 01:19:41 PM
********************************************************************
define class MyHeader as header
	mcArrowName = ""    && name of the arrow used for all headers of the grid
	mlAscending = .f.   && flag for sort order
	mlColumnMoved = .f. && flag indicating column was moved
	mnColumnOrder = 0   && original column order
	mlColumnSized = .f. && flag indicating column was resized
	mnColumnWidth = 0   && original size of column
	nOriginalForeColor = 0  && original ForeColor
	nCurForeColor = 0  && current ForeColor
	nForeColorAsc =  16711935 && Fore Color, when the column is in ASC order
	nForeColorDesc = 8388863   && Fore Color, when the column is in DESC order
	nNormalForeColor = 0 && Black
	nActiveColumnForeColor = 16777215 && White
	lNoActiveHighlight = .f. && If this property is set to true, ActiveColumn is not showing in white forecolor
	lSorted = .f. && Logical property, what this column was sorted
	cTagName = '' && Tag Name, which should be used for sorting, if not specified, use the column source instead

* Use this property to define index expression other than just sorting by control source field.
	SortingExpression = ""
* Sorting index tag currently used for sorting.
	hidden CurrentTag
	CurrentTag = ""
* following property used to indicate which method was used to index the
* alias - structural or non-structural index.
	hidden lNonStructural
	lNonStructural = .f.

	statusbartext = "" && Status Bar Text for the Header
	tooltiptext = "" && Tool Tip Text property for the Header
	
	lDontChangeOthers = .t. && Don't change other headers

	procedure init
	lparameters tcCaption
	local ix, lcProperty
	with this
		if vartype(m.tcCaption) # "C" ;
				or empty(m.tcCaption)
			tcCaption = .caption
		endif
		.caption = m.tcCaption
		.alignment = 2
		.nOriginalForeColor=.forecolor
		.nCurForeColor = .forecolor
		if !pemstatus(.parent.parent,"nCurOrderedColumnIndex",5)
			.parent.parent.addproperty("nCurOrderedColumnIndex",0)
		endif
		if !pemstatus(.parent.parent,"nCurActiveColumnIndex",5)
			.parent.parent.addproperty("nCurActiveColumnIndex",0)
		endif
	endwith
endproc

	procedure ForeColor_assign
	lparameters vNewVal
*To do: Modify this routine for the Assign method
	with this
		if m.vNewVal <> .forecolor && Color is supposed to change
			if inlist(m.vNewVal, .nForeColorAsc, .nForeColorDesc)
				.parent.parent.nCurOrderedColumnIndex=.GetColumnIndex()
			else
				.nCurForeColor= m.vNewVal
				.nOriginalForeColor = m.vNewVal
				.parent.parent.nCurActiveColumnIndex=.GetColumnIndex()
			endif
			.forecolor = m.vNewVal
		endif
	endwith


	procedure GetColumnIndex
	local lnI, lnIndex
	lnIndex=0
	with this.parent
		for lnI=1 to .parent.columncount
			if .parent.columns[m.lnI].columnorder=.columnorder
				lnIndex=m.lnI
				exit
			endif
		next
	endwith
	return m.lnIndex
endproc

	procedure Order_Highlight
	lparameter toColumn
	if vartype(toColumn)<>'O'
		local lnOldIndex, lnIndex, loColumn, lnActiveColumn
		lnActiveColumn = this.parent.parent.activecolumn
		for each loColumn in this.parent.parent.columns
			if type('loColumn.Header1.caption')='C' ;
					and pemstatus(loColumn.Header1,'nOriginalForeColor',5)
				if loColumn.columnorder <> m.lnActiveColumn or this.lNoActiveHighlight
					loColumn.Header1.forecolor = this.nNormalForeColor
				else		    
					loColumn.Header1.forecolor = this.nActiveColumnForeColor						
				endif
			endif
		next
	endif
*!*		lnOldIndex = this.parent.parent.nCurOrderedColumnIndex
*!*		with this.parent.parent
*!*			if m.lnOldIndex > 0
*!*			    wait window time 2 transform(m.lnOldIndex)
*!*				.columns[m.lnOldIndex].Header1.forecolor= ;
*!*					.columns[m.lnOldIndex].Header1.nOriginalForeColor
*!*			endif
*!*		endwith
	with this
		if descending()
			.forecolor = .nForeColorDesc && Red
		else
			.forecolor = .nForeColorAsc
		endif
	endwith
endproc

	procedure click
	local nTempCurRec, lcTagName

	with this
		if ! .mlColumnMoved and ! .mlColumnSized
* sortable column that was clicked
			.mlAscending = ! .mlAscending
			thisform.lockscreen = .t.
			lcTagName=iif(!empty(.cTagName),.cTagName,justext(.parent.controlsource))
			.cTagName = m.lcTagName
			select (.parent.parent.recordsource)
			
			if tagno(m.lcTagName)= 0
				.CreateTag()
			else
				.CurrentTag = m.lcTagName
			endif

			if not empty(.CurrentTag)
				nTempCurRec = recno(.parent.parent.recordsource)
				if .mlAscending
					set order to tag (.CurrentTag) ;
						in (.parent.parent.recordsource) ascending
				else
					set order to tag (.CurrentTag) ;
						in (.parent.parent.recordsource) descending
				endif
				.Order_Highlight() && Show color
				.parent.parent.refresh()
				
				if type('thisform.navstand.name')='C'
					thisform.navstand.lstOrders.refresh()
					thisform.navstand.navUpdate()
				endif
				
				if between(m.nTempCurRec,1,reccount(.parent.parent.recordsource))
					go m.nTempCurRec in (.parent.parent.recordsource)
				endif
			endif
			thisform.lockscreen = .f.
		endif
	endwith
endproc

	procedure destroy
	with this
		if !empty(.CurrentTag) and !(.CurrentTag == .cTagName) and .lNonStructural
&& clean up index
			local llValid, lnOldAlias
			llValid = .t.
			lnOldAlias = select(0)
			if used(.parent.parent.recordsource)
				select (.parent.parent.recordsource)
			else
				llValid = .f.
			endif
			
			if m.llValid
&& disable errors
				local lc___OldError
				private m.ll__Error
				ll__Error = .f.
				lc___OldError = on("ERROR")
				on error m.ll__Error = .t.

				delete tag (.CurrentTag)

				on error &lc___OldError
				release m.ll__Error
			endif

			if file(.CurrentTag + '.cdx')
				erase(.CurrentTag + '.cdx')
			endif
			.CurrentTag = ""

			select(m.lnOldAlias)
		endif
	endwith
endproc


	procedure CreateTag
* assuming alias for sorting is in current workarea
* assuming this method is called from the Sorting Manager code only from this class.

	with this
* calculate the expression for sorting
		local lc__SortExpr, lnLimitation
		lnLimitation = iif(set("Collate")=="MACHINE",240,120)
		if empty(.SortingExpression)
			lc__SortExpr = .parent.controlsource
* make basic checking for control source type
			local lcType, lnValLen, llIsField
			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
				
			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
		else
			lc__SortExpr = .SortingExpression
		endif

&& 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
			.lNonStructural = 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 .lNonStructural
					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
	endwith
endproc

	procedure mousemove && Mouse moves over control
	lparameters nButton, nShift, nXCoord, nYCoord
	with this
		set message to .statusbartext
&&evaluate('this.parent.parent.parent.shape'+this.parent.parent.name)
*	.parent.parent.tooltiptext = .ToolTipText
		.parent.parent.statusbartext = .statusbartext
*    .MouseDownToolTip(nButton, nShift, nXCoord, nYCoord)
*     .parent.parent.MouseMove(nButton, nShift, nXCoord, nYCoord)
*     mouse at mrow(), mcol()
*!*			endif
	endwith
endproc


	procedure mousedown
	lparameters nButton, nShift, nXCoord, nYCoord
	with this

* initialize items that will be tested in MouseUp
		.mnColumnOrder = this.parent.columnorder
		.mnColumnWidth = this.parent.width
	endwith
endproc

	procedure mouseup
	lparameters nButton, nShift, nXCoord, nYCoord

	with this
* check to see if this was a resize or move
		.mlColumnMoved = ( this.parent.columnorder != .mnColumnOrder )
		.mlColumnSized = ( this.parent.width != .mnColumnWidth )
	endwith
endproc

	procedure dblclick
	this.click()
*this.parent.parent.SetOrder(this.parent.controlsource)
endproc


	procedure dWordStringToNumber
	parameter tcDWord
	local lnReturn, lnI

	if (vartype(m.tcDWord) <> "C") or (len(m.tcDWord) < 4)
		return 0
	endif

	lnReturn = 0
	for lnI = 1 to 4
		lnReturn = asc( substr(m.tcDWord, 5-m.lnI, 1)) + m.lnReturn
		if lnI <> 4
			lnReturn = m.lnReturn * 256
		endif
	endfor
	return m.lnReturn
endproc


	procedure MouseDownToolTip
	lparameters nButton, nShift, nXCoord, nYCoord
* !!!! NOTE:
* The code below is used to forward mouse clicks from this control to the
* control below it. The code it copied from
* the source of the Fancy ToolTip control by Paul-Vlad Tatavu
* from the www.levelextreme.com site, downloads section.
* Fancy ToolTip control provided for free, as described in the Readme.TXT
* file in the download file.
	local lnMouseX, lnMouseY
	local lcPointStructure
	local lnFormHandle, lnTopParentHandle, lnHandle
	local lnPressedKeys
	local lnButtonDown, lnButtonUp, lnMKButton
	local lnWM_MOUSEACTIVATE, lnWM_SETCURSOR, lnWM_MOUSEMOVE, ;
		lnWM_LBUTTONDOWN, lnWM_RBUTTONDOWN, lnWM_MBUTTONDOWN, ;
		lnWM_LBUTTONUP, lnWM_RBUTTONUP, lnWM_MBUTTONUP, ;
		lnHTCLIENT, lnMK_LBUTTON, lnMK_RBUTTON, ;
		lnMK_MBUTTON, lnMK_SHIFT, lnMK_CONTROL

*-- Declare Win32 API functions
	declare integer GetCursorPos ;
		in Win32API ;
		as __GetCursorPos__ ;
		string @lcPointStructure
	declare integer WindowFromPoint ;
		in Win32API ;
		as __WindowFromPoint__ ;
		integer lnX, ;
		integer lnY
	declare integer GetParent ;
		in Win32API ;
		as __GetParent__ ;
		integer lnWindowHandle
	declare integer SendMessage ;
		in Win32API ;
		as __SendMessage__ ;
		integer lnWindowHandle, ;
		integer lnMessage, ;
		integer lnWParam, ;
		integer lnLParam
	declare integer PostMessage ;
		in Win32API ;
		as __PostMessage__ ;
		integer lnWindowHandle, ;
		integer lnMessage, ;
		integer lnWParam, ;
		integer lnLParam
	declare integer ScreenToClient ;
		in Win32API ;
		as __ScreenToClient__ ;
		integer lnWindowHandle, ;
		string @lcPointStructure

*-- Get the cursor position relative to screen
	lcPointStructure = replicate(chr(0), 8)
	= __GetCursorPos__(@lcPointStructure)

*-- Extract the mouse coordinates from
*   the structure returned by GetCursorPosition()
	lnMouseX = this.dWordStringToNumber(;
		left(lcPointStructure, 4))
	lnMouseY = this.dWordStringToNumber(;
		right(lcPointStructure, 4))

*-- Get a handle to the window under mouse
*   (a handle to the current form, in this case)
	lnFormHandle = __WindowFromPoint__(lnMouseX, lnMouseY)

*-- Get a handle to the desktop window
*   that is a (grand)parent of the current form
	lnHandle = lnFormHandle
	do while lnHandle != 0
		lnHandle = __GetParent__(lnHandle)
		if lnHandle != 0
			lnTopParentHandle = lnHandle
		endif
	enddo

*-- Declare constants used by mouse messages
	lnWM_MOUSEACTIVATE = 0x0021
	lnWM_SETCURSOR     = 0x0020
	lnWM_MOUSEMOVE     = 0x0200

	lnWM_LBUTTONDOWN   = 0x0201
	lnWM_RBUTTONDOWN   = 0x0204
	lnWM_MBUTTONDOWN   = 0x0207
	lnWM_LBUTTONUP     = 0x0202
	lnWM_RBUTTONUP     = 0x0205
	lnWM_MBUTTONUP     = 0x0208

	lnHTCLIENT         = 0x0001

	lnMK_LBUTTON       = 0x0001
	lnMK_RBUTTON       = 0x0002
	lnMK_MBUTTON       = 0x0010
	lnMK_SHIFT         = 0x0004
	lnMK_CONTROL       = 0x0008

	lnPressedKeys = 0
	if bitand(nShift, 1) = 1
*-- The Shift key was pressed when
*   mouse was clicked
		lnPressedKeys = bitor(lnPressedKeys, lnMK_SHIFT)
	endif
	if bitand(nShift, 2) = 2
*-- The Ctrl key was pressed when
*   mouse was clicked
		lnPressedKeys = bitor(lnPressedKeys, lnMK_CONTROL)
	endif

	do case
	case nButton = 0 && Nothing was pressed
		lnButtonDown = 0
		lnButtonUp   = 0
		lnMKButton   = 0

	case nButton = 1
*-- Left button
		lnButtonDown = lnWM_LBUTTONDOWN
		lnButtonUp   = lnWM_LBUTTONUP
		lnMKButton   = lnMK_LBUTTON
	case nButton = 2
*-- Right button
		lnButtonDown = lnWM_RBUTTONDOWN
		lnButtonUp   = lnWM_RBUTTONUP
		lnMKButton   = lnMK_RBUTTON
	case nButton = 4
*-- Middle button
		lnButtonDown = lnWM_MBUTTONDOWN
		lnButtonUp   = lnWM_MBUTTONUP
		lnMKButton   = lnMK_MBUTTON
	endcase

*-- Convert mouse coordinates from screen coordinates
*   to form's client area coordinates
	= __ScreenToClient__(lnFormHandle, @lcPointStructure)
	lnMouseX = this.dWordStringToNumber(;
		left(lcPointStructure, 4))
	lnMouseY = this.dWordStringToNumber(;
		right(lcPointStructure, 4))

*-- Simulate a mouse up message(s)
*   (Will be received by the behind control)
	lnLParam = lnMouseY * 256 * 256 + lnMouseX
	= __SendMessage__( ;
		lnFormHandle, ;
		lnButtonUp, ;
		lnMKButton + lnPressedKeys, ;
		lnLParam)
	lnLParam = lnWM_MOUSEMOVE * 256 * 256 + lnHTCLIENT
	= __SendMessage__( ;
		lnFormHandle, ;
		lnWM_SETCURSOR, ;
		lnFormHandle, ;
		lnLParam)
	lnLParam = lnMouseY * 256 * 256 + lnMouseX
	= __PostMessage__( ;
		lnFormHandle, ;
		lnWM_MOUSEMOVE, ;
		lnPressedKeys, ;
		lnLParam)

*-- Hide the control
*	this.visible = .f.
*-- Simulate a mouse down message(s)
*   (Will be received by the control under mouse)
	lnLParam = lnButtonDown * 256 * 256 + lnHTCLIENT
	= __SendMessage__( ;
		lnFormHandle, ;
		lnWM_MOUSEACTIVATE, ;
		lnTopParentHandle, ;
		lnLParam)
	= __SendMessage__( ;
		lnFormHandle, ;
		lnWM_SETCURSOR, ;
		lnFormHandle, ;
		lnLParam)
	lnLParam = lnMouseY * 256 * 256 + lnMouseX
	= __PostMessage__( ;
		lnFormHandle, ;
		lnButtonDown, ;
		lnMKButton, ;
		lnLParam)

*	this.visible = .t.
endproc

	procedure DispSortingMessage
	lparameters llShow
	if m.llShow
		wait window 'Sorting...' nowait noclear
	else
		wait clear
	endif
endproc

enddefine
>Hi Marcia,
>I had try out the coding but the data in the grid still no change after click the different of grid header with particular order. I had try to add in below code to let the grid repaint.
>
>Header's Click method:
>
>WITH This.Parent
> IF PEMSTATUS( .Parent, 'SetOrder', 5 )
> .Parent.SetOrder( JUSTEXT( .ControlSource ) )
> .refresh && add in by Vincent
> ENDIF
>ENDWITH
>
>But no effect!
>
>If I want to click the grid header first time the order will be ascending order and click second time the order will be descending order. Can I write the code like this:
>
>lnClick is public variable
>
>IF lnClick = 1 THEN
> SET ORDER TO ( tcTag ) ASCENDING
> lnClick = 2
>ELSE
> SET ORDER TO ( tcTag ) DESCENDING
> lnClick = 1
>ENDIF
>
>Pls help me again. Thank you very much.
If it's not broken, fix it until it is.


My Blog
Previous
Next
Reply
Map
View

Click here to load this message in the networking platform