Level Extreme platform
Subscription
Corporate profile
Products & Services
Support
Legal
Français
Creating indexes on the fly
Message
 
General information
Forum:
Visual FoxPro
Category:
Forms & Form designer
Miscellaneous
Thread ID:
00683034
Message ID:
00683079
Views:
41
Ok, disregard. I took code from Vlad G in his sorting grid sample. Works fine in few tests, I ran. Here is the code for myHeader class after incorporating Vlad's ideas:
********************************************************************
*  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
	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
					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
			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"
				m.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 contains 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 filder
* 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 everybody,
>
>I'm wondering about your opinion: Is it possible to create a general procedure for creating indexes on the fly? We would not know, what type of RecordSource is used for the grid.
>
>It could be:
>1) Updatablle cursor
>2) Buffered table
>3) Read-only cursor
>
>others...
>
>Just want to check it.
If it's not broken, fix it until it is.


My Blog
Previous
Reply
Map
View

Click here to load this message in the networking platform