******************************************************************** * 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,