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: ' 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 #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