Tweet
' Grid control with adjustable column and row headers and many facilities
'
' Please make your comments here:
' http://www.powerbasic.com/support/pb...045#post272045
'
' This is a custom drawn grid control with no structural limits to
' the number of rows and columns. Only the available memory may
' impose a limit in this respect. The data are held in a one-
' dimensional string array, which is manipulated using the extremely
' fast built-in string functions provided by PowerBasic. This results
' in a fast and effective program operation.
'
' Column width and row height can be adjusted: Place the mouse on a
' column or row divider: the mouse pointer changes to a sizing
' pointer; then you can drag the divider to increase or decrease
' column width or row height.
'
' The grid is quite versatile and can be set up for your specific
' purposes: For display only: set DisplayOnlyFlagGlobal to one. To
' display also a cell cursor: set DisplayOnlyFlagGlobal to zero.
' To provide editing and other facilities: set MenuFlagGlobal to
' one. This enables display of a shortcut menu using the right mouse
' button.
'
' Using the shortcut menu you can perform a number of additional tasks:
' 1) Columns or rows can be added to the grid.
'
' 2) Extended selection of cells can be enabled/disabled. F8 does
' the same. When enabled the current cursor cell position defines a
' corner of the selection rectangle. A left mouse button click or
' the position after keyboard scrolling defines the opposite corner
' of the selection rectangle.
'
' The selected cells can be 3) cleared. They can also be 4) copied
' and then 5) pasted into another place of the grid. The latest
' clear or paste action can be undone.
'
' The number of columns/rows spanned by the selection rectangle
' defines the number of columns/rows that may be 6) inserted or 7)
' deleted. The latest column/row deletion action may be undone.
'
' The rows of the grid can be 8) sorted according to the column
' variable marked by the cell cursor. The data can be sorted
' alphabetic or numeric and ascending or descending. The latest sort
' can be undone to obtain the prior sequence of rows.
'
' 9) Cell writing can be enabled/disabled. When enabled the
' characters will be displayed in the cursor cell as you enter them
' like in EXCEL. The new text can be cancelled using ESC unless you
' have moved to a new cell. Using F2 a cell text can be edited.
'
' 10) Editing of headers may be enabled/disabled. When enabled text
' can be edited by clicking the header.
'
' This Code is Public Domain. Best of luck with it.
'
' Best regards.
'
' Erik Christensen -------------- December 29, 2007
'
' Please make your comments here:
' http://www.powerbasic.com/support/pb...045#post272045
'
' This is a custom drawn grid control with no structural limits to
' the number of rows and columns. Only the available memory may
' impose a limit in this respect. The data are held in a one-
' dimensional string array, which is manipulated using the extremely
' fast built-in string functions provided by PowerBasic. This results
' in a fast and effective program operation.
'
' Column width and row height can be adjusted: Place the mouse on a
' column or row divider: the mouse pointer changes to a sizing
' pointer; then you can drag the divider to increase or decrease
' column width or row height.
'
' The grid is quite versatile and can be set up for your specific
' purposes: For display only: set DisplayOnlyFlagGlobal to one. To
' display also a cell cursor: set DisplayOnlyFlagGlobal to zero.
' To provide editing and other facilities: set MenuFlagGlobal to
' one. This enables display of a shortcut menu using the right mouse
' button.
'
' Using the shortcut menu you can perform a number of additional tasks:
' 1) Columns or rows can be added to the grid.
'
' 2) Extended selection of cells can be enabled/disabled. F8 does
' the same. When enabled the current cursor cell position defines a
' corner of the selection rectangle. A left mouse button click or
' the position after keyboard scrolling defines the opposite corner
' of the selection rectangle.
'
' The selected cells can be 3) cleared. They can also be 4) copied
' and then 5) pasted into another place of the grid. The latest
' clear or paste action can be undone.
'
' The number of columns/rows spanned by the selection rectangle
' defines the number of columns/rows that may be 6) inserted or 7)
' deleted. The latest column/row deletion action may be undone.
'
' The rows of the grid can be 8) sorted according to the column
' variable marked by the cell cursor. The data can be sorted
' alphabetic or numeric and ascending or descending. The latest sort
' can be undone to obtain the prior sequence of rows.
'
' 9) Cell writing can be enabled/disabled. When enabled the
' characters will be displayed in the cursor cell as you enter them
' like in EXCEL. The new text can be cancelled using ESC unless you
' have moved to a new cell. Using F2 a cell text can be edited.
'
' 10) Editing of headers may be enabled/disabled. When enabled text
' can be edited by clicking the header.
'
' This Code is Public Domain. Best of luck with it.
'
' Best regards.
'
' Erik Christensen -------------- December 29, 2007
Code:
' Grid control with adjustable column and row headers and many facilities
'
' Please make your comments here:
' [url]http://www.powerbasic.com/support/pbforums/showthread.php?p=272045#post272045[/url]
'
' This is a custom drawn grid control with no structural limits to
' the number of rows and columns. Only the available memory may
' impose a limit in this respect. The data are held in a one-
' dimensional string array, which is manipulated using the extremely
' fast built-in string functions provided by PowerBasic. This results
' in a fast and effective program operation.
'
' Column width and row height can be adjusted: Place the mouse on a
' column or row divider: the mouse pointer changes to a sizing
' pointer; then you can drag the divider to increase or decrease
' column width or row height.
'
' The grid is quite versatile and can be set up for your specific
' purposes: For display only: set DisplayOnlyFlagGlobal to one. To
' display also a cell cursor: set DisplayOnlyFlagGlobal to zero.
' To provide editing and other facilities: set MenuFlagGlobal to
' one. This enables display of a shortcut menu using the right mouse
' button.
'
' Using the shortcut menu you can perform a number of additional tasks:
' 1) Columns or rows can be added to the grid.
'
' 2) Extended selection of cells can be enabled/disabled. F8 does
' the same. When enabled the current cursor cell position defines a
' corner of the selection rectangle. A left mouse button click or
' the position after keyboard scrolling defines the opposite corner
' of the selection rectangle.
'
' The selected cells can be 3) cleared. They can also be 4) copied
' and then 5) pasted into another place of the grid. The latest
' clear or paste action can be undone.
'
' The number of columns/rows spanned by the selection rectangle
' defines the number of columns/rows that may be 6) inserted or 7)
' deleted. The latest column/row deletion action may be undone.
'
' The rows of the grid can be 8) sorted according to the column
' variable marked by the cell cursor. The data can be sorted
' alphabetic or numeric and ascending or descending. The latest sort
' can be undone to obtain the prior sequence of rows.
'
' 9) Cell writing can be enabled/disabled. When enabled the
' characters will be displayed in the cursor cell as you enter them
' like in EXCEL. The new text can be cancelled using ESC unless you
' have moved to a new cell. Using F2 a cell text can be edited.
'
' 10) Editing of headers may be enabled/disabled. When enabled text
' can be edited by clicking the header.
'
' This Code is Public Domain. Best of luck with it.
'
' Best regards.
'
' Erik Christensen -------------- December 29, 2007
#COMPILE EXE
#REGISTER NONE
#DIM ALL
#INCLUDE "WIN32API.INC"
#INCLUDE "COMDLG32.INC"
'******************************************************************************
'** Start of a potential ECGrid Include File **********************************
'******************************************************************************
%FORM1_GRID = 1350
%FORM1_STATIC = 1370
%ID_EDITCHILD = 1410
'
GLOBAL hGridGlobal AS LONG ' Handle of grid control
GLOBAL RowsGlobal AS LONG ' Total number of rows in array
GLOBAL ColumnsGlobal AS LONG ' Total number of columns in array
GLOBAL DataRowsGlobal() AS STRING ' Total data set is held here
GLOBAL hEditGlobal& ' Handle of edit control in grid
'
GLOBAL gOldSubClassEditGlobal AS LONG
GLOBAL SelectStartColGlobal AS LONG
GLOBAL SelectStartRowGlobal AS LONG
GLOBAL SelectEndRowGlobal AS LONG
GLOBAL SelectEndColGlobal AS LONG
GLOBAL AnchorGlobal AS LONG
'
GLOBAL VScrollNotifyGlobal AS WORD
GLOBAL HScrollNotifyGlobal AS WORD
GLOBAL EditFlagGlobal AS LONG
GLOBAL CorrectFlagGlobal AS LONG
GLOBAL HeadEditFlagGlobal AS LONG
GLOBAL RowHeaderEditFlagGlobal AS LONG
GLOBAL HeadColGlobal AS LONG
GLOBAL EditRowGlobal AS LONG
GLOBAL hFontGlobal AS LONG
GLOBAL hStaticGlobal AS LONG
'
GLOBAL MenuFlagGlobal AS LONG
'
GLOBAL DisplayOnlyFlagGlobal AS LONG
'
FUNCTION InsertTextFields(BYVAL TextLine AS STRING, BYVAL NewFields AS STRING, BYVAL IndxStart AS LONG, BYVAL Separator AS STRING) AS STRING
LOCAL Pos1 AS LONG, I AS LONG
I = PARSECOUNT(TextLine, Separator)
' check parameters: if invalid then exit without making any change
IF IndxStart > I OR IndxStart < 1 OR LEN(separator)<>1 THEN FUNCTION = TextLine : EXIT FUNCTION
FOR I = 2 TO IndxStart : INCR Pos1 : Pos1 = INSTR(Pos1, TextLine, Separator) : NEXT
INCR Pos1 : FUNCTION = STRINSERT$(TextLine, NewFields + Separator, Pos1)
END FUNCTION
'
FUNCTION ReplaceFields(BYVAL TextLine AS STRING, BYVAL NewFields AS STRING, BYVAL IndxStart AS LONG, BYVAL Separator AS STRING) AS STRING
LOCAL Pos1 AS LONG, Pos2 AS LONG, I AS LONG, J AS LONG
J = PARSECOUNT(NewFields, Separator) : I = PARSECOUNT(TextLine, Separator)
' check parameters: if invalid then exit without making any change
IF J > I - IndxStart + 1 OR IndxStart < 1 OR LEN(separator)<>1 THEN FUNCTION = TextLine : EXIT FUNCTION ' Invalid parameters: make no change
FOR I = 2 TO IndxStart : INCR Pos1 : Pos1 = INSTR(Pos1, TextLine, Separator) : NEXT
Pos2 = Pos1 : INCR Pos1
FOR I = 1 TO J : INCR Pos2 : Pos2 = INSTR(Pos2, TextLine, Separator) : NEXT
IF ISFALSE Pos2 THEN Pos2 = LEN(TextLine) + 1 ' position at end of line
FUNCTION = STRINSERT$(STRDELETE$(TextLine, Pos1, Pos2 - Pos1), NewFields, Pos1)
END FUNCTION
'
FUNCTION InsertEmptyFields(BYVAL TextLine AS STRING, BYVAL IndxStart AS LONG, BYVAL EmptyFields AS LONG, BYVAL Separator AS STRING) AS STRING
LOCAL Pos1 AS LONG, Pos2 AS LONG, I AS LONG
I = PARSECOUNT(TextLine, Separator)
' check parameters: if invalid then exit without making any change
IF IndxStart > I OR IndxStart < 1 OR EmptyFields < 1 OR LEN(separator)<>1 THEN FUNCTION = TextLine : EXIT FUNCTION
FOR I = 2 TO IndxStart : INCR Pos1 : Pos1 = INSTR(Pos1, TextLine, Separator) : NEXT
INCR Pos1 : FUNCTION = STRINSERT$(TextLine, STRING$(EmptyFields, Separator), Pos1)
END FUNCTION
'
FUNCTION DeleteFields(BYVAL TextLine AS STRING, BYVAL IndxStart AS LONG, BYVAL IndxEnd AS LONG, BYVAL Separator AS STRING) AS STRING
LOCAL Pos1 AS LONG, Pos2 AS LONG, I AS LONG
I = PARSECOUNT(TextLine, Separator)
' check parameters: if invalid then exit without making any change
IF IndxStart > I OR IndxEnd < IndxStart OR IndxEnd > I OR IndxEnd < 1 OR IndxStart < 1 OR LEN(separator)<>1 THEN FUNCTION = TextLine : EXIT FUNCTION
FOR I = 2 TO IndxStart : INCR Pos1 : Pos1 = INSTR(Pos1, TextLine, Separator) : NEXT
Pos2 = Pos1 : INCR pos1
FOR I = 0 TO IndxEnd - IndxStart : INCR Pos2 : Pos2 = INSTR(Pos2, TextLine, Separator) : NEXT
IF ISFALSE Pos2 THEN DECR Pos1 : Pos2 = LEN(TextLine) + 1 ' position at end of line
FUNCTION = STRDELETE$(TextLine, Pos1, Pos2 - Pos1 + 1)
END FUNCTION
'
FUNCTION DeleteAndGetDeletedFields(BYREF TextLine AS STRING, BYVAL IndxStart AS LONG, BYVAL IndxEnd AS LONG, BYVAL Separator AS STRING) AS STRING
LOCAL Pos1 AS LONG, Pos2 AS LONG, I AS LONG, fl AS LONG
I = PARSECOUNT(TextLine, Separator)
' check parameters: if invalid then exit without making any change
IF IndxStart > I OR IndxEnd < IndxStart OR IndxEnd > I OR IndxEnd < 1 OR IndxStart < 1 OR LEN(separator)<>1 THEN FUNCTION = TextLine : EXIT FUNCTION
FOR I = 2 TO IndxStart : INCR Pos1 : Pos1 = INSTR(Pos1, TextLine, Separator) : NEXT
Pos2 = Pos1 : INCR pos1
FOR I = 0 TO IndxEnd - IndxStart : INCR Pos2 : Pos2 = INSTR(Pos2, TextLine, Separator) : NEXT
IF ISFALSE Pos2 THEN Pos2 = LEN(TextLine) + 1 : fl = 1 ' position at end of line
FUNCTION = MID$(TextLine, Pos1, Pos2 - Pos1) ' Now holds fields to be deleted
IF ISTRUE fl THEN DECR Pos1 ' Last field included, then also delete separator preceding the deleted fields
TextLine = STRDELETE$(TextLine, Pos1, Pos2 - Pos1 + 1) ' Delete fields from main string
END FUNCTION
'
FUNCTION GetFields(BYVAL TextLine AS STRING, BYVAL IndxStart AS LONG, BYVAL IndxEnd AS LONG, BYVAL Separator AS STRING) AS STRING
LOCAL Pos1 AS LONG, Pos2 AS LONG, I AS LONG
I = PARSECOUNT(TextLine, Separator)
' check parameters: if invalid then exit without making any change
IF IndxStart > I OR IndxEnd < IndxStart OR IndxEnd > I OR IndxEnd < 1 OR IndxStart < 1 OR LEN(separator)<>1 THEN FUNCTION = TextLine : EXIT FUNCTION
FOR I = 2 TO IndxStart : INCR Pos1 : Pos1 = INSTR(Pos1, TextLine, Separator) : NEXT
Pos2 = Pos1 : INCR Pos1
FOR I = 0 TO IndxEnd - IndxStart : INCR Pos2 : Pos2 = INSTR(Pos2, TextLine, Separator) : NEXT
IF ISFALSE Pos2 THEN Pos2 = LEN(TextLine)+1 ' position at end of line
FUNCTION = MID$(TextLine, Pos1, Pos2 - Pos1)
END FUNCTION
'
FUNCTION ClearSelection(BYREF UndoLatest2() AS STRING, BYREF UndoFlag2 AS LONG, BYREF UndoXstart2 AS LONG, _
BYVAL xMin AS LONG, BYVAL xMax AS LONG, BYVAL yMin AS LONG, BYVAL yMax AS LONG) AS LONG
MOUSEPTR 11
LOCAL j AS LONG
REDIM UndoLatest2(yMin TO yMax) : UndoXstart2 = xMin + 1
FOR j = yMin TO yMax
UndoLatest2(j) = GetFields(DataRowsGlobal(j), xMin + 1 , xMax + 1, $TAB)
' replace fields with blank fields
DataRowsGlobal(j) = ReplaceFields(DataRowsGlobal(j), STRING$(xMax - xMin, $TAB), xMin + 1, $TAB)
NEXT
MOUSEPTR 1
UndoFlag2 = 1
FUNCTION = 1
END FUNCTION
'
FUNCTION SelectionToClipboard(BYVAL xMin AS LONG, BYVAL xMax AS LONG, _
BYVAL yMin AS LONG, BYVAL yMax AS LONG) AS LONG
MOUSEPTR 11
LOCAL i AS LONG, j AS LONG
LOCAL S AS STRING
FOR j = yMin TO yMax
S = S + GetFields(DataRowsGlobal(j), xMin + 1 , xMax + 1, $TAB) + $CRLF
NEXT
LOCAL hGlob AS LONG
LOCAL hData AS LONG
' Create a global memory object and copy the data into it
hData = GlobalAlloc(%GMEM_MOVEABLE OR %GMEM_DDESHARE, BYVAL LEN(S)+1)
MOUSEPTR 1
IF ISFALSE hData THEN EXIT FUNCTION
hGlob = GlobalLock(hData)
IF ISFALSE hGlob THEN EXIT FUNCTION
MoveMemory BYVAL hGlob, BYVAL STRPTR(S), BYVAL LEN(S)+1
GlobalUnlock hData
' Open the clipboard
IF ISFALSE(OpenClipboard(%NULL)) THEN GlobalFree hData : EXIT FUNCTION
' Paste the data onto the clipboard
IF ISFALSE(EmptyClipboard) THEN EXIT FUNCTION
IF ISFALSE(SetClipboardData(%CF_TEXT, hData)) THEN EXIT FUNCTION
IF ISFALSE(CloseClipboard) THEN EXIT FUNCTION
FUNCTION = 1
END FUNCTION
'
FUNCTION TextFromClipboard(Txt AS STRING) AS LONG
LOCAL hData AS ASCIIZ PTR
IF OpenClipboard(%NULL) = 0 THEN EXIT FUNCTION
hData = GetClipboardData (%CF_TEXT)
CloseClipboard
Txt = @hData
FUNCTION = 1
END FUNCTION
'
FUNCTION ClipboardToGrid(BYREF UndoLatest() AS STRING, BYREF UndoFlag AS LONG, BYREF UndoXstart AS LONG, _
BYVAL xPos AS LONG, BYVAL yPos AS LONG, _
BYREF xE AS LONG,BYREF yE AS LONG) AS LONG
LOCAL Buffer AS STRING, st AS STRING
LOCAL LINES1 AS LONG, Tabs AS LONG
LOCAL l AS LONG, t AS LONG, InComplFlg AS LONG
IF TextFromClipboard(Buffer) = 0 THEN FUNCTION = 0 : EXIT FUNCTION
MOUSEPTR 11
LINES1 = PARSECOUNT(Buffer, $CRLF) - 1
Tabs = PARSECOUNT(PARSE$(Buffer,$CRLF,1), $TAB)
xE = MIN(xPos+Tabs-1,ColumnsGlobal) : yE = MIN(yPos+LINES1-1,RowsGlobal)
'
REDIM UndoLatest(yPos TO yE) : UndoXstart = xPos + 1
' Check if paste goes beyond grid limits: If so, set appropriate flag.
IF xPos + Tabs - 1 > ColumnsGlobal OR yPos + Lines1 - 1 > RowsGlobal THEN InComplFlg = 1
FOR l = yPos TO yE
UndoLatest(l) = GetFields(DataRowsGlobal(l), UndoXstart, xE + 1, $TAB)
st = PARSE$(Buffer,$CRLF,l - yPos + 1)
st = GetFields(st, 1, xE - xPos + 1, $TAB) ' Get new string to fit within grid limits
DataRowsGlobal(l) = ReplaceFields(DataRowsGlobal(l), st, xPos + 1, $TAB)
NEXT
MOUSEPTR 1
UndoFlag = 1
FUNCTION = 1
IF InComplFlg = 1 THEN FUNCTION = 2
END FUNCTION
'
FUNCTION UndoLatestPasteOrClear(BYREF UndoLatest() AS STRING, BYREF UndoFlag AS LONG, BYVAL UndoXstart AS LONG, _
BYREF A AS LONG,BYREF B AS LONG,BYREF C AS LONG,BYREF D AS LONG) AS LONG
' SelectStartColGlobal, SelectStartRowGlobal, SelectEndColGlobal, SelectEndRowGlobal
LOCAL i AS LONG, j AS LONG
MOUSEPTR 11
B = LBOUND(UndoLatest) : D = UBOUND(UndoLatest)
A = UndoXstart - 1
C = A + PARSECOUNT(UndoLatest(B), $TAB) - 1
FOR j = B TO D
' Restore data prior to latest paste or clear
DataRowsGlobal(j) = ReplaceFields(DataRowsGlobal(j), UndoLatest(j), UndoXstart, $TAB)
NEXT
MOUSEPTR 1
UndoFlag = 0
FUNCTION = 1
END FUNCTION
'
SUB PBTagarraySort(BYREF CS() AS STRING, BYVAL Rlow AS LONG, BYVAL Rhigh AS LONG, _
BYVAL Col AS LONG, BYVAL SortType AS LONG, BYREF indx() AS LONG, BYREF newHigh AS LONG)
MOUSEPTR 11
REGISTER i AS LONG
INCR Col ' necessary for the parse function since the array starts with column zero
'
' find upper limit of non-blank data in upper end of array (avoid including "outside" upper blank data in the sorting)
DO WHILE TRIM$(PARSE$(CS(Rhigh), $TAB, Col)) = "" AND Rhigh > 1
DECR Rhigh
LOOP
'
newHigh = Rhigh
IF Rhigh <= Rlow + 1 THEN MOUSEPTR 1 : EXIT SUB
'
IF SortType = 1 OR SortType = 2 THEN ' Character or Alphabetical or String sorting
DIM VarCopy(0 TO Rhigh) AS LOCAL STRING ' extra working space
DIM cop(0 TO Rhigh) AS LOCAL STRING ' copy
FOR i = Rlow TO Rhigh
VarCopy(i) = PARSE$(CS(i), $TAB, Col) : cop(i) = VarCopy(i)
indx(i) = i
NEXT
IF SortType = 1 THEN ' ascending sorting (default)
ARRAY SORT cop(1) FOR Rhigh, TAGARRAY indx()
ARRAY SORT VarCopy(1) FOR Rhigh, TAGARRAY CS()
ELSE ' descending sorting
ARRAY SORT cop(1) FOR Rhigh, TAGARRAY indx(), DESCEND
ARRAY SORT VarCopy(1) FOR Rhigh, TAGARRAY CS(), DESCEND
END IF
ERASE VarCopy(), cop()
'
ELSEIF SortType = 3 OR SortType = 4 THEN ' Numerical sorting
DIM VarCopyNum(0 TO Rhigh) AS LOCAL SINGLE ' extra working space
DIM copnum(0 TO Rhigh) AS LOCAL SINGLE ' copy
FOR i = Rlow TO Rhigh
VarCopyNum(i) = VAL(PARSE$(CS(i), $TAB, Col)) : copnum(i) = VarCopyNum(i)
indx(i) = i
NEXT
IF SortType = 3 THEN ' ascending sorting (default)
ARRAY SORT copnum(1) FOR Rhigh, TAGARRAY indx()
ARRAY SORT VarCopyNum(1) FOR Rhigh, TAGARRAY CS()
ELSE ' descending sorting
ARRAY SORT copnum(1) FOR Rhigh, TAGARRAY indx(), DESCEND
ARRAY SORT VarCopyNum(1) FOR Rhigh, TAGARRAY CS(), DESCEND
END IF
ERASE VarCopyNum(), copnum()
END IF
MOUSEPTR 1
END SUB
'
FUNCTION MakeFont(BYVAL FontHeight AS LONG,BYVAL FontWeight AS LONG, _
BYVAL Italic AS LONG, BYVAL Underline AS LONG,BYVAL StrikeOut AS LONG, _
BYVAL FaceName AS STRING) AS LONG
LOCAL lfFont AS LOGFONT
lfFont.lfHeight = FontHeight ' DEFINE FONT HEIGHT DIRECTLY IN PIXELS
lfFont.lfWidth = 0 ' logical average character width
lfFont.lfEscapement = 0 ' angle of escapement
lfFont.lfOrientation = 0 ' base-line orientation angle
lfFont.lfWeight = FontWeight ' font weight
lfFont.lfItalic = Italic ' italic attribute flag (0,1)
lfFont.lfUnderline = Underline ' underline attribute flag (0,1)
lfFont.lfStrikeOut = StrikeOut ' strikeout attribute flag (0,1)
lfFont.lfCharSet = %ANSI_CHARSET ' character set identifier
lfFont.lfOutPrecision = %OUT_TT_PRECIS ' output precision
lfFont.lfClipPrecision = %CLIP_DEFAULT_PRECIS ' clipping precision
lfFont.lfQuality = %DEFAULT_QUALITY ' output quality
lfFont.lfPitchAndFamily = %FF_DONTCARE ' pitch and family
lfFont.lfFaceName = FaceName ' typeface name string
FUNCTION = CreateFontIndirect (lfFont)
END FUNCTION
'
FUNCTION InitHeaderGridCtrl() AS LONG
LOCAL wc AS WNDCLASS
LOCAL szClassName AS ASCIIZ * 11
szClassName = "ECGRID"
wc.style = %CS_HREDRAW OR %CS_VREDRAW OR %CS_DBLCLKS OR %CS_GLOBALCLASS
wc.lpfnWndProc = CODEPTR(GridCallBack)
wc.cbClsExtra = 0
wc.cbWndExtra = 0
wc.hInstance = GetModuleHandle(BYVAL %NULL)
wc.hIcon = %NULL
wc.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wc.hbrBackground = GetStockObject(%WHITE_BRUSH)
wc.lpszMenuName = %NULL
wc.lpszClassName = VARPTR(szClassName)
FUNCTION = RegisterClass(wc)
END FUNCTION
'
FUNCTION PageDim(BYVAL StartingPoint AS LONG, BYREF Arr() AS LONG, BYVAL PixelsOfPage AS LONG, BYVAL Direction AS LONG) AS LONG
LOCAL Sum AS LONG, Position AS LONG, flag1 AS LONG
PixelsOfPage = PixelsOfPage - Arr(LBOUND(Arr)) ' always subtract header height or row width (at LBOUND) from PixelsOfPage
Position = StartingPoint : Sum = Arr(Position)
IF Direction = 1 THEN ' up or left
flag1 = 0
DO
IF Position <= LBOUND(Arr) + 1 THEN flag1 = 1 : EXIT DO ' if bound of array reached then set flag and exit do
IF Sum + Arr(Position - 1) > PixelsOfPage THEN EXIT DO ' if addition of next item leads to Sum > PixelsOfPage then exit do
DECR Position : Sum = Sum + Arr(Position) ' else decrease pos and add item to Sum
LOOP
IF flag1 = 1 THEN ' lower bound reached: then start from below and move upwards
StartingPoint = LBOUND(Arr) + 1 : Position = StartingPoint : Sum = Arr(Position)
DO
IF Position >= UBOUND(Arr) THEN EXIT DO ' if bound of array reached then exit do
IF Sum + Arr(Position + 1) > PixelsOfPage THEN EXIT DO ' if addition of next item leads to Sum > PixelsOfPage then exit do
INCR Position : Sum = Sum + Arr(Position) ' else increase pos and add item to Sum
LOOP
END IF
'
ELSEIF Direction = 2 THEN ' down or right
flag1 = 0
DO
IF Position >= UBOUND(Arr) THEN flag1 = 1 : EXIT DO ' if bound of array reached then set flag and exit do
IF Sum + Arr(Position + 1) > PixelsOfPage THEN EXIT DO ' if addition of next item leads to Sum > PixelsOfPage then exit do
INCR Position : Sum = Sum + Arr(Position) ' else increase pos and add item to Sum
LOOP
IF flag1 = 1 THEN ' upper bound reached: then start from above and move downwards
StartingPoint = UBOUND(Arr) : Position = StartingPoint : Sum = Arr(Position)
DO
IF Position <= LBOUND(Arr) + 1 THEN EXIT DO ' if bound of array reached then exit do
IF Sum + Arr(Position - 1) > PixelsOfPage THEN EXIT DO ' if addition of next item leads to Sum > PixelsOfPage then exit do
DECR Position : Sum = Sum + Arr(Position) ' else decrease pos and add item to Sum
LOOP
END IF
END IF
FUNCTION = ABS(Position - StartingPoint) + 1
END FUNCTION
'
FUNCTION ArIndx(BYVAL i AS LONG, BYVAL posi AS LONG) AS LONG ' gives the correct index of data in array
IF i = 0 THEN FUNCTION = 0 : EXIT FUNCTION ' header column or rowr
IF i > 0 THEN FUNCTION = i - 1 + posi ' cell in grid: dependent on scroll position
END FUNCTION
'
CALLBACK FUNCTION GridCallBack
' Callback Handle CBHNDL is: hGridGlobal&
STATIC hCtr&,Res&,s AS ASCIIZ * 250
STATIC MinWidth AS LONG, MinHeight AS LONG
LOCAL rc AS RECT ,i&,j&,hdc&,k&,chrs&,idx&,jdy&,M&
LOCAL rcp AS RECT POINTER
rcp = VARPTR(rc)
LOCAL iTimes AS LONG
LOCAL rc2 AS RECT, r5 AS RECT
LOCAL hDCgr AS LONG
LOCAL ColStart AS LONG
STATIC TextHeight AS LONG
LOCAL lpSize AS SIZEL
STATIC Spacing AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL tm AS TEXTMETRIC
STATIC hBrushGr&,hBrushHd&,HeaderCol&,GridCol&
STATIC hCursorCellBrush AS LONG, hSelCellsBrush AS LONG
STATIC hFatFont AS LONG
STATIC hGrayPen AS LONG, hLightGrayPen AS LONG
STATIC memDCgr AS LONG, hBitGr AS LONG
STATIC siX AS SCROLLINFO
STATIC siY AS SCROLLINFO
STATIC xPos&, yPos&
STATIC DragFlagC&,DragIndxC&
STATIC DragFlagR&,DragIndxR&
STATIC xTot AS LONG, xk AS LONG, InFlagC AS LONG, xid AS LONG, xid2 AS LONG, xTot2 AS LONG
STATIC yTot AS LONG, yk AS LONG, InFlagR AS LONG, yid AS LONG, yid2 AS LONG, yTot2 AS LONG
STATIC SelX AS LONG ' Column selected
STATIC SelY AS LONG ' Row selected
STATIC ColWidth() AS LONG ' Array to hold column widths
STATIC RowHeight() AS LONG ' Array to hold row heights
STATIC HeaderHeight AS LONG ' Height of header control
STATIC LineHeight AS LONG ' Height of one line in grid control
STATIC SelYMax AS LONG
STATIC SelYMin AS LONG
STATIC SelXMax AS LONG
STATIC SelXMin AS LONG
STATIC UndoFlagPaste AS LONG, UndoXstartPaste AS LONG, UndoFlagClear AS LONG, UndoXstartClear AS LONG
STATIC InsertDelete AS LONG, Sorting AS LONG, SortType AS LONG
STATIC UndoLatestPaste() AS STRING, UndoLatestClear() AS STRING
STATIC UndoArray() AS STRING
STATIC UndoRowDel() AS STRING
STATIC ColWidthSave() AS LONG
STATIC RowHeightSave() AS LONG
STATIC indx() AS LONG, Rhigh AS LONG
STATIC nWidth AS LONG ' width of client area
STATIC nHeight AS LONG 'height of client area
STATIC hPopUp1 AS DWORD, hPopUp2 AS DWORD, hPopUp3 AS DWORD
STATIC RCdelete AS LONG
LOCAL t AS STRING
LOCAL KI AS LONG
LOCAL cowi AS LONG
STATIC hStatus AS LONG
STATIC CellFlag&, ColFlag&, RowFlag&
STATIC x1&,y1&,x2&,y2&
STATIC ptsCursor AS POINTAPI
STATIC hFatPen AS LONG
STATIC CellEdit AS LONG, HeaderEdit AS LONG
STATIC hBroadBlackPen AS LONG
LOCAL rcs AS RECT, yFlagU AS LONG, yFlagD AS LONG, xFlagL AS LONG, xFlagR AS LONG
LOCAL SelDr AS LONG
'
SELECT CASE CBMSG
CASE %WM_USER + 402
GOSUB Settings
FUNCTION = 0 : EXIT FUNCTION
'
CASE %WM_CREATE
'
hFontGlobal = MakeFont(15,%FW_NORMAL,0,0,0,"Arial")
hFatFont = MakeFont(15,%FW_BOLD,0,0,0,"Arial")
hGrayPen = CreatePen(%PS_SOLID, 0, %GRAY)
hLightGrayPen = CreatePen(%PS_SOLID, 0, %LTGRAY) 'rgb(225,225,225))'%LTGRAY)
hBroadBlackPen = CreatePen(%PS_SOLID, 3, %BLACK)
GridCol = RGB(255,255,255) : HeaderCol = RGB(210,210,210)
hBrushGr& = CreateSolidBrush(GridCol)
hBrushHd& = CreateSolidBrush(HeaderCol)
hCursorCellBrush = CreateSolidBrush(RGB(0,220,255))
'' hSelCellsBrush = CreateSolidBrush(RGB(170,200,250))
hSelCellsBrush = CreateSolidBrush(RGB(190,205,255))
'
MinWidth = 40
MinHeight = 16
Spacing = 5
'
' Create a virtual window for the grid
GetClientRect CBHNDL, rc
hDCgr = GetDC(CBHNDL)
memDCgr = CreateCompatibleDC(hDCgr)
hBitGr = CreateCompatibleBitmap(hDCgr,Rc.nRight,Rc.nBottom)
SelectObject memDCgr, hBitGr
SelectObject memDCgr, hFontGlobal
GetTextMetrics memDCgr, tm
LineHeight = tm.tmHeight + tm.tmInternalLeading
HeaderHeight = LineHeight + 1
'
Res& = PatBlt(memDCgr, 0, 0, Rc.nRight, Rc.nBottom, %PATCOPY)
SetBkMode memDCgr, %TRANSPARENT
GetClientRect CBHNDL, rc
'
' Get estimates of size variables for grid display
siY.nPage = (Rc.nBottom - HeaderHeight-1) \ LineHeight
' readjust grid height to avoid clipping of last line, initially
GetWindowRect CBHNDL, rc
MoveWindow CBHNDL, rc.nLeft, rc.nTop, rc.nRight - rc.nLeft, siY.nPage * LineHeight + HeaderHeight + GetSystemMetrics(%SM_CYHSCROLL) + 2 , 1
'
' Define shortcut menu.
MENU NEW POPUP TO hPopUp1
MENU ADD STRING, hPopUp1, "Extended Selection OFF", 5, %MF_ENABLED
MENU ADD STRING, hPopUp1, "-", 0, 0
MENU NEW POPUP TO hPopUp2
MENU ADD POPUP, hPopUp1, "Add", hPopUp2, %MF_ENABLED
MENU NEW POPUP TO hPopUp3
MENU ADD POPUP, hPopUp2, "Row(s)", hPopUp3, %MF_ENABLED
MENU ADD STRING, hPopUp3, "One", 30, %MF_ENABLED
MENU ADD STRING, hPopUp3, "Five", 31, %MF_ENABLED
MENU ADD STRING, hPopUp3, "Ten", 32, %MF_ENABLED
MENU NEW POPUP TO hPopUp3
MENU ADD POPUP, hPopUp2, "Column(s)", hPopUp3, %MF_ENABLED
MENU ADD STRING, hPopUp3, "One", 35, %MF_ENABLED
MENU ADD STRING, hPopUp3, "Five", 36, %MF_ENABLED
MENU ADD STRING, hPopUp3, "Ten", 37, %MF_ENABLED
MENU ADD STRING, hPopUp1, "-", 0, 0
MENU NEW POPUP TO hPopUp2
MENU ADD POPUP, hPopUp1, "Insert", hPopUp2, %MF_ENABLED
MENU ADD STRING, hPopUp2, "Row(s)", 65, %MF_ENABLED
MENU ADD STRING, hPopUp2, "Column(s)", 70, %MF_ENABLED
MENU ADD STRING, hPopUp1, "-", 0, 0
MENU NEW POPUP TO hPopUp2
MENU ADD POPUP, hPopUp1, "Delete", hPopUp2, %MF_ENABLED
MENU ADD STRING, hPopUp2, "Row(s)", 80, %MF_ENABLED
MENU ADD STRING, hPopUp2, "Column(s)", 81, %MF_ENABLED
MENU ADD STRING, hPopUp1, "Undo Latest Delete", 85, %MF_GRAYED
MENU ADD STRING, hPopUp1, "-", 0, 0
MENU ADD STRING, hPopUp1, "Clear", 41, %MF_ENABLED
MENU ADD STRING, hPopUp1, "Undo Latest Clear", 42, %MF_GRAYED
MENU ADD STRING, hPopUp1, "-", 0, 0
MENU ADD STRING, hPopUp1, "Copy", 45, %MF_ENABLED
MENU ADD STRING, hPopUp1, "-", 0, 0
MENU ADD STRING, hPopUp1, "Paste", 50, %MF_ENABLED
MENU ADD STRING, hPopUp1, "Undo Latest Paste", 60, %MF_GRAYED
MENU ADD STRING, hPopUp1, "-", 0, 0
MENU NEW POPUP TO hPopUp2
MENU ADD POPUP, hPopUp1, "Sort", hPopUp2, %MF_ENABLED
MENU ADD STRING, hPopUp2, "Alphabetic Ascending", 105, %MF_ENABLED
MENU ADD STRING, hPopUp2, "Alphabetic Descending", 110, %MF_ENABLED
MENU ADD STRING, hPopUp2, "Numeric Ascending", 115, %MF_ENABLED
MENU ADD STRING, hPopUp2, "Numeric Descending", 120, %MF_ENABLED
MENU ADD STRING, hPopUp1, "Undo Latest Sort", 122, %MF_GRAYED
MENU ADD STRING, hPopUp1, "-", 0, 0
MENU ADD STRING, hPopUp1, "Cell Writing OFF", 10, %MF_ENABLED
MENU ADD STRING, hPopUp1, "-", 0, 0
MENU ADD STRING, hPopUp1, "Header Editing OFF", 15, %MF_ENABLED
MENU ATTACH hPopUp1, CBHNDL
'
RowsGlobal = siY.nPage
REDIM PRESERVE DataRowsGlobal(0 TO RowsGlobal)
'
ColumnsGlobal = 9
FOR i = 0 TO RowsGlobal
DataRowsGlobal(i) = STRING$(ColumnsGlobal+1, $TAB)
NEXT
SendMessage CBHNDL, %WM_USER + 401, 0, 0
'
IF ISFALSE hEditGlobal THEN
' Create edit control
hEditGlobal = CreateWindow("EDIT",BYVAL %NULL,%WS_CHILD OR %ES_AUTOHSCROLL, _
0, 0, 0, 0,CBHNDL,%ID_EDITCHILD, _
GetWindowLong(CBHNDL,%GWL_HINSTANCE),BYVAL %NULL)
SendMessage hEditGlobal&,%WM_SETFONT,hFontGlobal,MAKLNG(%TRUE,0)
' Subclass Edit Control
gOldSubClassEditGlobal& = SetWindowLong(hEditGlobal&, %GWL_WNDPROC, CODEPTR(SubClassEditKeys))
END IF
GOSUB Settings
'
FUNCTION = 0 : EXIT FUNCTION
'
CASE %WM_USER + 401
'
REDIM ColWidth(0 TO ColumnsGlobal)
REDIM RowHeight(0 TO RowsGlobal)
RowHeight(0) = HeaderHeight
FOR i = 1 TO RowsGlobal
RowHeight(i) = LineHeight
NEXT
ColWidth(0) = 100
FOR i = 1 TO ColumnsGlobal
ColWidth(i) = 135
NEXT
' Define vertical scrollbar
siY.cbSize = SIZEOF(siY)
siY.fMask = %SIF_PAGE OR %SIF_POS OR %SIF_RANGE
siY.nMin = 1
siY.nMax = RowsGlobal
siY.nPos = 1
siY.nPage = PageDim(siY.nPos, RowHeight(), nHeight, 2)
Res& = SetScrollInfo(CBHNDL, %SB_VERT, siY, %TRUE)
'
' Define horizontal scrollbar
siX.cbSize = SIZEOF(siX)
siX.fMask = %SIF_PAGE OR %SIF_POS OR %SIF_RANGE
siX.nMin = 1
siX.nMax = ColumnsGlobal
siX.nPos = 1
siX.nPage = PageDim(siX.nPos, ColWidth(), nWidth, 2)
Res& = SetScrollInfo(CBHNDL, %SB_HORZ, siX, %TRUE)
'
' Set initial cursor position
SelectStartColGlobal = siX.nPos
SelectStartRowGlobal = siY.nPos
SelectEndRowGlobal = SelectStartRowGlobal : SelectEndColGlobal = SelectStartColGlobal
SelYMax& = SelectStartRowGlobal : SelYMin& = SelectStartRowGlobal
SelXMax& = SelectStartColGlobal : SelXMin& = SelectStartColGlobal
AnchorGlobal = 0
'
GOSUB Settings
'
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
'
CASE %WM_VSCROLL
SetFocus CBHNDL
IF ISTRUE EditFlagGlobal THEN CALL FinishEdit
HeadEditFlagGlobal = 0
'
' if AnchorGlobal is not set, then move SelectStartRowGlobal
' if AnchorGlobal is set, then move SelectEndRowGlobal. Hence the swap below
IF ISTRUE AnchorGlobal THEN SWAP SelectStartRowGlobal, SelectEndRowGlobal
'
siY.cbSize = SIZEOF(siY)
siY.fMask = %SIF_ALL
Res& = GetScrollInfo(CBHNDL, %SB_VERT, siY)
yPos = siY.nPos
SELECT CASE LOWRD(CBWPARAM)
'
CASE %SB_TOP
siY.nPos = siY.nMin : IF VScrollNotifyGlobal = %SB_TOP THEN SelectStartRowGlobal = siY.nMin
'
CASE %SB_BOTTOM
siY.nPos = siY.nMax
siY.nPage = PageDim(siY.nPos, RowHeight(), nHeight, 2)
siY.nPos = siY.nMax - siY.nPage + 1
IF VScrollNotifyGlobal = %SB_BOTTOM THEN SelectStartRowGlobal = siY.nMax
'
CASE %SB_LINEDOWN
IF VScrollNotifyGlobal = %SB_LINEDOWN THEN ' Down key pressed
IF SelectStartRowGlobal < siY.nMax THEN INCR SelectStartRowGlobal
DO
siY.nPage = PageDim(siY.nPos, RowHeight(), nHeight, 2)
IF SelectStartRowGlobal >= siY.nPos + siY.nPage THEN INCR siY.nPos
LOOP UNTIL SelectStartRowGlobal < siY.nPos + siY.nPage
ELSE ' Scroll bar clicked
INCR siY.nPos
END IF
siY.nPage = PageDim(siY.nPos, RowHeight(), nHeight, 2)
siY.nPos = MIN(siY.nMax - siY.nPage + 1, siY.nPos)
'
CASE %SB_LINEUP
IF VScrollNotifyGlobal = %SB_LINEUP THEN ' Up key pressed
IF SelectStartRowGlobal > siY.nMin THEN DECR SelectStartRowGlobal
IF SelectStartRowGlobal < siY.nPos THEN DECR siY.nPos
ELSE ' Scroll bar clicked
IF siY.nPos > siY.nMin THEN DECR siY.nPos
END IF
siY.nPage = PageDim(siY.nPos, RowHeight(), nHeight, 2)
'
CASE %SB_PAGEDOWN
i = SelectStartRowGlobal - siY.nPos
siY.nPage = PageDim(siY.nPos, RowHeight(), nHeight, 2)
IF VScrollNotifyGlobal = %SB_PAGEDOWN THEN ' Page Down key pressed
IF siY.nPos <= siY.nMax - siY.nPage THEN siY.nPos = MIN(siY.nPos + siY.nPage, siY.nMax - siY.nPage + 1)
SelectStartRowGlobal = siY.nPos + MIN(i, siY.nPage - 1)
ELSE ' Scroll bar clicked
siY.nPos = siY.nPos + siY.nPage
END IF
siY.nPage = PageDim(siY.nPos, RowHeight(), nHeight, 2)
'
CASE %SB_PAGEUP
i = SelectStartRowGlobal - siY.nPos
siY.nPage = PageDim(siY.nPos-1, RowHeight(), nHeight, 1)
IF VScrollNotifyGlobal = %SB_PAGEUP THEN ' Page Up key pressed
IF siY.nPos > siY.nMin THEN siY.nPos = MAX(siY.nPos - siY.nPage, siY.nMin)
SelectStartRowGlobal = siY.nPos + MIN(i, siY.nPage - 1)
ELSE ' Scroll bar clicked
siY.nPos = MAX(siY.nPos - siY.nPage, siY.nMin)
END IF
'
CASE %SB_THUMBTRACK
siY.nPos = siY.nTrackPos
siY.nPage = PageDim(siY.nPos, RowHeight(), nHeight, 2)
'
CASE ELSE
'
END SELECT
VScrollNotifyGlobal = -1
siY.fMask = %SIF_ALL
Res& = SetScrollInfo(CBHNDL, %SB_VERT, siY, %TRUE)
IF ISTRUE AnchorGlobal THEN SWAP SelectStartRowGlobal, SelectEndRowGlobal ' swap back the previous swap
IF ISFALSE AnchorGlobal THEN SelectEndRowGlobal = SelectStartRowGlobal : SelectEndColGlobal = SelectStartColGlobal
InvalidateRect CBHNDL, BYVAL %NULL , %FALSE
UpdateWindow CBHNDL
FUNCTION = 0 : EXIT FUNCTION
'
CASE %WM_HSCROLL
SetFocus CBHNDL
IF ISTRUE EditFlagGlobal THEN CALL FinishEdit
HeadEditFlagGlobal = 0
'
' if AnchorGlobal is not set, then move SelectStartColGlobal
' if AnchorGlobal is set, then move SelectEndColGlobal. Hence the swap below
IF ISTRUE AnchorGlobal THEN SWAP SelectStartColGlobal, SelectEndColGlobal
siX.cbSize = SIZEOF(siX)
siX.fMask = %SIF_ALL
Res& = GetScrollInfo(CBHNDL, %SB_HORZ, siX)
xPos = siX.nPos
SELECT CASE LOWRD(CBWPARAM)
CASE %SB_LEFT ' to the left limit
siX.nPos = siX.nMin
IF HScrollNotifyGlobal = %SB_LEFT THEN SelectStartColGlobal = siX.nMin
'
CASE %SB_RIGHT ' to the right limit
siX.nPos = siX.nMax
siX.nPage = PageDim(siX.nPos, ColWidth(), nWidth, 2)
siX.nPos = siX.nMax - siX.nPage + 1
IF HScrollNotifyGlobal = %SB_RIGHT THEN SelectStartColGlobal = siX.nMax
'
CASE %SB_LINELEFT
IF HScrollNotifyGlobal = %SB_LINELEFT THEN ' Left key pressed
IF SelectStartColGlobal > siX.nMin THEN DECR SelectStartColGlobal
IF SelectStartColGlobal < siX.nPos THEN DECR siX.nPos
ELSE ' Scroll bar clicked
IF siX.nPos > 1 THEN DECR siX.nPos
END IF
siX.nPage = PageDim(siX.nPos, ColWidth(), nWidth, 2)
'
CASE %SB_LINERIGHT
IF HScrollNotifyGlobal = %SB_LINERIGHT THEN ' Right key pressed
IF SelectStartColGlobal < siX.nMax THEN INCR SelectStartColGlobal
DO
siX.nPage = PageDim(siX.nPos, ColWidth(), nWidth, 2)
IF SelectStartColGlobal >= siX.nPos + siX.nPage THEN INCR siX.nPos
LOOP UNTIL SelectStartColGlobal < siX.nPos + siX.nPage
ELSE ' Scroll bar clicked
IF siX.nPos < siX.nMax THEN INCR siX.nPos
END IF
siX.nPage = PageDim(siX.nPos, ColWidth(), nWidth, 2)
siX.nPos = MIN(siX.nMax - siX.nPage + 1, siX.nPos)
'
CASE %SB_PAGELEFT
siX.nPage = PageDim(siX.nPos, ColWidth(), nWidth, 1)
siX.nPos = siX.nPos - siX.nPage
siX.nPage = PageDim(siX.nPos, ColWidth(), nWidth, 2)
'
CASE %SB_PAGERIGHT
siX.nPage = PageDim(siX.nPos, ColWidth(), nWidth, 2)
siX.nPos = siX.nPos + siX.nPage
siX.nPage = PageDim(siX.nPos, ColWidth(), nWidth, 2)
'
CASE %SB_THUMBTRACK
siX.nPos = siX.nTrackPos
siX.nPage = PageDim(siX.nPos, ColWidth(), nWidth, 2)
CASE ELSE
'
END SELECT
HScrollNotifyGlobal = -1
siX.fMask = %SIF_ALL
Res& = SetScrollInfo(CBHNDL, %SB_HORZ, siX, %TRUE)
IF ISTRUE AnchorGlobal THEN SWAP SelectStartColGlobal, SelectEndColGlobal ' swap back the previous swap
IF ISFALSE AnchorGlobal THEN SelectEndRowGlobal = SelectStartRowGlobal : SelectEndColGlobal = SelectStartColGlobal
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
UpdateWindow CBHNDL
FUNCTION = 0 : EXIT FUNCTION
'
CASE %WM_GETDLGCODE ' Ensure that the control processes all keys by itself
FUNCTION = %DLGC_WANTALLKEYS : EXIT FUNCTION
'
CASE %WM_CHAR ' Any character key at time of pressing
IF ISTRUE CellEdit THEN
' This is the starting signal for editing a cell.
' Before starting: End any previous editing.
SetFocus CBHNDL
'
' Set extended selection off
AnchorGlobal = 0
CheckMenuItem hPopup1,5,%MF_UNCHECKED
MENU SET TEXT hPopup1, BYCMD 5, "Extended Selection OFF"
SelectEndRowGlobal = SelectStartRowGlobal : SelectEndColGlobal = SelectStartColGlobal
'
IF ISTRUE EditFlagGlobal THEN CALL FinishEdit
HeadEditFlagGlobal = 0
'
SELECT CASE CBWPARAM
' Exit if character is not relevant.
CASE %VK_TAB,%VK_LINEFEED, %VK_RETURN, 32 TO 255
CASE ELSE : FUNCTION = 0 : EXIT FUNCTION
END SELECT
' First: If selected cell not in view, then scroll it into view.
IF ISFALSE ColFlag OR ISFALSE RowFlag THEN
IF ISFALSE ColFlag THEN
siX.nPos = SelectStartColGlobal
Res& = SetScrollInfo(CBHNDL, %SB_HORZ, siX, %TRUE)
END IF
IF ISFALSE RowFlag THEN
siY.nPos = SelectStartRowGlobal
Res& = SetScrollInfo(CBHNDL, %SB_VERT, siY, %TRUE)
END IF
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
UpdateWindow CBHNDL
END IF
'
' Identify character and perform relevant action.
SELECT CASE CBWPARAM
CASE %VK_TAB
HScrollNotifyGlobal = %SB_LINERIGHT
IF ISFALSE AnchorGlobal THEN SendMessage CBHNDL,%WM_HSCROLL,MAKLNG(HScrollNotifyGlobal,0),0
FUNCTION = 0 : EXIT FUNCTION
CASE %VK_LINEFEED, %VK_RETURN
VScrollNotifyGlobal = %SB_LINEDOWN
IF ISFALSE AnchorGlobal THEN SendMessage CBHNDL,%WM_VSCROLL,MAKLNG(VScrollNotifyGlobal,0),0
FUNCTION = 0 : EXIT FUNCTION
CASE 32 TO 255 ' Character codes
' Move edit window to selected cell and display it there.
MoveWindow hEditGlobal&,x1+1,y1+1,x2-x1-2,y2-y1-3,1
ShowWindow hEditGlobal&, %SW_SHOW
SetFocus hEditGlobal&
' Set current character as the first in the edit control.
CONTROL SET TEXT CBHNDL,%ID_EDITCHILD,CHR$(CBWPARAM)
SendMessage hEditGlobal,%EM_SETSEL,0,-1 ' Set caret
SendMessage hEditGlobal,%EM_SETSEL,-1,1 ' to end of string.
EditFlagGlobal = 1
END SELECT
GOSUB Settings
FUNCTION = 0 : EXIT FUNCTION
END IF
GOSUB Settings
'
CASE %WM_KEYDOWN
SetFocus CBHNDL
IF ISTRUE EditFlagGlobal THEN CALL FinishEdit
HeadEditFlagGlobal = 0
'
' Process arrow keys etc. for grid. hGridGlobal& needs to have focus.
VScrollNotifyGlobal = -1 : HScrollNotifyGlobal = -1
SELECT CASE CBWPARAM
CASE %VK_UP : VScrollNotifyGlobal = %SB_LINEUP
CASE %VK_DOWN : VScrollNotifyGlobal = %SB_LINEDOWN
CASE %VK_LEFT : HScrollNotifyGlobal = %SB_LINELEFT
CASE %VK_RIGHT : HScrollNotifyGlobal = %SB_LINERIGHT
CASE %VK_PRIOR : VScrollNotifyGlobal = %SB_PAGEUP
CASE %VK_NEXT : VScrollNotifyGlobal = %SB_PAGEDOWN
CASE %VK_HOME : HScrollNotifyGlobal = %SB_LEFT : VScrollNotifyGlobal = %SB_TOP
CASE %VK_END : HScrollNotifyGlobal = %SB_RIGHT : VScrollNotifyGlobal = %SB_BOTTOM
'
CASE %VK_F2 ' Function key F2: Activate a cell for editing
IF ISTRUE CellEdit THEN
' If selected cell not in view then scroll it into view
IF ISFALSE ColFlag OR ISFALSE RowFlag THEN
IF ISFALSE ColFlag THEN
siX.nPos = SelectStartColGlobal
Res& = SetScrollInfo(CBHNDL, %SB_HORZ, siX, %TRUE)
END IF
IF ISFALSE RowFlag THEN
siY.nPos = SelectStartRowGlobal
Res& = SetScrollInfo(CBHNDL, %SB_VERT, siY, %TRUE)
END IF
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
UpdateWindow CBHNDL
END IF
'
' Move edit window to selected cell and display it there.
MoveWindow hEditGlobal&,x1+1,y1+1,x2-x1-2,y2-y1-3,1
ShowWindow hEditGlobal&, %SW_SHOW
SetFocus hEditGlobal&
' Set current cell text in the edit control.
t=PARSE$(DataRowsGlobal(SelectStartRowGlobal),$TAB,SelectStartColGlobal + 1)
SetWindowText hEditGlobal, BYVAL STRPTR(t)
SendMessage hEditGlobal,%EM_SETSEL,0,-1 ' Set caret
SendMessage hEditGlobal,%EM_SETSEL,-1,1 ' to end of string.
EditFlagGlobal = 1
CorrectFlagGlobal = 1
GOSUB Settings
FUNCTION = 0 : EXIT FUNCTION
END IF
CASE %VK_F8
AnchorGlobal = 1 - AnchorGlobal
IF ISTRUE AnchorGlobal THEN
MENU SET STATE hPopup1, BYCMD 5, %MF_CHECKED
MENU SET TEXT hPopup1, BYCMD 5, "Extended Selection ON"
ELSE
MENU SET STATE hPopup1, BYCMD 5, %MF_UNCHECKED
MENU SET TEXT hPopup1, BYCMD 5, "Extended Selection OFF"
SelectEndRowGlobal = SelectStartRowGlobal : SelectEndColGlobal = SelectStartColGlobal
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
END IF
GOSUB Settings
FUNCTION = 0 : EXIT FUNCTION
CASE ELSE : FUNCTION = 0 : EXIT FUNCTION
'
END SELECT
IF VScrollNotifyGlobal > -1 THEN SendMessage CBHNDL, %WM_VSCROLL, MAKLNG(VScrollNotifyGlobal, 0), 0
IF HScrollNotifyGlobal > -1 THEN SendMessage CBHNDL, %WM_HSCROLL, MAKLNG(HScrollNotifyGlobal, 0), 0
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
UpdateWindow CBHNDL
FUNCTION = 0 : EXIT FUNCTION
'
CASE %WM_SIZE
'
nWidth = LOWRD(CBLPARAM) ' width of client area
nHeight = HIWRD(CBLPARAM) ' height of client area
GOSUB Settings
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
UpdateWindow CBHNDL
'
CASE %WM_PAINT
'
GOSUB Settings ' display current settings
'
' Draw grid
'
' Get full selection outline.
SelYMax& = MAX(SelectEndRowGlobal, SelectStartRowGlobal)
SelYMin& = MIN(SelectEndRowGlobal, SelectStartRowGlobal)
SelXMax& = MAX(SelectEndColGlobal, SelectStartColGlobal)
SelXMin& = MIN(SelectEndColGlobal, SelectStartColGlobal)
'
' Determine location of selection
'
yFlagU = 0 : yFlagD = 0 : xFlagL = 0 : xFlagR = 0 : SelDr = 1
j = 0 : rcs.nTop = RowHeight(0) - 1 : rcs.nBottom = nHeight
TextHeight = RowHeight(0)
DO WHILE TextHeight < nHeight
INCR j : jdy = ArIndx(j, siY.nPos)
IF jdy > RowsGlobal THEN EXIT DO
IF jdy = SelYMin THEN rcs.nTop = TextHeight - 1 : yFlagU = 1 ' selection upper line Y position
TextHeight = TextHeight + RowHeight(jdy)
IF jdy = SelYMax THEN rcs.nBottom = TextHeight - 1 : yFlagD = 1 ' selection lower line Y position
LOOP
IF ArIndx(1, siY.nPos) > SelYMax OR ArIndx(j, siY.nPos) < SelYMin THEN SelDr = 0 ' outside display window
'
i = 0 : rcs.nLeft = ColWidth(0) - 1 : rcs.nRight = nWidth
Colstart = ColWidth(0)
DO WHILE Colstart < nWidth
INCR i : idx = ArIndx(i, siX.nPos)
IF idx > ColumnsGlobal THEN EXIT DO
IF idx = SelXMin THEN rcs.nLeft = Colstart : xFlagL = 1 ' selection left line X position
Colstart = Colstart + ColWidth(idx)
IF idx = SelXMax THEN rcs.nRight = Colstart : xFlagR = 1 ' selection right line X position
LOOP
IF ArIndx(1, siX.nPos) > SelXMax OR ArIndx(i, siX.nPos) < SelXMin THEN SelDr = 0 ' outside display window
'
'
GetClientRect CBHNDL,rc
Res&=FillRect(memDCgr, rc, GetStockObject(%WHITE_BRUSH))
'
' Color column headers area
rc.nBottom = RowHeight(0) ' Header Height
Res&=FillRect(memDCgr, rc, hBrushHd)
'
' Set bacground colour of grid cells
GetClientRect CBHNDL,rc
rc.nTop = RowHeight(0) ' Header Height
Res&=FillRect(memDCgr, rc, hBrushGr)
GetClientRect CBHNDL,rc
GetClientRect CBHNDL,rc2
TextHeight = 0 : j = 0
CellFlag = %FALSE : RowFlag = %FALSE : ColFlag = %FALSE
'
' Row loop
DO WHILE (TextHeight < rc.nBottom - rc.nTop ) AND (j - 1 + siY.nPos <= RowsGlobal)
jdy = ArIndx(j, siY.nPos)
TextHeight = TextHeight + RowHeight(jdy)
ColStart = 0 : i = 0
'
' Column loop
DO WHILE (ColStart < rc.nRight) AND ArIndx(i, siX.nPos) <= UBOUND(ColWidth)
idx = ArIndx(i, siX.nPos)
cowi = ColWidth(idx)
k = 2
IF ColStart + cowi > rc.nRight THEN cowi = rc.nRight - ColStart
IF cowi <= 0 THEN EXIT DO
'
' Paint row header column and draw vertical lines
IF j = 0 THEN ' First line
IF i = 0 THEN ' Row header column: Paint it light gray
rc2.nRight = cowi
Res&=FillRect(memDCgr, rc2, hBrushHd)
ELSE ' Other columns: Draw vertical lines
IF i = 1 THEN ' Select black pen for row header column's right side
SelectObject memDCgr, GetStockObject(%BLACK_PEN)
ELSE ' Select grey pen for other columns
SelectObject memDCgr, hLightGrayPen
END IF
MoveToEx memDCgr, ColStart, RowHeight(0), BYVAL %NULL
LineTo memDCgr, Colstart, rc.nBottom
MoveToEx memDCgr, ColStart + cowi, RowHeight(0), BYVAL %NULL
LineTo memDCgr, Colstart + cowi, rc.nBottom
END IF
IF ColStart > 0 THEN ' Draw vertical lines in column header
SelectObject memDCgr, GetStockObject(%BLACK_PEN)
MoveToEx memDCgr,ColStart, RowHeight(0) - 1, BYVAL %NULL
LineTo memDCgr, ColStart, -1
MoveToEx memDCgr,ColStart + cowi, RowHeight(0) - 1, BYVAL %NULL
LineTo memDCgr, ColStart + cowi, -1
END IF
END IF
'
' Get text, background color and font
IF i = 0 THEN ' Row header (first) column text
IF j = 0 THEN
s = PARSE$(DataRowsGlobal(0), $TAB, 1) ' column header (first) line
ELSE
s = FORMAT$(jdy)+" "+PARSE$(DataRowsGlobal(jdy), $TAB, 1) ' following lines
END IF
SelectObject memDCgr, hFatFont
ELSE ' Following columns
IF j = 0 THEN ' column header text
IF idx <= UBOUND(ColWidth) THEN s = FORMAT$(idx)+" "+PARSE$(DataRowsGlobal(0), $TAB, idx + 1)
SelectObject memDCgr, hFatFont
IF idx = SelectStartColGlobal THEN ColFlag = 1
ELSE ' cell text
s = PARSE$(DataRowsGlobal(jdy), $TAB, idx + 1)
SelectObject memDCgr, hFontGlobal
END IF
END IF
'
' Write cell text
r5.nLeft = ColStart + 1
r5.nTop = TextHeight - RowHeight(jdy)
r5.nRight = ColStart + ColWidth(idx)
r5.nBottom = TextHeight
IF i>0 AND j>0 THEN
IF jdy = SelectStartRowGlobal AND idx = SelectStartColGlobal THEN
'
ELSEIF jdy >= SelYMin AND jdy <= SelYMax AND idx >= SelXMin AND idx <= SelXMax THEN
FillRect memDCgr, r5, hSelCellsBrush
END IF
ELSE
FillRect memDCgr, r5, hBrushHd
END IF
'
r5.nLeft = ColStart + Spacing : r5.nTop = r5.nTop + 1
DrawText memDCgr, s, BYVAL LEN(s), r5, BYVAL (%DT_LEFT OR %DT_END_ELLIPSIS OR %DT_WORDBREAK) ' or %DT_NOCLIP OR %DT_SINGLELINE OR %DT_VCENTER
'
' Determine if selected item is here. If so determine its rectangle.
IF jdy = SelectStartRowGlobal THEN ' Selected row in display
RowFlag = 1
IF idx = SelectStartColGlobal THEN ' Selected cell in display
x1 = ColStart + 1
x2 = ColStart + ColWidth(idx)
y1 = TextHeight - RowHeight(jdy)
y2 = TextHeight
CellFlag = 1
END IF
END IF
'
IF i = 0 OR j = 0 THEN ' Make button appearance of headers
IF j = 0 THEN KI = 1
IF i = 0 THEN KI = 0
SelectObject memDCgr, GetStockObject(%WHITE_PEN)
MoveToEx memDCgr, ColStart + KI, TextHeight - 2, BYVAL %NULL
LineTo memDCgr, ColStart + KI, TextHeight - RowHeight(jdy)
LineTo memDCgr, ColStart + cowi - 1, TextHeight - RowHeight(jdy)
SelectObject memDCgr, hGrayPen
LineTo memDCgr, ColStart + cowi - 1, TextHeight - 2
LineTo memDCgr, ColStart, TextHeight - 2
END IF
'
' Prepare to draw next column
ColStart = ColStart + ColWidth(idx)
INCR i
LOOP ' end column loop
'
' Finished with row: Draw horizontal line
' Row header part: black
SelectObject memDCgr, GetStockObject(%BLACK_PEN)
MoveToEx memDCgr, 0, TextHeight - 1, BYVAL %NULL
LineTo memDCgr, rc2.nRight, TextHeight - 1
' If not column header line, then remaining part lightgray
IF j > 0 THEN SelectObject memDCgr, hLightGrayPen
LineTo memDCgr, rc.nRight, TextHeight - 1
INCR j
IF j > UBOUND(RowHeight) THEN EXIT DO
LOOP ' end row loop
'
IF ISFALSE DisplayOnlyFlagGlobal THEN
IF ISTRUE SelDr THEN ' Draw selection lines
SelectObject memDCgr, hBroadBlackPen
IF ISTRUE yFlagU THEN ' draw upper line
MoveToEx memDCgr, rcs.nLeft, rcs.nTop, BYVAL %NULL
LineTo memDCgr, rcs.nRight, rcs.nTop
SetPixel memDCgr, rcs.nRight + 1, rcs.nTop - 1, %BLACK
END IF
IF ISTRUE yFlagD THEN ' draw lower line
MoveToEx memDCgr, rcs.nLeft, rcs.nBottom, BYVAL %NULL
LineTo memDCgr, rcs.nRight, rcs.nBottom
SetPixel memDCgr, rcs.nRight + 1, rcs.nBottom + 1, %BLACK
END IF
IF ISTRUE xFlagL THEN ' draw left line
MoveToEx memDCgr, rcs.nLeft, rcs.nTop, BYVAL %NULL
LineTo memDCgr, rcs.nLeft, rcs.nBottom
SetPixel memDCgr, rcs.nLeft - 1, rcs.nTop - 1, %BLACK
SetPixel memDCgr, rcs.nLeft - 1, rcs.nBottom + 1, %BLACK
END IF
IF ISTRUE xFlagR THEN ' draw right line
MoveToEx memDCgr, rcs.nRight, rcs.nTop, BYVAL %NULL
LineTo memDCgr, rcs.nRight, rcs.nBottom
SetPixel memDCgr, rcs.nRight + 1, rcs.nTop - 1, %BLACK
SetPixel memDCgr, rcs.nRight + 1, rcs.nBottom + 1, %BLACK
END IF
'
END IF
END IF
ShowScrollBar CBHNDL, %SB_BOTH, %TRUE ' always show scroll bars
'
hDCgr = BeginPaint(CBHNDL, Ps)
'
' Copy virtual grid window onto screen.
Res& = BitBlt(hDCgr,0,0,Rc.nRight,Rc.nBottom,memDCgr,0,0,%SRCCOPY)
'
EndPaint CBHNDL, Ps
'
FUNCTION = 0 : EXIT FUNCTION
'
CASE %WM_MOUSEMOVE
'
xPos = LOWRD(CBLPARAM) : yPos = HIWRD(CBLPARAM)
IF ISFALSE (CBWPARAM AND %MK_LBUTTON) THEN ' left button not down
GOSUB OnColumnOrRowDivider
ELSE ' left button down
IF DragFlagC = 1 AND xid > -1 THEN ' Column divisor dragging is going on
xTot = 0 : xk = 0 : MOUSEPTR 9
DO
i = ArIndx(xk, siX.nPos)
IF i > xid THEN EXIT DO
xTot = xTot + ColWidth(i)
INCR xk
LOOP
ColWidth(xid) = MAX(ColWidth(xid) + xPos - xTot, MinWidth)
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
FUNCTION = 0 : EXIT FUNCTION
END IF
'
IF DragFlagR = 1 AND yid > -1 THEN ' Row divisor dragging is going on
yTot = 0 : yk = 0 : MOUSEPTR 7
DO
i = ArIndx(yk, siY.nPos)
IF i > yid THEN EXIT DO
yTot = yTot + RowHeight(i)
INCR yk
LOOP
RowHeight(yid) = MAX(RowHeight(yid) + yPos - yTot, MinHeight)
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
END IF
END IF
FUNCTION = 0 : EXIT FUNCTION
'
OnColumnOrRowDivider:
GetClientRect CBHNDL,rc
InFlagC = 0 : InFlagR = 0
IF yPos >= 0 AND yPos <= RowHeight(0) AND xPos > ColWidth(0) - 6 THEN ' in column header area
xTot = 0 : xk = 0
DO
xid = ArIndx(xk, siX.nPos)
xTot = xTot + ColWidth(xid)
IF InFlagC = 0 AND xTot > xPos THEN xid2 = xid : xTot2 = xTot : InFlagC = -1
IF ABS(xTot - xPos) < 7 THEN MOUSEPTR 9 : InFlagC = 1 : EXIT DO
INCR xk
IF xTot > rc.nRight + 6 OR ArIndx(xk, siX.nPos) > UBOUND(ColWidth) THEN EXIT DO
LOOP
ELSEIF xPos >= 0 AND xPos <= ColWidth(0) AND yPos > RowHeight(0) - 6 THEN ' in row header area
yTot = 0 : yk = 0
DO
yid = ArIndx(yk, siY.nPos)
yTot = yTot + RowHeight(yid)
IF InFlagR = 0 AND yTot > yPos THEN yid2 = yid : yTot2 = yTot : InFlagR = -1
IF ABS(yTot - yPos) < 5 THEN MOUSEPTR 7 : InFlagR = 1 : EXIT DO
INCR yk
IF yTot > rc.nBottom + 4 OR ArIndx(yk, siY.nPos) > UBOUND(RowHeight) THEN EXIT DO
LOOP
END IF
IF InFlagC = 0 THEN xid = -1
IF InFlagR = 0 THEN yid = -1
'
RETURN
CASE %WM_LBUTTONDOWN
SetFocus CBHNDL
IF ISTRUE EditFlagGlobal THEN CALL FinishEdit
HeadEditFlagGlobal = 0
'
xPos = LOWRD(CBLPARAM) : yPos = HIWRD(CBLPARAM)
DragFlagC = 0 : DragFlagR = 0
GOSUB OnColumnOrRowDivider
IF InFlagC = 1 THEN ' on field separator in column header area
DragFlagC = 1
ELSEIF InFlagC = -1 THEN ' in column header area outside field separator
IF ISTRUE HeaderEdit THEN
SendMessage hEditGlobal&,%WM_SETFONT,hFatFont,MAKLNG(%TRUE,0)
HeadColGlobal = xid2
' Move edit window to selected cell and display it there.
MoveWindow hEditGlobal&, xTot2-ColWidth(xid2)+2, 1, ColWidth(xid2)-3, RowHeight(0)-3, 1
ShowWindow hEditGlobal&, %SW_SHOW
SetFocus hEditGlobal&
' Set current cell text in the edit control.
t=PARSE$(DataRowsGlobal(0),$TAB,xid2+1)
SetWindowText hEditGlobal, BYVAL STRPTR(t)
SendMessage hEditGlobal,%EM_SETSEL,0,-1 ' Set caret
SendMessage hEditGlobal,%EM_SETSEL,-1,1 ' to end of string.
HeadEditFlagGlobal = 1
EditFlagGlobal = 1
CorrectFlagGlobal = 1
GOSUB Settings
FUNCTION = 0 : EXIT FUNCTION
END IF
END IF
'
IF InFlagR = 1 THEN ' on field separator in row header area
DragFlagR = 1
ELSEIF InFlagR = -1 THEN ' in row header area outside field separator
IF ISTRUE HeaderEdit THEN
SendMessage hEditGlobal&,%WM_SETFONT,hFatFont,MAKLNG(%TRUE,0)
EditRowGlobal = yid2
' Move edit window to selected cell and display it there.
MoveWindow hEditGlobal&, 1, yTot2 - RowHeight(yid2)+1, Colwidth(0)-2, RowHeight(yid2)-3, 1
ShowWindow hEditGlobal&, %SW_SHOW
SetFocus hEditGlobal&
' Set current cell text in the edit control.
t=PARSE$(DataRowsGlobal(EditRowGlobal), $TAB, 1)
SetWindowText hEditGlobal, BYVAL STRPTR(t)
SendMessage hEditGlobal,%EM_SETSEL,0,-1 ' Set caret
SendMessage hEditGlobal,%EM_SETSEL,-1,1 ' to end of string.
RowHeaderEditFlagGlobal = 1
EditFlagGlobal = 1
CorrectFlagGlobal = 1
GOSUB Settings
FUNCTION = 0 : EXIT FUNCTION
END IF
END IF
'
GOSUB InCellArea
IF xTot <> -9999 AND yTot <> -9999 THEN
IF ISTRUE AnchorGlobal THEN
SelectEndRowGlobal = yid : SelectEndColGlobal = xid
ELSE
SelectStartRowGlobal = yid : SelectStartColGlobal = xid
SelectEndRowGlobal = SelectStartRowGlobal : SelectEndColGlobal = SelectStartColGlobal
END IF
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
END IF
FUNCTION = 0 : EXIT FUNCTION
'
InCellArea: ' identify which cell
IF xPos > ColWidth(0) AND yPos > RowHeight(0) THEN
'
xTot = 0 : xk = 0
GetClientRect CBHNDL,rc
DO
xid = ArIndx(xk, siX.nPos)
xTot = xTot + ColWidth(xid)
IF xTot > xPos THEN EXIT DO
INCR xk
IF ArIndx(xk, siX.nPos) > UBOUND(ColWidth) THEN xTot = -9999 : EXIT DO
LOOP
'
yTot = 0 : yk = 0
DO
yid = ArIndx(yk, siY.nPos)
yTot = yTot + RowHeight(yid)
IF yTot > yPos THEN EXIT DO
INCR yk
IF ArIndx(yk, siY.nPos) > UBOUND(RowHeight) THEN yTot = -9999 : EXIT DO
LOOP
ELSE
yTot = -9999 : xTot = -9999
END IF
RETURN
'
CASE %WM_LBUTTONUP
DragFlagC = 0 : DragIndxC = -1
DragFlagR = 0 : DragIndxR = -1
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
FUNCTION = 0 : EXIT FUNCTION
CASE %WM_LBUTTONDBLCLK
' msgbox "left double click"
CASE %WM_RBUTTONDBLCLK
' MSGBOX "right double click"
CASE %WM_RBUTTONDOWN ' Display shortcut menu
IF ISTRUE MenuFlagGlobal THEN ' display popup menu only if flag is true
xPos = LOWRD(CBLPARAM) : yPos = HIWRD(CBLPARAM)
IF ISTRUE IsClipboardFormatAvailable(%CF_TEXT) THEN ' Can paste
EnableMenuItem hPopUp1,50,%MF_ENABLED
ELSE
EnableMenuItem hPopUp1,50,%MF_GRAYED
END IF
IF ISTRUE UndoFlagPaste THEN ' Can undo latest paste
EnableMenuItem hPopUp1,60,%MF_ENABLED
ELSE
EnableMenuItem hPopUp1,60,%MF_GRAYED
END IF
GetWindowRect CBHNDL, r5
TrackPopupMenuEx hPopUp1,%TPM_LEFTALIGN OR %TPM_VERTICAL OR %TPM_LEFTBUTTON OR %TPM_RIGHTBUTTON ,xPos+r5.nLeft, yPos+r5.nTop, CBHNDL, BYVAL %NULL
END IF
'
CASE %WM_NOTIFY
'
CASE %WM_COMMAND
SELECT CASE CBCTL 'LOWRD(CBWPARAM)
'
' Right Click Menu
CASE 5 ' Toggle Extended selection
AnchorGlobal = 1 - AnchorGlobal
IF ISTRUE AnchorGlobal THEN
MENU SET STATE hPopup1, BYCMD 5, %MF_CHECKED
MENU SET TEXT hPopup1, BYCMD 5, "Extended Selection ON"
ELSE
MENU SET STATE hPopup1, BYCMD 5, %MF_UNCHECKED
MENU SET TEXT hPopup1, BYCMD 5, "Extended Selection OFF"
SelectEndRowGlobal = SelectStartRowGlobal : SelectEndColGlobal = SelectStartColGlobal
END IF
GOSUB Settings
FUNCTION = 0 : EXIT FUNCTION
'
Settings:
IF ISTRUE MenuFlagGlobal THEN
LOCAL s4 AS STRING
SendMessage hStaticGlobal&, %WM_SETFONT, hFontGlobal, MAKLNG(%TRUE,0)
s4 = "Current settings: "
IF AnchorGlobal = 1 THEN s4 = s4 + "Extended Selection (F8): ON " ELSE s4 = s4 + "Extended Selection (F8): OFF "
IF CellEdit = 1 THEN s4 = s4 + "Cell Writing: ON " ELSE s4 = s4 + "Cell Writing: OFF "
IF CorrectFlagGlobal = 1 THEN s4 = s4 + "Cell Editig (F2): ON " ELSE s4 = s4 + "Cell Editing (F2): OFF "
IF HeaderEdit = 1 THEN s4 = s4 + "Header Editing: ON " ELSE s4 = s4 + "Header Editing: OFF "
CONTROL SET TEXT GetParent(CBHNDL), %FORM1_STATIC, s4
END IF
RETURN
'
CASE 10 ' Toggle Cell Edit
CellEdit = 1 - CellEdit
IF ISTRUE CellEdit THEN
CheckMenuItem hPopup1, 10, %MF_CHECKED
MENU SET TEXT hPopup1, BYCMD 10, "Cell Writing ON"
ELSE
CheckMenuItem hPopup1, 10, %MF_UNCHECKED
MENU SET TEXT hPopup1, BYCMD 10, "Cell Writing OFF"
END IF
GOSUB Settings
'
CASE 15 ' Toggle Header Edit
HeaderEdit = 1 - HeaderEdit
IF ISTRUE HeaderEdit THEN
CheckMenuItem hPopup1, 15 ,%MF_CHECKED
MENU SET TEXT hPopup1, BYCMD 15, "Header Editing ON"
ELSE
CheckMenuItem hPopup1, 15, %MF_UNCHECKED
MENU SET TEXT hPopup1, BYCMD 15, "Header Editing OFF"
END IF
GOSUB Settings
'
CASE 30 ' Add extra rows (below the last)
iTimes = 1 : GOSUB AddRows : GOSUB Settings : FUNCTION = 0 : EXIT FUNCTION
'
CASE 31
iTimes = 5 : GOSUB AddRows : GOSUB Settings : FUNCTION = 0 : EXIT FUNCTION
'
CASE 32
iTimes = 10 : GOSUB AddRows : GOSUB Settings : FUNCTION = 0 : EXIT FUNCTION
'
AddRows:
AnchorGlobal = 0
CheckMenuItem hPopup1,5,%MF_UNCHECKED
MENU SET TEXT hPopup1, BYCMD 5, "Extended Selection OFF"
FOR i = 1 TO iTimes
INCR RowsGlobal : INCR siY.nMax
REDIM PRESERVE DataRowsGlobal(0 TO RowsGlobal)
DataRowsGlobal(RowsGlobal) = STRING$(ColumnsGlobal+1, $TAB)
REDIM PRESERVE RowHeight(0 TO RowsGlobal)
RowHeight(RowsGlobal) = LineHeight
NEXT
siY.nPos = siY.nMax
siY.nPage = PageDim(siY.nPos, RowHeight(), nHeight, 2)
siY.nPos = siY.nMax - siY.nPage + 1
SelectStartRowGlobal = RowsGlobal - iTimes + 1 : SelectEndRowGlobal = SelectStartRowGlobal
SelectEndColGlobal = SelectStartColGlobal
siY.fMask = %SIF_PAGE OR %SIF_POS OR %SIF_RANGE
Res& = SetScrollInfo(CBHNDL, %SB_VERT, siY, %TRUE)
EnableMenuItem hPopUp1, 122, %MF_GRAYED ' undo latest sort
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
RETURN
'
CASE 35 ' Add extra columns (to the right of the last column)
iTimes = 1 : GOSUB AddColumns : GOSUB Settings : FUNCTION = 0 : EXIT FUNCTION
'
CASE 36
iTimes = 5 : GOSUB AddColumns : GOSUB Settings : FUNCTION = 0 : EXIT FUNCTION
'
CASE 37
iTimes = 10 : GOSUB AddColumns : GOSUB Settings : FUNCTION = 0 : EXIT FUNCTION
'
AddColumns:
AnchorGlobal = 0
CheckMenuItem hPopup1,5,%MF_UNCHECKED
MENU SET TEXT hPopup1, BYCMD 5, "Extended Selection OFF"
FOR j = 1 TO iTimes
INCR ColumnsGlobal : INCR siX.nMax
REDIM PRESERVE ColWidth(0 TO ColumnsGlobal)
FOR i = 0 TO RowsGlobal
DataRowsGlobal(i) = DataRowsGlobal(i) + $TAB
NEXT
ColWidth(ColumnsGlobal) = ColWidth(ColumnsGlobal - 1)
NEXT
siX.nPos = siX.nMax
siX.nPage = PageDim(siX.nPos, ColWidth(), nWidth, 2)
siX.nPos = siX.nMax - siX.nPage + 1
SelectStartColGlobal = ColumnsGlobal - iTimes + 1 : SelectEndColGlobal = SelectStartColGlobal
SelectEndRowGlobal = SelectStartRowGlobal
siX.fMask = %SIF_PAGE OR %SIF_POS OR %SIF_RANGE
Res& = SetScrollInfo(CBHNDL, %SB_HORZ, siX, %TRUE)
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
RETURN
'
CASE 41 ' Clear selected data
AnchorGlobal = 0
CheckMenuItem hPopup1,5,%MF_UNCHECKED
MENU SET TEXT hPopup1, BYCMD 5, "Extended Selection OFF"
EnableMenuItem hPopUp1, 42, %MF_ENABLED
GOSUB Settings
Res = ClearSelection(UndoLatestClear(), UndoFlagClear, UndoXstartClear, SelXMin, SelXMax, SelYMin, SelYMax)
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
CASE 42 ' Undo latest clear
AnchorGlobal = 0
CheckMenuItem hPopup1,5,%MF_UNCHECKED
MENU SET TEXT hPopup1, BYCMD 5, "Extended Selection OFF"
EnableMenuItem hPopUp1, 42, %MF_GRAYED ' undo latest clear
GOSUB Settings
res = UndoLatestPasteOrClear(UndoLatestClear(), UndoFlagClear, UndoXstartClear,SelectStartColGlobal,SelectStartRowGlobal,SelectEndColGlobal,SelectEndRowGlobal)
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
CASE 45 ' Copy selected data to clipboard
AnchorGlobal = 0
CheckMenuItem hPopup1,5,%MF_UNCHECKED
MENU SET TEXT hPopup1, BYCMD 5, "Extended Selection OFF"
EnableMenuItem hPopUp1, 122, %MF_GRAYED ' undo latest sort
GOSUB Settings
Res& = SelectionToClipboard(SelXMin,SelXMax,SelYMin,SelYMax)
IF ISFALSE Res& THEN MSGBOX "Could Not Copy to Clipboard",%MB_ICONERROR,"Problem:"
CASE 50 ' Paste clipboard data to grid at the focused cell
AnchorGlobal = 0
CheckMenuItem hPopup1,5,%MF_UNCHECKED
MENU SET TEXT hPopup1, BYCMD 5, "Extended Selection OFF"
EnableMenuItem hPopUp1, 60, %MF_ENABLED
EnableMenuItem hPopUp1, 122, %MF_GRAYED ' undo latest sort
GOSUB Settings
res = ClipboardToGrid(UndoLatestPaste(), UndoFlagPaste, UndoXstartPaste,SelectStartColGlobal,SelectStartRowGlobal,SelectEndColGlobal,SelectEndRowGlobal)
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
IF ISFALSE Res& THEN MSGBOX "Could Not Paste From Clipboard",%MB_ICONERROR,"Problem:"
IF Res& = 2 THEN MSGBOX "Not All Data In Clipboard Could Be Pasted Onto Grid Due To Insufficient Space",%MB_ICONWARNING,"Notice:"
CASE 60 ' Undo latest paste to the grid
AnchorGlobal = 0
CheckMenuItem hPopup1,5,%MF_UNCHECKED
MENU SET TEXT hPopup1, BYCMD 5, "Extended Selection OFF"
EnableMenuItem hPopUp1, 60, %MF_GRAYED ' undo latest paste
GOSUB Settings
' EnableMenuItem hPopUp1, 35, %MF_GRAYED
res = UndoLatestPasteOrClear(UndoLatestPaste(), UndoFlagPaste, UndoXstartPaste,SelectStartColGlobal,SelectStartRowGlobal,SelectEndColGlobal,SelectEndRowGlobal)
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
'
CASE 65 ' Insert Rows
MOUSEPTR 11
EnableMenuItem hPopUp1, 60, %MF_GRAYED ' undo latest paste
EnableMenuItem hPopUp1, 42, %MF_GRAYED ' undo latest clear
EnableMenuItem hPopUp1, 122, %MF_GRAYED ' undo latest sort
RowsGlobal = RowsGlobal + ABS(SelectEndRowGlobal - SelectStartRowGlobal) + 1 : siY.nMax = siY.nMax + ABS(SelectEndRowGlobal - SelectStartRowGlobal) + 1
REDIM PRESERVE DataRowsGlobal(0 TO RowsGlobal)
FOR I = MIN(SelectEndRowGlobal, SelectStartRowGlobal) TO MAX(SelectEndRowGlobal, SelectStartRowGlobal)
ARRAY INSERT DataRowsGlobal(I), STRING$(ColumnsGlobal + 1, $TAB)
NEXT
REDIM PRESERVE RowHeight(0 TO RowsGlobal)
FOR I = MIN(SelectEndRowGlobal, SelectStartRowGlobal) TO MAX(SelectEndRowGlobal, SelectStartRowGlobal)
ARRAY INSERT RowHeight(i), LineHeight
NEXT
MOUSEPTR 1
siY.fMask = %SIF_ALL
Res = SetScrollInfo(CBHNDL, %SB_VERT, siY, %TRUE)
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
'
CASE 70 ' Insert Columns
MOUSEPTR 11
EnableMenuItem hPopUp1, 60, %MF_GRAYED ' undo latest paste
EnableMenuItem hPopUp1, 42, %MF_GRAYED ' undo latest clear
ColumnsGlobal = ColumnsGlobal + ABS(SelectEndColGlobal - SelectStartColGlobal) + 1 : siX.nMax = siX.nMax + ABS(SelectEndColGlobal - SelectStartColGlobal) + 1
REDIM PRESERVE ColWidth(0 TO ColumnsGlobal)
FOR i = 0 TO RowsGlobal
DataRowsGlobal(i) = InsertEmptyFields(DataRowsGlobal(i), MIN(SelectEndColGlobal, SelectStartColGlobal) + 1, ABS(SelectEndColGlobal - SelectStartColGlobal) + 1, $TAB)
NEXT
FOR i = MIN(SelectEndColGlobal, SelectStartColGlobal) + 1 TO MAX(SelectEndColGlobal, SelectStartColGlobal) + 1
ARRAY INSERT ColWidth(i), 135
NEXT
MOUSEPTR 1
siX.fMask = %SIF_ALL
Res = SetScrollInfo(CBHNDL, %SB_HORZ, siX, %TRUE)
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
'
CASE 80 ' Delete Rows
RCdelete = 1
MOUSEPTR 11
EnableMenuItem hPopUp1, 60, %MF_GRAYED ' undo latest paste
EnableMenuItem hPopUp1, 42, %MF_GRAYED ' undo latest clear
EnableMenuItem hPopUp1, 122, %MF_GRAYED ' undo latest sort
REDIM UndoRowDel(MIN(SelectEndRowGlobal, SelectStartRowGlobal) TO MAX(SelectEndRowGlobal, SelectStartRowGlobal))
REDIM RowHeightSave(MIN(SelectEndRowGlobal, SelectStartRowGlobal) TO MAX(SelectEndRowGlobal, SelectStartRowGlobal))
RowsGlobal = RowsGlobal - ABS(SelectEndRowGlobal - SelectStartRowGlobal) - 1 : siY.nMax = siY.nMax - ABS(SelectEndRowGlobal - SelectStartRowGlobal) - 1
FOR I = MAX(SelectEndRowGlobal, SelectStartRowGlobal) TO MIN(SelectEndRowGlobal, SelectStartRowGlobal) STEP -1
UndoRowDel(I) = DataRowsGlobal(I)
ARRAY DELETE DataRowsGlobal(I)
NEXT
FOR I = MAX(SelectEndRowGlobal, SelectStartRowGlobal) TO MIN(SelectEndRowGlobal, SelectStartRowGlobal) STEP -1
RowHeightSave(I) = RowHeight(I)
ARRAY DELETE RowHeight(I)
NEXT
AnchorGlobal = 0
MENU SET STATE hPopup1, BYCMD 5, %MF_UNCHECKED
MENU SET TEXT hPopup1, BYCMD 5, "Extended Selection OFF"
SelectStartRowGlobal = MIN(RowsGlobal, SelectStartRowGlobal)
SelectEndRowGlobal = SelectStartRowGlobal : SelectEndColGlobal = SelectStartColGlobal
GOSUB Settings
' SelectEndRowGlobal = MIN(SelectEndRowGlobal, RowsGlobal) : SelectStartRowGlobal = MIN(SelectStartRowGlobal, RowsGlobal)
REDIM PRESERVE DataRowsGlobal(0 TO RowsGlobal)
REDIM PRESERVE RowHeight(0 TO RowsGlobal)
MOUSEPTR 1
EnableMenuItem hPopUp1, 122, %MF_GRAYED ' undo sort
EnableMenuItem hPopUp1, 85, %MF_ENABLED
siY.nPage = PageDim(siY.nPos, RowHeight(), nHeight, 2)
siY.nPos = MIN(siY.nPos, siY.nMax - siY.nPage + 1)
siY.fMask = %SIF_ALL
Res = SetScrollInfo(CBHNDL, %SB_VERT, siY, %TRUE)
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
'
CASE 81 ' Delete Columns
RCdelete = 2
MOUSEPTR 11
EnableMenuItem hPopUp1, 60, %MF_GRAYED ' undo latest paste
EnableMenuItem hPopUp1, 42, %MF_GRAYED ' undo latest clear
REDIM UndoArray(0 TO RowsGlobal)
REDIM ColWidthSave(MIN(SelectEndColGlobal, SelectStartColGlobal) TO MAX(SelectEndColGlobal, SelectStartColGlobal))
FOR i = 0 TO RowsGlobal
UndoArray(i) = DeleteAndGetDeletedFields(DataRowsGlobal(i), MIN(SelectEndColGlobal, SelectStartColGlobal) + 1, MAX(SelectEndColGlobal, SelectStartColGlobal) + 1, $TAB)
NEXT
FOR i = MAX(SelectEndColGlobal, SelectStartColGlobal) TO MIN(SelectEndColGlobal, SelectStartColGlobal) STEP -1
ColWidthSave(i) = ColWidth(i)
ARRAY DELETE ColWidth(i)
NEXT
ColumnsGlobal = ColumnsGlobal - ABS(SelectEndColGlobal - SelectStartColGlobal) - 1 : siX.nMax = siX.nMax - ABS(SelectEndColGlobal - SelectStartColGlobal) - 1
AnchorGlobal = 0
MENU SET STATE hPopup1, BYCMD 5, %MF_UNCHECKED
MENU SET TEXT hPopup1, BYCMD 5, "Extended Selection OFF"
SelectStartColGlobal = MIN(ColumnsGlobal, SelectStartColGlobal)
SelectEndRowGlobal = SelectStartRowGlobal : SelectEndColGlobal = SelectStartColGlobal
GOSUB Settings
' SelectEndColGlobal = MIN(SelectEndColGlobal, ColumnsGlobal) : SelectStartColGlobal = MIN(SelectStartColGlobal, ColumnsGlobal)
REDIM PRESERVE ColWidth(0 TO ColumnsGlobal)
siX.nPage = PageDim(siX.nPos, ColWidth(), nWidth, 2)
siX.nPos = MIN(siX.nPos, siX.nMax - siX.nPage + 1)
EnableMenuItem hPopUp1, 85, %MF_ENABLED
siX.fMask = %SIF_ALL
Res = SetScrollInfo(CBHNDL, %SB_HORZ, siX, %TRUE)
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
MOUSEPTR 1
'
CASE 85 ' Undo latest row(s)/column(s) delete
MOUSEPTR 11
IF RCdelete = 1 THEN ' Undo latest Row(s) delete
RowsGlobal = RowsGlobal + UBOUND(RowHeightSave) - LBOUND(RowHeightSave) + 1
siY.nMax = siY.nMax + UBOUND(RowHeightSave) - LBOUND(RowHeightSave) + 1
SelectStartColGlobal = 1 : SelectEndColGlobal = ColumnsGlobal
SelectStartRowGlobal = LBOUND(RowHeightSave) : SelectEndRowGlobal = UBOUND(RowHeightSave)
REDIM PRESERVE DataRowsGlobal(0 TO RowsGlobal)
FOR I = LBOUND(RowHeightSave) TO UBOUND(RowHeightSave)
ARRAY INSERT DataRowsGlobal(I), UndoRowDel(I)
NEXT
REDIM PRESERVE RowHeight(0 TO RowsGlobal)
FOR I = LBOUND(RowHeightSave) TO UBOUND(RowHeightSave)
ARRAY INSERT RowHeight(i), RowHeightSave(i)
NEXT
siY.fMask = %SIF_ALL
Res = SetScrollInfo(CBHNDL, %SB_VERT, siY, %TRUE)
ELSEIF RCdelete = 2 THEN ' Undo latest Column(s) Delete
ColumnsGlobal = ColumnsGlobal + UBOUND(ColWidthSave) - LBOUND(ColWidthSave) + 1
siX.nMax = siX.nMax + UBOUND(ColWidthSave) - LBOUND(ColWidthSave) + 1
SelectStartColGlobal = LBOUND(ColWidthSave) : SelectEndColGlobal = UBOUND(ColWidthSave)
SelectStartRowGlobal = 1 : SelectEndRowGlobal = RowsGlobal
REDIM PRESERVE ColWidth(0 TO ColumnsGlobal)
FOR i = 0 TO RowsGlobal
DataRowsGlobal(i) = InsertTextFields(DataRowsGlobal(i), UndoArray(i), LBOUND(ColWidthSave) + 1, $TAB)
NEXT
FOR i = LBOUND(ColWidthSave) TO UBOUND(ColWidthSave)
ARRAY INSERT ColWidth(i), ColWidthSave(i)
NEXT
siX.fMask = %SIF_ALL
Res = SetScrollInfo(CBHNDL, %SB_HORZ, siX, %TRUE)
END IF
RCdelete = 0
MOUSEPTR 1
EnableMenuItem hPopUp1, 85, %MF_GRAYED
AnchorGlobal = 0
MENU SET STATE hPopup1, BYCMD 5, %MF_UNCHECKED
MENU SET TEXT hPopup1, BYCMD 5, "Extended Selection OFF"
GOSUB Settings
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
'
CASE 105 ' Ascending Alphabetic Sorting
SortType = 1 : GOSUB sorting : FUNCTION = 0 : EXIT FUNCTION
'
sorting:
EnableMenuItem hPopUp1, 122, %MF_ENABLED
EnableMenuItem hPopUp1, 60, %MF_GRAYED ' undo latest paste
EnableMenuItem hPopUp1, 42, %MF_GRAYED ' undo latest clear
REDIM indx(0 TO RowsGlobal)
MOUSEPTR 11
IF UBOUND(DataRowsGlobal) > 2 THEN CALL PBTagarraySort(DataRowsGlobal(), 1, RowsGlobal, SelectStartColGlobal, SortType, indx(), Rhigh)
MOUSEPTR 1
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
RETURN
'
CASE 110 ' Descending Alphabetic Sorting
SortType = 2 : GOSUB sorting : FUNCTION = 0 : EXIT FUNCTION
'
CASE 115 ' Ascending Numerical Sorting
SortType = 3 : GOSUB sorting : FUNCTION = 0 : EXIT FUNCTION
'
CASE 120 ' Descending Numerical Sorting
SortType = 4 : GOSUB sorting : FUNCTION = 0 : EXIT FUNCTION
'
CASE 122 ' undo latest sort
EnableMenuItem hPopUp1, 122, %MF_GRAYED
ARRAY SORT indx(1) FOR Rhigh, TAGARRAY DataRowsGlobal()
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
'
END SELECT
'
FUNCTION = 0 : EXIT FUNCTION
'
CASE %WM_DESTROY
'
IF hGrayPen THEN DeleteObject hGrayPen
IF hLightGrayPen THEN DeleteObject hLightGrayPen
IF hFontGlobal THEN DeleteObject hFontGlobal
IF hFatFont THEN DeleteObject hFatFont
IF memDCgr THEN DeleteDC memDCgr
IF hBitGr THEN DeleteObject hBitGr
IF hBrushGr THEN DeleteObject hBrushGr
IF hBrushHd THEN DeleteObject hBrushHd
IF hCursorCellBrush THEN DeleteObject hCursorCellBrush
IF hSelCellsBrush THEN DeleteObject hSelCellsBrush
'
FUNCTION = 0 : EXIT FUNCTION
END SELECT
' Pass unprocessed messages on to the default handler
FUNCTION = DefWindowProc(CBHNDL, CBMSG, CBWPARAM, CBLPARAM)
'
END FUNCTION
'
CALLBACK FUNCTION SubClassEditKeys
' Subclass callback function for processing key messages for edit control.
LOCAL res AS DWORD, i&,j&,k&,t$
'
SELECT CASE CBMSG
'
CASE %WM_CHAR
SELECT CASE CBWPARAM ' Holds the code.
' Specify what action should be taken.
CASE %VK_RETURN,%VK_LINEFEED ' End editing of cell and move one cell down
CALL FinishEdit
IF ISFALSE HeadEditFlagGlobal AND RowHeaderEditFlagGlobal <> 2 THEN
RowHeaderEditFlagGlobal = 0
VScrollNotifyGlobal = %SB_LINEDOWN ': INCR EditRowGlobal
IF ISFALSE AnchorGlobal THEN SendMessage hGridGlobal&,%WM_VSCROLL,MAKLNG(VScrollNotifyGlobal,0),0
END IF
HeadEditFlagGlobal = 0 : RowHeaderEditFlagGlobal = 0 : EXIT FUNCTION
CASE %VK_TAB ' End editing of cell and move one cell right
CALL FinishEdit
IF ISFALSE HeadEditFlagGlobal AND RowHeaderEditFlagGlobal <> 2 THEN
RowHeaderEditFlagGlobal = 0
HScrollNotifyGlobal = %SB_LINERIGHT ': INCR EditCol
IF ISFALSE AnchorGlobal THEN SendMessage hGridGlobal&,%WM_HSCROLL,MAKLNG(HScrollNotifyGlobal,0),0
END IF
HeadEditFlagGlobal = 0 : RowHeaderEditFlagGlobal = 0 : EXIT FUNCTION
CASE %VK_ESCAPE ' Cancel edit: leave original cell text unchanged
EditFlagGlobal = 0 : CorrectFlagGlobal = 0 : HeadEditFlagGlobal = 0 : RowHeaderEditFlagGlobal = 0
ShowWindow hEditGlobal&, %SW_HIDE
SetFocus hGridGlobal&
InvalidateRect hGridGlobal&,BYVAL %NULL, %FALSE
EXIT FUNCTION
CASE ELSE ' No action to be taken here for characters. They are being taken care of within the edit control.
END SELECT
'
CASE %WM_KEYDOWN
SELECT CASE CBWPARAM
CASE %VK_DELETE,%VK_LEFT,%VK_RIGHT
CASE ELSE
IF ISTRUE HeadEditFlagGlobal OR RowHeaderEditFlagGlobal = 1 THEN FUNCTION = 0 : EXIT FUNCTION
END SELECT
VScrollNotifyGlobal = -1 : HScrollNotifyGlobal = -1
SELECT CASE CBWPARAM
CASE %VK_DELETE
IF ISTRUE CorrectFlagGlobal THEN ' Remove character right of caret
res = SendMessage(hEditGlobal, %EM_GETSEL, 0, 0)
j = HIWRD(res) ' Caret position
CONTROL GET TEXT hGridGlobal&,%ID_EDITCHILD TO t
t = LEFT$(t,j)+MID$(t,j+2)
CONTROL SET TEXT hGridGlobal&,%ID_EDITCHILD,t
SendMessage hEditGlobal, %EM_SETSEL, j,j ' Reset caret
FUNCTION = 0 : EXIT FUNCTION
END IF
CASE %VK_UP : VScrollNotifyGlobal = %SB_LINEUP
CASE %VK_DOWN : VScrollNotifyGlobal = %SB_LINEDOWN
CASE %VK_LEFT
IF ISTRUE CorrectFlagGlobal THEN ' Move caret left
res = SendMessage(hEditGlobal, %EM_GETSEL, 0, 0)
j = MAX(HIWRD(res)-1,0) ' Caret is at the (upper limit of the) selection
SendMessage hEditGlobal, %EM_SETSEL, j,j ' Set caret at new position
FUNCTION = 0 : EXIT FUNCTION
ELSE ' Move to next cell to the left
HScrollNotifyGlobal = %SB_LINELEFT
END IF
CASE %VK_RIGHT
IF ISTRUE CorrectFlagGlobal THEN ' Move caret right
k = SendMessage(hEditGlobal, %EM_LINELENGTH, 0, 0)
res = SendMessage(hEditGlobal, %EM_GETSEL, 0, 0)
j = MIN(HIWRD(res)+1,k)
SendMessage hEditGlobal, %EM_SETSEL, j,j
FUNCTION = 0 : EXIT FUNCTION
ELSE ' Move to next cell to the right
HScrollNotifyGlobal = %SB_LINERIGHT
END IF
CASE %VK_PRIOR : VScrollNotifyGlobal = %SB_PAGEUP
CASE %VK_NEXT : VScrollNotifyGlobal = %SB_PAGEDOWN
CASE %VK_HOME : VScrollNotifyGlobal = %SB_TOP : HScrollNotifyGlobal = %SB_LEFT
CASE %VK_END : VScrollNotifyGlobal = %SB_BOTTOM : HScrollNotifyGlobal = %SB_RIGHT
CASE ELSE : FUNCTION = 0 : EXIT FUNCTION
END SELECT
'
IF VScrollNotifyGlobal > -1 AND ISFALSE AnchorGlobal THEN SendMessage hGridGlobal&,%WM_VSCROLL,MAKLNG(VScrollNotifyGlobal,0),0
IF HScrollNotifyGlobal > -1 AND ISFALSE AnchorGlobal THEN SendMessage hGridGlobal&,%WM_HSCROLL,MAKLNG(HScrollNotifyGlobal,0),0
'
END SELECT
' Pass the message on to the original window procedure.
FUNCTION = CallWindowProc(gOldSubClassEditGlobal&, CBHNDL, CBMSG, CBWPARAM, CBLPARAM)
END FUNCTION
'
SUB FinishEdit
LOCAL t AS STRING
CONTROL GET TEXT hGridGlobal&,%ID_EDITCHILD TO t
IF ISTRUE HeadEditFlagGlobal THEN
DataRowsGlobal(0) = ReplaceFields(DataRowsGlobal(0), t, HeadColGlobal+1, $TAB)
ELSEIF RowHeaderEditFlagGlobal = 1 THEN
DataRowsGlobal(EditRowGlobal) = ReplaceFields(DataRowsGlobal(EditRowGlobal), t, 1, $TAB)
RowHeaderEditFlagGlobal = 2
ELSE
DataRowsGlobal(SelectEndRowGlobal) = ReplaceFields(DataRowsGlobal(SelectEndRowGlobal), t, SelectEndColGlobal+1, $TAB)
END IF
t=""
SetWindowText hEditGlobal, BYVAL STRPTR(t)
EditFlagGlobal = 0
CorrectFlagGlobal = 0
SendMessage hEditGlobal&,%WM_SETFONT,hFontGlobal,MAKLNG(%TRUE,0) ' normal font (default)
ShowWindow hEditGlobal&, %SW_HIDE
SetFocus hGridGlobal&
SendMessage hGridGlobal, %WM_USER + 402, 0, 0
InvalidateRect hGridGlobal&,BYVAL %NULL, %FALSE
UpdateWindow hGridGlobal&
END SUB
'
FUNCTION CreateGrid(BYVAL hDlg AS LONG, BYVAL ID AS LONG, _
BYVAL Xp AS LONG, BYVAL Yp AS LONG, _
BYVAL W AS LONG, BYVAL H AS LONG, _
BYVAL UNflag AS LONG) AS LONG
LOCAL Res AS LONG,r2 AS LONG
Res = InitHeaderGridCtrl
r2 = CreateWindow("ECGRID", BYVAL 0, %WS_VISIBLE OR _
%WS_CHILD OR %WS_HSCROLL OR %WS_VSCROLL OR %WS_BORDER, _
Xp, Yp, W, H, hDlg, ID, GetModuleHandle(BYVAL %NULL), BYVAL 0)
ShowWindow r2, %SW_SHOW
UpdateWindow r2
FUNCTION = r2
END FUNCTION
'
' **************************************************************************************
' ***************** End of potential ECGrid include file *******************************
' **************************************************************************************
'
SUB About
LOCAL t AS STRING
t="Grid Control with adjustable rows and columns and many facilities (extended selection, " + _
"edit, clear undo clear, copy, paste, undo paste, column/row add, insert, delete, " + _
"undo delete, sort, undo sort) "+$CRLF+$CRLF _
+"This Code is Public Domain. Best of luck with it. "+ $CRLF+$CRLF+ _
"Coded by:"+$CRLF+$CRLF _
+"Erik Christensen"+$CRLF+$CRLF _
+"Version 1.01 December 30, 2007"
MSGBOX t, %MB_ICONINFORMATION, "About this program"
END SUB
'
SUB explain
LOCAL t AS STRING
t="This is a custom drawn grid control with no structural limits to " + _
"the number of rows and columns. Only the available memory may " + _
"impose a limit in this respect. The data are held in a one-" + _
"dimensional string array, which is manipulated using the extremely " + _
"fast built-in string functions provided by PowerBasic. This result " + _
"is a fast and effective program operation. " + $CRLF+$CRLF+ _
"Column width and row height can be adjusted: Place the mouse on a " + _
"column or row divider: the mouse pointer changes to a sizing " + _
"pointer; then you can drag the divider to increase or decrease " + _
"column width or row height." + $CRLF+$CRLF + _
"The grid is quite versatile and can be set up for your specific " + _
"purposes: For display only: set DisplayOnlyFlagGlobal to one. To " + _
"display also a cell cursor: set DisplayOnlyFlagGlobal to zero. " + _
"To provide editing and other facilities: set MenuFlagGlobal to " + _
"one. This enables display of a shortcut menu using the right mouse " + _
"button. "+ $CRLF+$CRLF + _
"Using this menu you can perform a number of additional tasks: " + _
"Columns or rows can be 1) added to the grid. "+ $CRLF+$CRLF + _
"2) Extended selection of cells can be enabled/disabled. F8 does " + _
"the same. When enabled the current cursor cell position defines a " + _
"corner of the selection rectangle. A left mouse button click or " + _
"the position after keyboard scrolling defines the opposite corner " + _
"of the selection rectangle. "+ $CRLF+$CRLF + _
"The selected cells can be 3) cleared. They can also be 4) copied " + _
"and then 5) pasted into another place of the grid. The latest " + _
"clear or paste action can be undone. "+ $CRLF+$CRLF + _
"The number of columns/rows spanned by the selection rectangle " + _
"defines the number of columns/rows that may be 6) inserted or 7) " + _
"deleted. The latest column/row deletion action may be undone. " + _
"The rows of the grid can be 8) sorted according to the column " + _
"variable marked by the cell cursor. The data can be sorted " + _
"alphabetic or numeric and ascending or descending. The latest sort " + _
"can be undone to obtain the prior sequence of rows. "+ $CRLF+$CRLF + _
"9) Cell writing can be enabled/disabled. When enabled the " + _
"characters will be displayed in the cursor cell as you enter them " + _
"like in EXCEL. The new text can be cancelled using ESC unless you " + _
"have moved to a new cell. Using F2 a cell text can be edited. " + $CRLF+$CRLF+ _
"10) Editing of headers may be enabled/disabled. When enabled text " + _
"can be edited by clicking the header. "+ $CRLF+$CRLF+ _
"This Code is Public Domain. Best of luck with it. "+ $CRLF+$CRLF+ _
"Best regards "+ $CRLF+$CRLF+ _
"Erik Christensen -------------- December 29, 2007"
MSGBOX t, %MB_ICONINFORMATION,"Information and Help: Grid Control with adjustable row and column headers"
END SUB
'
SUB GenerateDefaultData
MOUSEPTR 11
LOCAL I AS LONG
DATA "Surname","First Name","City","Age (years)","Weight (kg)","Height (cm)","Body Mass Index (BMI) (kg/m²)"
DATA "Andersen","Jones","Smith","Evans","Nielsen","Petersen"
DATA "Holmes","Burton","Monroe","Watson","Goethe","Hals"
DATA "Schiller","Rembrandt","Bonaparte","Wells","Verne","Shakespeare"
DATA "Hans","Peter","Eric","Alan","Alain","Jean"
DATA "John","William","Claude","Michael","Carl","James"
DATA "Eve","Marilyn","Claudia","Maria","Susan","Karin"
DATA "Los Angeles","New York","Washington","San Diego","San Francisco","Chicago"
DATA "Paris","London","Berlin","Copenhagen","Oslo","Stockholm"
DATA "Amsterdam","Brussels","Moscow","Saint Petersburg","Shanghai","Tokyo"
'
ColumnsGlobal = 7 ' number of columns
RowsGlobal = 100'00 ' number of rows
'
REDIM DataRowsGlobal(0 TO RowsGlobal)
DataRowsGlobal(0) = $TAB ' start with a blank in the upper left header field
' In the data set each line ends with a TAB character to ensure correct operation of the program
FOR I=1 TO ColumnsGlobal
DataRowsGlobal(0) = DataRowsGlobal(0)+READ$(I)+$TAB
NEXT
RANDOMIZE 1.634 ' ensures same data set each time you selects default data
FOR I=1 TO RowsGlobal
DataRowsGlobal(I)=DataRowsGlobal(I)+$TAB+READ$(RND(8,25))+$TAB ' the first tab character means that the
DataRowsGlobal(I)=DataRowsGlobal(I)+READ$(RND(26,43))+$TAB
DataRowsGlobal(I)=DataRowsGlobal(I)+READ$(RND(44,61))+$TAB
DataRowsGlobal(I)=DataRowsGlobal(I)+LTRIM$(STR$(RND(10,100)))+$TAB
DataRowsGlobal(I)=DataRowsGlobal(I)+LTRIM$(STR$(RND(50,130)))+$TAB
DataRowsGlobal(I)=DataRowsGlobal(I)+LTRIM$(STR$(RND(160,210)))+$TAB
DataRowsGlobal(I)=DataRowsGlobal(I)+LTRIM$(STR$(ROUND(VAL(PARSE$(DataRowsGlobal(I),$TAB,6))*10000/VAL(PARSE$(DataRowsGlobal(I),$TAB,7))^2,1)))+$TAB
NEXT
MOUSEPTR 1
END SUB
'
FUNCTION FilNameSave(BYREF PAFUout AS STRING, BYREF PAFU AS STRING) AS LONG
' This is set up to save in TAB-separated text file format, each line being terminated with $CRLF
' ***********************************************************************************************
LOCAL Path AS STRING
LOCAL f AS STRING
LOCAL LSTYLE AS DWORD
LOCAL hFile AS LONG
LOCAL res AS LONG
LOCAL FileString AS STRING
LOCAL ECode AS LONG
LOCAL i AS LONG
PAFUout=""
igen:
Path=LEFT$(PAFU, INSTR(-1, PAFU, ANY "/:\"))
f=""
LSTYLE = %OFN_HIDEREADONLY OR %OFN_LONGNAMES
IF SaveFileDialog(0, "Save File", f, Path, _
"Text Files|*.txt|All Files|*.*", "txt", LSTYLE) THEN
PAFUout=f
IF PAFU=PAFUout THEN
res = MSGBOX ("Output file name the same as input file name. Do you want this ?",%MB_ICONHAND OR %MB_YESNO, "Problem:")
IF res = %IDNO THEN GOTO igen
END IF
FOR i = 0 TO ColumnsGlobal
DataRowsGlobal(i) = LEFT$(DataRowsGlobal(i), LEN(DataRowsGlobal(i)) - 1) ' remove the end TAB character
DataRowsGlobal(i) = ReplaceFields(DataRowsGlobal(i), "", 1, $TAB) ' remove any row header
NEXT
FileString = JOIN$(DataRowsGlobal(), $CRLF)
hFile = FREEFILE
OPEN PAFUout FOR BINARY AS hFile
ECode = ERRCLEAR : IF Ecode THEN MSGBOX "Error on File, code=" & STR$(Ecode) : GOTO exit2
PUT$ hFile, FileString
ECode = ERRCLEAR : IF Ecode THEN MSGBOX "Error on File, code=" & STR$(Ecode) : CLOSE #hFile: GOTO exit2
SETEOF hFile
ECode = ERRCLEAR : IF Ecode THEN MSGBOX "Error on File, code=" & STR$(Ecode) : CLOSE #hFile: GOTO exit2
CLOSE hFile
FUNCTION = 1 : EXIT FUNCTION
END IF
exit2:
FUNCTION = 0
END FUNCTION
'
FUNCTION FilNameOpen(BYREF PAFUout AS STRING, BYREF PAFU AS STRING) AS LONG
' This is set up to read TAB-separated text files, where each line (or record) is terminated with $CRLF
' *****************************************************************************************************
LOCAL Path AS STRING
LOCAL f AS STRING
LOCAL LSTYLE AS DWORD
LOCAL hFile AS LONG
LOCAL Ecode AS LONG, FileString AS STRING
Path = CURDIR$
f = "*.TXT"
LSTYLE = %OFN_FILEMUSTEXIST OR %OFN_HIDEREADONLY OR %OFN_LONGNAMES
IF OpenFileDialog(0, "Open File", f, Path, _
"Text Files|*.txt|All Files|*.*", "txt", LSTYLE) THEN
PAFU=f
hFile = FREEFILE
ON ERROR RESUME NEXT
OPEN PAFU FOR BINARY AS #hFile
ECode = ERRCLEAR : IF Ecode THEN MSGBOX "Error on File, code=" & STR$(Ecode) : GOTO exit1
GET$ #hFile, LOF(hFile), FileString
ECode = ERRCLEAR : IF Ecode THEN MSGBOX "Error on File, code=" & STR$(Ecode) : CLOSE #hFile: GOTO exit1
CLOSE #hFile
RowsGlobal = PARSECOUNT(FileString, $CRLF) - 1 ' subtract one because first row is occupied by column headers
REDIM DataRowsGlobal(0 TO RowsGlobal)
REPLACE $CRLF WITH $TAB+$CRLF IN FileString ' insert an extra TAB$ before each $CRLF (at the end of each data-row)
' to ensure correct operation of the program
PARSE FileString, DataRowsGlobal(), $CRLF
ColumnsGlobal = PARSECOUNT(DataRowsGlobal(0), $TAB) - 2 ' subtract one because first column is occupied by row headers
' ' and subtract one more, which was added in the replace statement above
FUNCTION = 1 : EXIT FUNCTION
END IF
exit1:
FUNCTION = 0
END FUNCTION
'
' **************************************************************************************
' ***************************************************************************************
'
%IDD_DIALOG1 = 101
%IDR_MENU1 = 102
%IDM_FILE_LOADDEFAULTDATA = 1001
%IDM_FILE_OPENFILE = 1002
%IDM_FILE_SAVEFILEAS = 1003
%IDM_FILE_EXIT = 1004
%IDM_HELP_HELP = 1006
%IDM_HELP_ABOUT = 1007
%IDM_DISPLAY_ONLY = 1008
%IDM_CELL_CURSOR = 1009
%IDM_SHORTCUT_MENU = 1010
%IDM_ROW_HEADER = 1011
'
%IDD_DIALOG3 = 301
%IDC_LISTBOX31 = 3001
%IDC_BUTTON31 = 3002
%IDC_LABEL31 = 3003
%IDC_OPTION31 = 3004
%IDC_OPTION32 = 3005
%IDC_LABEL32 = 3006
%IDC_BUTTON32 = 3007
'------------------------------------------------------------------------------
CALLBACK FUNCTION ShowDIALOG3Proc()
LOCAL Res AS LONG, i AS LONG
SELECT CASE AS LONG CBMSG
CASE %WM_INITDIALOG
' Initialization handler
CONTROL SET OPTION CBHNDL, %IDC_OPTION31, %IDC_OPTION31, %IDC_OPTION32
CONTROL DISABLE CBHNDL, %IDC_BUTTON32
CONTROL SET FOCUS CBHNDL, %IDC_BUTTON31
'
CASE %WM_NCACTIVATE
STATIC hWndSaveFocus AS DWORD
IF ISFALSE CBWPARAM THEN
' Save control focus
hWndSaveFocus = GetFocus()
ELSEIF hWndSaveFocus THEN
' Restore control focus
SetFocus(hWndSaveFocus)
hWndSaveFocus = 0
END IF
'
CASE %WM_COMMAND
' Process control notifications
SELECT CASE AS LONG CBCTL
'
CASE %IDC_LISTBOX31
IF CBCTLMSG = %LBN_SELCHANGE THEN
CONTROL SEND CBHNDL, %IDC_LISTBOX31, %LB_GETCURSEL, 0, 0 TO Res
IF Res>= 0 THEN CONTROL ENABLE CBHNDL, %IDC_BUTTON32
END IF
CASE %IDC_BUTTON31 ' exit
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
MOUSEPTR 11
CONTROL GET CHECK CBHNDL, %IDC_OPTION32 TO Res
IF Res = 1 THEN ' Do not use first line as column headers
INCR RowsGlobal
REDIM PRESERVE DataRowsGlobal(0 TO RowsGlobal)
ARRAY INSERT DataRowsGlobal(0), STRING$(ColumnsGlobal + 1, $TAB)
END IF
'
CONTROL SEND CBHNDL, %IDC_LISTBOX31, %LB_GETCURSEL, 0, 0 TO Res
IF Res >= 0 THEN ' use selected variable as row header
FOR i = 0 TO RowsGlobal
DataRowsGlobal(i) = ReplaceFields(DataRowsGlobal(i), PARSE$(DataRowsGlobal(i), $TAB, Res + 2), 1, $TAB)
NEXT
ELSE ' if none is selected, then blank the row header
FOR i = 0 TO RowsGlobal
DataRowsGlobal(i) = ReplaceFields(DataRowsGlobal(i), "", 1, $TAB)
NEXT
END IF
CONTROL GET CHECK CBHNDL, %IDC_OPTION31 TO Res
IF Res = 1 THEN EnableMenuItem GetMenu(GetParent(CBHNDL)), %IDM_ROW_HEADER, %MF_ENABLED
MOUSEPTR 1
'
DIALOG END CBHNDL
END IF
CASE %IDC_OPTION31 ' yes
IF CBCTLMSG = %BN_CLICKED THEN
CONTROL ENABLE CBHNDL, %IDC_LISTBOX31
CONTROL ENABLE CBHNDL, %IDC_LABEL32
END IF
CASE %IDC_OPTION32 ' no
IF CBCTLMSG = %BN_CLICKED THEN
CONTROL DISABLE CBHNDL, %IDC_LISTBOX31
CONTROL DISABLE CBHNDL, %IDC_LABEL32
CONTROL DISABLE CBHNDL, %IDC_BUTTON32
END IF
CASE %IDC_BUTTON32 ' cancel selection
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
CONTROL SEND CBHNDL, %IDC_LISTBOX31, %LB_SETCURSEL, -1, 0
CONTROL DISABLE CBHNDL, %IDC_BUTTON32
END IF
END SELECT
END SELECT
END FUNCTION
'
FUNCTION SampleListBox(BYVAL hDlg AS DWORD, BYVAL lID AS LONG) AS LONG
LOCAL i AS LONG
FOR i = 1 TO ColumnsGlobal
LISTBOX ADD hDlg, lID, "Column "+ FORMAT$(i, "####")+": "+PARSE$(DataRowsGlobal(0), $TAB, i + 1)
NEXT i
END FUNCTION
'
FUNCTION ShowDIALOG3(BYVAL hParent AS DWORD, BYVAL Flag AS LONG) AS LONG
LOCAL lRslt AS LONG
LOCAL hDlg AS DWORD
DIALOG NEW PIXELS, hParent, "Select headers", , , 378, 297, _
%WS_POPUP OR %WS_BORDER OR %WS_DLGFRAME OR %WS_CLIPSIBLINGS OR _
%WS_VISIBLE OR %DS_MODALFRAME OR %DS_3DLOOK OR %DS_NOFAILCREATE OR _
%DS_SETFONT, %WS_EX_STATICEDGE OR %WS_EX_CONTROLPARENT OR _
%WS_EX_LEFT OR %WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR, TO hDlg
CONTROL ADD LISTBOX, hDlg, %IDC_LISTBOX31, , 12, 65, 354, 149, %WS_TABSTOP OR %WS_VSCROLL, %WS_EX_CLIENTEDGE
SampleListBox hDlg, %IDC_LISTBOX31
CONTROL ADD LABEL, hDlg, %IDC_LABEL32, "2. You may also select one of the " + _
"variables above to be used as the ROW HEADER column by clicking on it.", _
48, 221, 282, 33, %WS_CHILD OR %WS_VISIBLE OR %SS_CENTER , _
%WS_EX_LEFT OR %WS_EX_LTRREADING
CONTROL ADD BUTTON, hDlg, %IDC_BUTTON31, "&Done", 300, 260, 66, 26, %WS_GROUP
CONTROL ADD LABEL, hDlg, %IDC_LABEL31, "The variables in the first line of the data are " + _
"shown below."+$CRLF+"1. Should these data be used as COLUMN HEADERS?", 12, 6, _
354, 33, %WS_CHILD OR %WS_VISIBLE OR %SS_CENTER, %WS_EX_LEFT OR _
%WS_EX_LTRREADING
' %WS_GROUP...
CONTROL ADD OPTION, hDlg, %IDC_OPTION31, "&Yes", 114, 39, 60, 26, _
%WS_CHILD OR %WS_VISIBLE OR %WS_GROUP OR %WS_TABSTOP OR %BS_TEXT OR _
%BS_AUTORADIOBUTTON OR %BS_LEFT OR %BS_VCENTER, %WS_EX_LEFT OR _
%WS_EX_LTRREADING
' %WS_GROUP...
CONTROL ADD OPTION, hDlg, %IDC_OPTION32, "&No", 222, 39, 54, 26, _
%WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR %BS_TEXT OR _
%BS_AUTORADIOBUTTON OR %BS_LEFT OR %BS_VCENTER, %WS_EX_LEFT OR _
%WS_EX_LTRREADING
CONTROL ADD BUTTON, hDlg, %IDC_BUTTON32, "&Cancel any selection of a row " + _
"header", 12, 260, 270, 26
IF ISTRUE Flag THEN
CONTROL DISABLE hDlg, %IDC_LABEL31
CONTROL DISABLE hDlg, %IDC_OPTION31
CONTROL DISABLE hDlg, %IDC_OPTION32
DIALOG SET TEXT hDlg, "Select a (new) row header"
CONTROL SET TEXT hDlg, %IDC_LABEL32, "Select one of the " + _
"variables above to be used as the ROW HEADER column by clicking on it."
END IF
DIALOG SHOW MODAL hDlg, CALL ShowDIALOG3Proc TO lRslt
FUNCTION = lRslt
END FUNCTION
'
' ***************************************************************************************
'
CALLBACK FUNCTION ShowDIALOG1Proc()
STATIC rc AS RECT, res AS LONG, i AS LONG, j AS LONG
STATIC hMenu AS DWORD
STATIC hPopUp1 AS DWORD
STATIC PAFUout AS STRING, PAFU AS STRING
STATIC hText AS LONG
SELECT CASE AS LONG CBMSG
CASE %WM_INITDIALOG
' Adapt window to Work Area on screen (desktop).
SystemParametersInfo %SPI_GETWORKAREA, 0, BYVAL VARPTR(Rc), 0
MoveWindow CBHNDL, Rc.nLeft, Rc.nTop, Rc.nRight - Rc.nLeft, Rc.nBottom - Rc.nTop, 0
GetClientRect CBHNDL, Rc
hGridGlobal& = CreateGrid(CBHNDL, %FORM1_GRID, 15, 0, Rc.nRight - 300, Rc.nBottom - 300, 0)
hStaticGlobal = CreateWindowEx(0, "STATIC", BYVAL 0, %WS_VISIBLE OR _
%WS_CHILD, 18,10, Rc.nRight - 36, 19, CBHNDL, %FORM1_STATIC, GetModuleHandle(BYVAL %NULL), BYVAL 0)
'
MENU NEW BAR TO hMenu
MENU NEW POPUP TO hPopUp1
MENU ADD POPUP, hMenu, "&File", hPopUp1, %MF_ENABLED
MENU ADD STRING, hPopUp1, "Load &Default Data", _
%IDM_FILE_LOADDEFAULTDATA, %MF_ENABLED
MENU ADD STRING, hPopUp1, "&Open File", %IDM_FILE_OPENFILE, _
%MF_ENABLED
MENU ADD STRING, hPopUp1, "&Save File As", %IDM_FILE_SAVEFILEAS, _
%MF_ENABLED
MENU ADD STRING, hPopUp1, "-", 0, 0
MENU ADD STRING, hPopUp1, "E&xit", %IDM_FILE_EXIT, %MF_ENABLED
MENU NEW POPUP TO hPopUp1
MENU ADD POPUP, hMenu, "&Options", hPopUp1, %MF_ENABLED
MENU ADD STRING, hPopUp1, "&Display Only", %IDM_DISPLAY_ONLY, %MF_ENABLED
MENU ADD STRING, hPopUp1, "-", 0, 0
MENU ADD STRING, hPopUp1, "Display Only and Cell &Cursor", %IDM_CELL_CURSOR, %MF_ENABLED
MENU ADD STRING, hPopUp1, "-", 0, 0
MENU ADD STRING, hPopUp1, "Shortcut &Menu", %IDM_SHORTCUT_MENU, %MF_ENABLED
MENU ADD STRING, hPopUp1, "-", 0, 0
MENU ADD STRING, hPopUp1, "Select another &Row Header", %IDM_ROW_HEADER, %MF_GRAYED
MENU NEW POPUP TO hPopUp1
MENU ADD POPUP, hMenu, "&Help", hPopUp1, %MF_ENABLED
MENU ADD STRING, hPopUp1, "&Help", %IDM_HELP_HELP, %MF_ENABLED
MENU ADD STRING, hPopUp1, "-", 0, 0
MENU ADD STRING, hPopUp1, "&About", %IDM_HELP_ABOUT, %MF_ENABLED
MENU ATTACH hMenu, CBHNDL
'
' DisplayOnlyFlagGlobal = 1 ' No cursor field is displayed and no shortcut menu can be elicited
' IF ISTRUE DisplayOnlyFlagGlobal THEN MenuFlagGlobal = 0
'
DisplayOnlyFlagGlobal = 0 ' A cursor field is displayed
MenuFlagGlobal = 1 ' A shortcut menu can be elicited
CheckMenuItem hMenu, %IDM_DISPLAY_ONLY, %MF_UNCHECKED
CheckMenuItem hMenu, %IDM_CELL_CURSOR, %MF_UNCHECKED
CheckMenuItem hMenu, %IDM_SHORTCUT_MENU, %MF_CHECKED
'
CASE %WM_NCACTIVATE
STATIC hWndSaveFocus AS DWORD
IF ISFALSE CBWPARAM THEN
' Save control focus
hWndSaveFocus = GetFocus()
ELSEIF hWndSaveFocus THEN
' Restore control focus
SetFocus(hWndSaveFocus)
hWndSaveFocus = 0
END IF
'
CASE %WM_DESTROY
PostQuitMessage 0
'
CASE %WM_COMMAND
' Process control notifications
SELECT CASE AS LONG CBCTL
'
CASE %IDM_FILE_LOADDEFAULTDATA
CALL GenerateDefaultData
CALL ShowDIALOG3(CBHNDL, 0)
SendMessage hGridGlobal, %WM_USER + 401, 0, 0
'
CASE %IDM_FILE_OPENFILE
res = FilNameOpen(PAFUout, PAFU)
CALL ShowDIALOG3(CBHNDL, 0)
SendMessage hGridGlobal, %WM_USER + 401, 0, 0
'
CASE %IDM_FILE_SAVEFILEAS
res = FilNameSave(PAFUout, PAFU)
'
CASE %IDM_FILE_EXIT : DIALOG END CBHNDL
'
CASE %IDM_HELP_HELP : CALL Explain
'
CASE %IDM_HELP_ABOUT : CALL About
'
CASE %IDM_DISPLAY_ONLY
DisplayOnlyFlagGlobal = 1 ' No cursor field is displayed and no shortcut menu can be elicited
MenuFlagGlobal = 0
CheckMenuItem hMenu, %IDM_DISPLAY_ONLY, %MF_CHECKED
CheckMenuItem hMenu, %IDM_CELL_CURSOR, %MF_UNCHECKED
CheckMenuItem hMenu, %IDM_SHORTCUT_MENU, %MF_UNCHECKED
CONTROL SET TEXT CBHNDL, %FORM1_STATIC, SPACE$(100)
InvalidateRect hGridGlobal&,BYVAL %NULL, %FALSE
'
CASE %IDM_CELL_CURSOR
DisplayOnlyFlagGlobal = 0 ' A cursor field is displayed but no shortcut menu can be elicited
MenuFlagGlobal = 0
CheckMenuItem hMenu, %IDM_DISPLAY_ONLY, %MF_UNCHECKED
CheckMenuItem hMenu, %IDM_CELL_CURSOR, %MF_CHECKED
CheckMenuItem hMenu, %IDM_SHORTCUT_MENU, %MF_UNCHECKED
CONTROL SET TEXT CBHNDL, %FORM1_STATIC, SPACE$(100)
InvalidateRect hGridGlobal&,BYVAL %NULL, %FALSE
'
CASE %IDM_SHORTCUT_MENU
DisplayOnlyFlagGlobal = 0 ' A cursor field is displayed and a shortcut menu can be elicited
MenuFlagGlobal = 1
CheckMenuItem hMenu, %IDM_DISPLAY_ONLY, %MF_UNCHECKED
CheckMenuItem hMenu, %IDM_CELL_CURSOR, %MF_UNCHECKED
CheckMenuItem hMenu, %IDM_SHORTCUT_MENU, %MF_CHECKED
InvalidateRect hGridGlobal&,BYVAL %NULL, %FALSE
'
CASE %IDM_ROW_HEADER
CALL ShowDIALOG3(CBHNDL, 1)
InvalidateRect hGridGlobal&,BYVAL %NULL, %FALSE
'
END SELECT
'
END SELECT
END FUNCTION
'
FUNCTION PBMAIN()
LOCAL lRslt AS LONG
LOCAL hDlg AS DWORD
LOCAL Msg AS tagMSG
DIALOG NEW PIXELS, %HWND_DESKTOP, "Grid Control with adjustable row and column headers", _
105, 114, 751, 564, %WS_POPUP OR %WS_BORDER OR %WS_DLGFRAME OR _
%WS_SYSMENU OR %WS_MINIMIZEBOX OR %WS_CLIPSIBLINGS OR %WS_VISIBLE OR _
%DS_MODALFRAME OR %DS_3DLOOK OR %DS_NOFAILCREATE OR %DS_SETFONT OR %WS_THICKFRAME, _
%WS_EX_CONTROLPARENT OR %WS_EX_LEFT OR %WS_EX_LTRREADING OR _
%WS_EX_RIGHTSCROLLBAR , TO hDlg
DIALOG SHOW MODELESS hDlg, CALL ShowDIALOG1Proc TO lRslt
' This Windows type message pump is necessary for correct operation of this program
WHILE GetMessage(Msg, %NULL, 0, 0)
TranslateMessage Msg
DispatchMessage Msg
WEND
FUNCTION = lRslt
END FUNCTION
Comment