Code: Select all
' Header based virtual grid control with cell editing for FreeBasic based on Erik Christensen post
' on powerbasic forum
' This version of the header based virtual grid control enables you to
' edit individual cells as well as column and row headers. Like in
' Excel new text is placed in the selected cell just by typing the text
' on the keyboard. You end entering new text by pressing ENTER, TAB, by
' moving the selected cell or by scrolling. Before ending you may
' retrieve the old text by pressing ESCAPE. In harmony with Excel you
' can perform full editing of a cell by pressing function key 2 (F2).
' When editing is started in this way you can insert and delete
' characters in any position.
'
' Editing of column and row headers is started by a mouse click. Full
' editing is always possible and editing needs to be ended by pressing
' ENTER or TAB. This arrangement makes it more difficult to
' accidentally change the headers.
'
' In this version you can import files from Excel and other similar
' programs if the files have been saved in TAB-separated text format.
' You can also save the data in the grid control in TAB-separated text
' format, which can be imported in Excel and most other programs.
'
' Thanks to the PowerBasic Forum for great inspiration. If you find
' any blunders or have comments, please let me know. :-)
'
'--------------------------------------------------------------
#INCLUDE Once "windows.bi"
#INCLUDE Once "win/COMMCTRL.bi"
#include once "win/commdlg.bi"
#Include Once "vbcompat.bi"
#Define VK_LINEFEED &H0A
Const BLACK = 0
CONST BLUE = 16711680
CONST GREEN = 65280
CONST CYAN = 16776960
CONST RED = 255
CONST PINK = 8388736
CONST YELLOW = 65535
CONST WHITE = 16777215
CONST GRAY = 8421504
CONST LTGRAY = &hFFD3D3D3
Const MAGENTA = &HAA00AA
CONST DARKBLUE = 8388608
CONST DARKGREEN = 32768
CONST DARKCYAN = 8421376
CONST DARKRED = 128
CONST BROWN = 32896
CONST DARKGRAY = 8421504
CONST LIGHTGRAY = 12632256
Const LIGHT_RED = &HFF5555
Const LIGHT_MAGENTA = &HFF55FF
CONST DARKPINK = 8388736
Sub CONTROL_GET_TEXT OverLoad (BYVAL hndl AS HWND, BYVAL IDctrl AS LONG, ByRef text AS STRING)
Dim As Integer tmpint
tmpint = 1 + GetWindowTextLength(GetDlgItem(hndl,IDctrl))
Dim strtmp As ZString ptr
strtmp=Allocate(tmpint*SizeOf(ZString))
GetWindowText(GetDlgItem(hndl,IDctrl),strtmp,tmpint)
text=*strtmp
End Sub
Function CONTROL_GET_TEXT (BYVAL hndl AS HWND, BYVAL IDctrl As LONG) AS String
Dim As Long tmpint
tmpint = 1 + GetWindowTextLength(GetDlgItem(hndl,IDctrl))
Dim strtmp As ZString ptr
strtmp=Allocate(tmpint*SizeOf(ZString))
GetWindowText(GetDlgItem(hndl,IDctrl),strtmp,tmpint)
return *strtmp
End Function
FUNCTION CONTROL_SET_TEXT (BYVAL hndl AS HWND, BYVAL IDctrl AS LONG, BYVAL text AS STRING) AS INTEGER
Return SetWindowText(getDlgitem(hndl,IDctrl),Text) 'SetDlgItemText(hndl,IDctrl, StrPtr(text))
End Function
FUNCTION OpenFileDialog (BYVAL hndl AS HWND, _ 'parent window
BYVAL sCaption AS STRING, _ 'caption
BYREF sFileName AS STRING, _ 'filename
BYVAL sInitialDir AS STRING, _ 'starting directory
BYVAL sFilter AS STRING, _ 'all valid filename extensions
BYVAL sDefExtension AS STRING, _ 'default extension
BYREF dFlags AS DWORD _ 'flags
) AS LONG
DIM AS OPENFILENAME ofn
DIM AS STRING szFileTitle
DIM mfilename AS ZSTRING * MAX_PATH + 1
mfilename = sFileName
IF LEN(sInitialDir) = 0 THEN sInitialDir = CURDIR$
WITH ofn
.lStructSize = SIZEOF(OPENFILENAME)
.hwndOwner = hndl
.hInstance = GetModuleHandle(NULL)
.lpstrFilter = STRPTR(sFilter)
.lpstrCustomFilter = NULL
.nMaxCustFilter = 0
.nFilterIndex = 1
.lpstrFile = @mfilename
.nMaxFile = SIZEOF(mfilename)
.lpstrFileTitle = CAST(LPTSTR, VARPTR(szFileTitle))
.nMaxFileTitle = NULL 'SIZEOF(szFileTitle)
.lpstrInitialDir = STRPTR(sInitialDir)
.lpstrTitle = STRPTR(sCaption)
.Flags = dFlags
.nFileOffset = 0
.nFileExtension = IIF(LEN(sDefExtension) = 0, LEN(mfilename), INSTR(mfilename, "." & sDefExtension) - 1)
.lpstrDefExt = NULL
.lCustData = 0
.lpfnHook = NULL
.lpTemplateName = NULL
END WITH
FUNCTION = GetOpenFileName(@ofn)
IF LEN(mfilename) THEN sFileName = mfilename
END FUNCTION
Function SaveFileDialog (BYVAL hWnd AS HWND, _ 'parent window
BYVAL sCaption AS STRING, _ 'caption
BYREF sFileName AS STRING, _ 'filename
BYVAL sInitialDir AS STRING, _ 'starting directory
BYVAL sFilter AS STRING, _ 'all valid filename extensions
BYVAL sDefExtension AS String, _ 'default extension
ByVal Flag As Integer=OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST Or OFN_EXPLORER) AS LONG
Dim ofn As OPENFILENAME
Dim AS STRING szFileTitle
DIM filename AS ZString * MAX_PATH + 1
filename = sFileName
IF LEN(sInitialDir) = 0 THEN sInitialDir = CURDIR$
ofn.lStructSize = SizeOf(ofn)
ofn.nMaxFile = SIZEOF(filename) 'ofn.nMaxFile = 2048
ofn.hwndOwner = hWnd
ofn.lpstrFile = Strptr(filename) ' ou @filename
ofn.lpstrfilter = Sadd(sfilter)
ofn.hInstance = GetModuleHandle(NULL)
ofn.nFilterIndex = 1
ofn.lpstrFileTitle = CAST(LPTSTR, VARPTR(szFileTitle))
ofn.nMaxFileTitle = NULL 'SIZEOF(szFileTitle)
ofn.lpstrInitialDir = STRPTR(sInitialDir)
ofn.lpstrTitle = STRPTR(sCaption)
ofn.nFileOffset = 0
ofn.nFileExtension = IIF(LEN(sDefExtension) = 0, LEN(filename), INSTR(filename, "." & sDefExtension) - 1)
ofn.lpstrDefExt = NULL
ofn.lCustData = 0
ofn.lpfnHook = NULL
ofn.lpTemplateName = NULL
ofn.Flags = flag
FUNCTION =GetSaveFileName(@ofn)
IF LEN(filename) THEN sFileName = filename
End Function
'******************************************************************************
'** Potential Include File Part ***********************************************
'******************************************************************************
'--------------------------------------------------------
Const FORM1_HEADER = 130
Const FORM1_GRID = 135
Const ID_EDITCHILD = 140
DIM SHARED hGrid As HWND ' Handle of grid control
DIM Shared hHead As HWND ' Handle of header control of grid control
DIM Shared hEdit As HWND ' Handle of edit control in grid
DIM Shared Rows AS LONG ' Total number of rows in array
DIM Shared Columns AS LONG ' Total number of columns in array
DIM Shared DataArray() AS STRING ' Two dimensional text array to be displayed
DIM Shared ColWidth() AS LONG ' Array to hold the column widths
DIM Shared HeaderHeight AS LONG ' Height of header control
DIM Shared LineHeight AS LONG ' Height of one line in grid control
DIM Shared gOldSubClassEdit As WNDPROC
DIM Shared SelectCol AS LONG
DIM Shared SelectRow AS LONG
DIM Shared VScrollNotify AS WORD
DIM Shared HScrollNotify AS WORD
DIM Shared EditFlag AS LONG
DIM Shared CorrectFlag AS LONG
DIM Shared HeadEditFlag AS LONG
DIM Shared RowHeaderEditFlag AS LONG
DIM Shared HeadCol AS LONG
DIM Shared EditRow AS LONG
DIM Shared hFont AS HFONT
DIM Shared siX AS SCROLLINFO
declare FUNCTION GridCallBack(hwnd As HWND, Msg As UINT,wparam As WPARAM,lparam as LPARAM)As LRESULT
Declare FUNCTION SubClassEditKeys (hwnd As HWND, Msg As UINT,wparam As WPARAM,lparam as LPARAM)As LRESULT
Declare SUB FinishEdit
FUNCTION MakeFont(BYVAL FontTypeSize AS LONG,BYVAL FontWeight AS LONG, _
BYVAL Italic AS LONG, BYVAL Underline AS LONG,BYVAL StrikeOut AS LONG, _
BYVAL FaceName AS STRING) AS HFONT
Dim hDC As HDC,LgPixelsY As Long
Dim lfFont AS lOGFONT ' Logfont structure
hDC = GetDC(HWND_DESKTOP)
'
'Retrieves device-specific information about the number
'of pixels per logical inch along the screen height
'(depends on screen resolution setting).
'This is important to define appropriate font sizes.
LgPixelsY = GetDeviceCaps(hDC, LOGPIXELSY)
'
ReleaseDC HWND_DESKTOP, hDC
'TYPE LOGFONT defines the attributes of a font.
'See LOGFONT in the Win32 help file
lfFont.lfHeight = -MulDiv(FontTypeSize,LgPixelsY,72) ' better than: -(FontTypeSize * LgPixelsY) \ 72
' logical height of font
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
' Make font according to specifications
FUNCTION = CreateFontIndirect (@lfFont)
END FUNCTION
FUNCTION InitHeaderGridCtrl() AS LONG
DIM wc AS WNDCLASS
Dim szClassName AS ZString * 11
szClassName = "HEADERGRID"
wc.style = CS_HREDRAW OR CS_VREDRAW OR CS_DBLCLKS OR CS_GLOBALCLASS
wc.lpfnWndProc = @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 = StrPtr(szClassName)
FUNCTION = RegisterClass(@wc)
END FUNCTION
FUNCTION GridCallBack(hwnd As HWND, Msg As UINT,wparam As WPARAM,lparam as LPARAM)As LRESULT
' Callback Handle hwnd is: hGrid&
Dim szString AS ZSTRING * 256
Dim layout AS HD_LAYOUT
Dim winpos AS WINDOWPOS
STATIC headitem AS HD_ITEM
STATIC hCtr As HWND ,Res As Long
Static s AS ZString * 250
Dim hdnptr AS HD_NOTIFY PTR
Dim hdiptr AS HD_ITEM PTR
Dim MinWidth AS LONG = 40
Dim rc AS RECT
Dim As Long i,j,k,chrs,idx,M
Dim hdc As HDC
Dim rc2 AS RECT
Dim hDCgr AS HDC
Dim ColStart AS LONG
STATIC TextHeight AS LONG
Dim lpSize AS SIZEL
Dim Spacing AS LONG : Spacing = 6
Dim ps AS PAINTSTRUCT
Dim tm AS TEXTMETRIC
STATIC hFontBold AS HFONT , hFatPen AS HPEN
STATIC hGrayPen AS HPEN, hLightGrayPen AS HPEN
STATIC memDCgr AS HDC, hBitGr AS HBITMAP
STATIC siY AS SCROLLINFO
STATIC ptsCursor AS POINT
STATIC PageRows AS LONG ' Number of rows on a page
STATIC PageColumns AS LONG ' Number of columns on a page
STATIC As Long CellFlag , ColFlag , RowFlag
STATIC As Long x1 ,y1 ,x2 ,y2
'
SELECT CASE Msg
CASE WM_CREATE
'
' Create Header and set its font.
IF 0=hHead THEN
hHead = CreateWindow("SysHeader32",BYVAL 0, WS_CHILD OR WS_BORDER _
Or HDS_BUTTONS,0,0,0,0,hwnd,Cast(HMENU,FORM1_HEADER), _
GetModuleHandle(NULL), BYVAL NULL)
hFontBold = MakeFont(8,FW_BOLD,0,0,0,"MS Sans Serif")
SendMessage hHead,WM_SETFONT,Cast(WPARAM,hFontBold),MAKELONG(TRUE,0)
hFont = MakeFont(8,FW_NORMAL,0,0,0,"MS Sans Serif")
hGrayPen = CreatePen(PS_SOLID, 0, GRAY)
hLightGrayPen = CreatePen(PS_SOLID, 0, LTGRAY)
hFatPen = CreatePen(PS_SOLID, 3, BLACK)
' Insert items into the header
headitem.mask = HDI_FORMAT OR HDI_WIDTH OR HDI_TEXT
headitem.fmt = HDF_STRING OR HDF_LEFT
FOR i = 0 TO MIN(20, Columns)
s="" : IF i>0 THEN s = FORMAT$(i )+" "
IF i <Columns THEN s = s + DataArray(i ,0)
headitem.pszText = StrPtr(s)
headitem.cchTextMax = LEN(headitem.pszText)
headitem.cxy = ColWidth(i )
Header_InsertItem( hHead , i , @headitem)
NEXT
ShowWindow hHead, SW_SHOW
ELSE
' Update header
FOR i = 0 TO MIN(20, Columns)
IF i>=Columns THEN
s =" "
headitem.cxy = 2000 ' set very wide extra column
ELSE
s="" : IF i>0 THEN s = FORMAT$(i)+" "
s = s + DataArray(i,0)
headitem.cxy = ColWidth(i)
END IF
headitem.pszText = StrPtr(s)
headitem.cchTextMax = LEN(*headitem.pszText)
SendMessage( hHead, HDM_SETITEM, i, cast(LPARAM,@headitem))
NEXT
END IF
'
IF 0=memDCgr THEN
' Create a virtual window for grid
hDCgr = GetDC(hwnd)
memDCgr = CreateCompatibleDC(hDCgr)
hBitGr = CreateCompatibleBitmap(hDCgr,Rc.Right,Rc.Bottom)
SelectObject memDCgr, hBitGr
SelectObject memDCgr, hFont
GetTextMetrics memDCgr, @tm
LineHeight = tm.tmHeight + tm.tmInternalLeading
Res = PatBlt(memDCgr, 0, 0, Rc.Right, Rc.Bottom, PATCOPY)
END IF
'
IF 0=hEdit THEN
' Create edit control
hEdit = CreateWindow("EDIT",BYVAL NULL,WS_CHILD OR ES_AUTOHSCROLL, _
0, 0, 0, 0,hwnd,Cast(HMENU,ID_EDITCHILD), _
Cast(HINSTANCE,GetWindowLong(hwnd,GWL_HINSTANCE)),BYVAL NULL)
SendMessage hEdit,WM_SETFONT,Cast(WPARAM,hFont),MAKELONG(TRUE,0)
' Subclass Edit Control
gOldSubClassEdit = Cast(WNDPROC,SetWindowLong(hEdit, GWL_WNDPROC, Cast(DWORD,@SubClassEditKeys)))
END IF
'
SelectRow = 1 : SelectCol = 1 ' Initial position of selection rectangle.
'
' Define vertical scrollbar
siY.cbSize = SIZEOF(siY)
siY.fMask = SIF_ALL ' = SIF_RANGE OR SIF_PAGE OR SIF_POS OR SIF_TRACKPOS
siY.nMin = 1
siY.nMax = Rows
siY.nPage = PageRows
siY.nPos = 1
Res = SetScrollInfo(hwnd, SB_VERT, @siY, TRUE)
'
' Define horizontal scrollbar
siX.cbSize = SIZEOF(siX)
siX.fMask = SIF_ALL
siX.nMin = 0
siX.nMax = Columns
siX.nPage = PageColumns
siX.nPos = 0
Res = SetScrollInfo(hwnd, SB_HORZ, @siX, TRUE)
'
SetFocus hwnd
InvalidateRect hwnd, BYVAL NULL , FALSE
CASE WM_VSCROLL
SetFocus hwnd
IF 0<>EditFlag THEN FinishEdit
HeadEditFlag = FALSE
SELECT CASE LoWord(wparam)
CASE SB_TOP : siY.nPos = siY.nMin : IF VScrollNotify = SB_TOP THEN SelectRow = siY.nMin
CASE SB_BOTTOM : siY.nPos = siY.nMax : IF VScrollNotify = SB_BOTTOM THEN SelectRow = siY.nMax
CASE SB_LINEDOWN
IF VScrollNotify = SB_LINEDOWN THEN ' Down key pressed
IF SelectRow < Rows THEN SelectRow+=1
IF SelectRow > siY.nPos + siY.nPage - 1 THEN siY.nPos+=1
ELSE ' Scroll bar clicked
siY.nPos +=1
END IF
CASE SB_LINEUP
IF VScrollNotify = SB_LINEUP THEN ' Up key pressed
IF SelectRow > 1 THEN SelectRow-=1
IF SelectRow < siY.nPos THEN siY.nPos-=1
ELSE ' Scroll bar clicked
siY.nPos -=1
END IF
CASE SB_PAGEDOWN
IF VScrollNotify = SB_PAGEDOWN THEN ' Page Down key pressed
IF SelectRow = siY.nPos + siY.nPage - 1 THEN ' On the last visible line
siY.nPos = siY.nPos + siY.nPage - 1
SelectRow = siY.nPos + siY.nPage - 1
END IF
' Not on the last display line: then move to that.
IF SelectRow < siY.nPos + siY.nPage - 1 THEN SelectRow = siY.nPos + siY.nPage - 1
SelectRow = MIN(SelectRow, siY.nMax)
ELSE ' Scroll bar clicked
siY.nPos = siY.nPos + siY.nPage - 1
END IF
CASE SB_PAGEUP
IF VScrollNotify = SB_PAGEUP THEN ' Page Up key pressed
IF SelectRow = siY.nPos THEN ' On the first visible line
siY.nPos = siY.nPos - siY.nPage + 1
SelectRow = siY.nPos
END IF
' Not on the first display line: then move to that.
IF SelectRow > siY.nPos THEN SelectRow = siY.nPos
SelectRow = MAX(SelectRow, siY.nMin)
ELSE ' Scroll bar clicked
siY.nPos = siY.nPos - siY.nPage + 1
END IF
CASE SB_THUMBTRACK
Res = GetScrollInfo(hwnd, SB_VERT, @siY)
siY.nPos = siY.nTrackPos
CASE ELSE : EXIT FUNCTION
END SELECT
VScrollNotify = -1
' Ensure that position is within range
siY.nPos = MAX&(siY.nMin, MIN&(siY.nPos, siY.nMax - siY.nPage + 1))
' Update vertical scroll bar
Res = SetScrollInfo(hwnd, SB_VERT, @siY, TRUE)
GetClientRect hwnd, @rc : Rc.Top = HeaderHeight
InvalidateRect hwnd, @rc , FALSE
EXIT FUNCTION
'
CASE WM_HSCROLL
SetFocus hwnd
IF 0<>EditFlag THEN FinishEdit
HeadEditFlag = FALSE
SELECT CASE LoWord(wparam)
CASE SB_LEFT : siX.nPos = siX.nMin :IF HScrollNotify = SB_LEFT THEN SelectCol = siX.nMin +1 ' Home
CASE SB_RIGHT : siX.nPos = siX.nMax : siX.nPage = 3 : IF HScrollNotify = SB_RIGHT THEN SelectCol = siX.nMax - 1' End
CASE SB_LINELEFT
IF HScrollNotify = SB_LINELEFT THEN ' Left key pressed
IF SelectCol > 1 THEN SelectCol-=1
IF SelectCol < siX.nPos + 1 THEN siX.nPos-=1
ELSE ' Scroll bar clicked
siX.nPos-=1
END IF
CASE SB_LINERIGHT
IF HScrollNotify = SB_LINERIGHT THEN ' Right key pressed
IF SelectCol < Columns-1 THEN SelectCol+=1
IF SelectCol > siX.nPos + siX.nPage - 2 THEN siX.nPos+=1
ELSE ' Scroll bar clicked
siX.nPos+=1
END IF
CASE SB_PAGELEFT : siX.nPos = MIN(siX.nPos - siX.nPage + 2 , siX.nPos - 1)
CASE SB_PAGERIGHT : siX.nPos = MAX(siX.nPos + siX.nPage - 2 , siX.nPos + 1)
CASE SB_THUMBTRACK
Res = GetScrollInfo(hwnd, SB_HORZ, @siX)
siX.nPos = siX.nTrackPos
CASE ELSE : EXIT FUNCTION
END SELECT
HScrollNotify = -1
' Ensure that position is within range
siX.nPos = MAX&(siX.nMin, MIN&(siX.nPos, siX.nMax - siX.nPage + 1))
' Update horizontal scroll bar
Res = SetScrollInfo(hwnd, SB_HORZ, @siX, TRUE)
InvalidateRect hwnd, BYVAL NULL, FALSE
UpdateWindow hwnd
EXIT FUNCTION
'
CASE WM_CHAR ' Any character key at time of pressing
' This is the starting signal for editing a cell.
' Before starting: End any previous editing.
SetFocus hwnd
IF 0<>EditFlag THEN FinishEdit
HeadEditFlag = FALSE
SELECT CASE wparam
' 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 0=ColFlag OR 0=RowFlag THEN
IF 0=ColFlag THEN
siX.nPos = SelectCol - 1
siX.nPos = MAX&(siX.nMin, MIN&(siX.nPos, siX.nMax - siX.nPage + 1))
Res = SetScrollInfo(hwnd, SB_HORZ, @siX, TRUE)
END IF
IF 0=RowFlag THEN
siY.nPos = SelectRow
siY.nPos = MAX&(siY.nMin, MIN&(siY.nPos, siY.nMax - siY.nPage + 1))
Res = SetScrollInfo(hwnd, SB_VERT, @siY, TRUE)
END IF
InvalidateRect hwnd, BYVAL NULL, FALSE
UpdateWindow hwnd
END IF
'
' Identify character and perform relevant action.
SELECT CASE wparam
CASE VK_TAB
HScrollNotify = SB_LINERIGHT
SendMessage hwnd,WM_HSCROLL,MAKELONG(HScrollNotify,0),0
FUNCTION = 0 : EXIT FUNCTION
CASE VK_LINEFEED, VK_RETURN
VScrollNotify = SB_LINEDOWN
SendMessage hwnd,WM_VSCROLL,MAKELONG(VScrollNotify,0),0
FUNCTION = 0 : EXIT FUNCTION
CASE 32 TO 255 ' Character codes
' Move edit window to selected cell and display it there.
MoveWindow hEdit ,x1+6,y1+2,x2-x1-9,y2-y1-3,1
ShowWindow hEdit , SW_SHOW
SetFocus hEdit
' Set current character as the first in the edit control.
CONTROL_SET_TEXT hwnd,ID_EDITCHILD,CHR$(wparam)
SendMessage hEdit,EM_SETSEL,0,-1 ' Set caret
SendMessage hEdit,EM_SETSEL,-1,1 ' to end of string.
EditFlag = TRUE
END SELECT
FUNCTION = 0 : EXIT FUNCTION
'
CASE WM_KEYDOWN
SetFocus hwnd
IF 0<>EditFlag THEN FinishEdit
HeadEditFlag = FALSE
' Process arrow keys etc. for grid. hGrid& needs to have focus.
VScrollNotify = -1 : HScrollNotify = -1
SELECT CASE wparam
CASE VK_UP : VScrollNotify = SB_LINEUP
CASE VK_DOWN : VScrollNotify = SB_LINEDOWN
CASE VK_LEFT : HScrollNotify = SB_LINELEFT
CASE VK_RIGHT : HScrollNotify = SB_LINERIGHT
CASE VK_PRIOR : VScrollNotify = SB_PAGEUP
CASE VK_NEXT : VScrollNotify = SB_PAGEDOWN
CASE VK_HOME : VScrollNotify = SB_TOP : HScrollNotify = SB_LEFT
CASE VK_END : VScrollNotify = SB_BOTTOM : HScrollNotify = SB_RIGHT
'
CASE VK_F2 ' Function key F2: Activate a cell for editing
' If selected cell not in view then scroll it into view
IF 0=ColFlag OR 0=RowFlag THEN
IF 0=ColFlag THEN
siX.nPos = SelectCol - 1
siX.nPos = MAX&(siX.nMin, MIN&(siX.nPos, siX.nMax - siX.nPage + 1))
Res = SetScrollInfo(hwnd, SB_HORZ, @siX, TRUE)
END IF
IF 0=RowFlag THEN
siY.nPos = SelectRow
siY.nPos = MAX&(siY.nMin, MIN&(siY.nPos, siY.nMax - siY.nPage + 1))
Res = SetScrollInfo(hwnd, SB_VERT, @siY, TRUE)
END IF
InvalidateRect hwnd, BYVAL NULL, FALSE
UpdateWindow hwnd
END IF
'
' Move edit window to selected cell and display it there.
MoveWindow hEdit ,x1+6,y1+2,x2-x1-9,y2-y1-3,1
ShowWindow hEdit , SW_SHOW
SetFocus hEdit
' Set current cell text in the edit control.
SetWindowText hEdit, BYVAL STRPTR(DataArray(SelectCol,SelectRow))
SendMessage hEdit,EM_SETSEL,0,-1 ' Set caret
SendMessage hEdit,EM_SETSEL,-1,1 ' to end of string.
EditFlag = TRUE
CorrectFlag = TRUE
FUNCTION = 0 : EXIT FUNCTION
CASE ELSE : FUNCTION = 0 : EXIT FUNCTION
END SELECT
IF VScrollNotify > -1 THEN SendMessage hwnd,WM_VSCROLL,MAKELONG(VScrollNotify,0),0
IF HScrollNotify > -1 THEN SendMessage hwnd,WM_HSCROLL,MAKELONG(HScrollNotify,0),0
'
CASE WM_LBUTTONDBLCLK ' Not used
CASE WM_LBUTTONDOWN ' Click to place selected cell at click position
'
SetFocus hwnd
IF 0<>EditFlag THEN FinishEdit
HeadEditFlag = FALSE
'
' Get cursor position in client area.
ptsCursor.x = LoWord(lparam) : ptsCursor.y = HiWord(lparam)
'
' Get column index for cell corresponding to this point.
IF ptsCursor.x < Colwidth(0) THEN ' Row header column
' Prepare for editing of row header column cell.
SendMessage hEdit,WM_SETFONT,Cast(WPARAM,hFontBold),MAKELONG(TRUE,0)
EditRow = siY.nPos + (ptsCursor.y - HeaderHeight) \ LineHeight
' Move edit window to selected cell and display it there.
MoveWindow hEdit,3,HeaderHeight+(EditRow-siY.nPos)*LineHeight+1,Colwidth(0)-6,LineHeight-3,1
ShowWindow hEdit, SW_SHOW
SetFocus hEdit
' Set current cell text in the edit control.
SetWindowText hEdit, BYVAL STRPTR(DataArray(0,EditRow))
SendMessage hEdit,EM_SETSEL,0,-1 ' Set caret
SendMessage hEdit,EM_SETSEL,-1,1 ' to end of string.
RowHeaderEditFlag = TRUE
EditFlag = TRUE
CorrectFlag = TRUE
FUNCTION = 0 : EXIT FUNCTION
ELSE ' Column one and beyond
Dim As Long kk,jj : kk=Colwidth(0) : jj = siX.nPos + 1
DO WHILE kk < ptsCursor.x AND jj < Columns
kk = kk + Colwidth(jj) : jj+=1
LOOP
SelectCol = jj - 1
END IF
'
' Get row index for cell corresponding to this point.
SelectRow = siY.nPos + (ptsCursor.y - HeaderHeight) \ LineHeight
'
InvalidateRect hwnd, BYVAL NULL, FALSE
'
CASE WM_PAINT
'
' Draw grid
STATIC PrevX AS LONG
IF siX.nPos <> PrevX OR 0<>HeadEditFlag THEN ' Horizontal scrolling has taken place
' Then update header items
FOR i As Long = 0 TO MIN(siX.nPage + 20, Columns)
IF i = 0 THEN idx = 0 ELSE idx = siX.nPos
IF i + idx >= Columns THEN
s =" "
headitem.cxy = 2000 ' set very wide extra column
ELSE
s = FORMAT$(i+idx)+" "+DataArray(i+idx,0)
IF i = 0 THEN s = DataArray(i+idx,0)
headitem.cxy = ColWidth(i+idx)
END IF
headitem.pszText = StrPtr(s)
headitem.cchTextMax = LEN(*headitem.pszText)
SendMessage hHead , HDM_SETITEM, i , cast(LPARAM,@headitem)
NEXT
END IF
PrevX = siX.nPos
GetClientRect hwnd,@rc
rc.Top = HeaderHeight
Res=FillRect(memDCgr, @rc, GetStockObject(WHITE_BRUSH))
GetClientRect hwnd,@rc2
rc2.Top = HeaderHeight
TextHeight = 0 : j = 0
CellFlag = FALSE : RowFlag = FALSE : ColFlag = FALSE
'
' Row loop
DO WHILE (TextHeight < rc.Bottom - rc.Top) AND (j + siY.nPos <= Rows)
'
j+=1 : TextHeight = TextHeight + LineHeight
ColStart = 0 : i = 0
'
' Column loop
DO WHILE (ColStart < rc.Right) AND (i + siX.nPos <= Columns)
Dim cowi As Long
IF i = 0 THEN idx = 0 ELSE idx = siX.nPos
cowi = ColWidth(i + idx) : k = 2
IF ColStart + cowi > rc.Right THEN cowi = rc.Right - ColStart
IF cowi <= 0 THEN EXIT DO
'
' Paint row header column and draw vertical lines
IF j = 1 THEN ' First line
IF i = 0 THEN ' Row header column: Paint it light gray
rc2.Right = cowi
Res=FillRect(memDCgr, @rc2, GetStockObject(LTGRAY_BRUSH))
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, hGrayPen
END IF
MoveToEx memDCgr, ColStart, HeaderHeight, NULL
LineTo memDCgr, Colstart, rc.Bottom
END IF
END IF
'
' Get array indices, select font and colors for text and background.
Dim As Long xx ,yy
IF i = 0 THEN ' Row header column
' Get indices for cell
xx = 0 : yy = j + siY.nPos - 1
' Get text from array
s = FORMAT$(yy)+" "+DataArray(xx,yy)
SelectObject memDCgr, hFontBold
SetBkColor memDCgr,LTGRAY
SetBkMode memDCgr,TRANSPARENT ' de moi
' Make button appearance of row headers
SelectObject memDCgr, GetStockObject(WHITE_PEN)
MoveToEx memDCgr, 1, HeaderHeight+j*LineHeight-2, BYVAL NULL
LineTo memDCgr, 1, HeaderHeight+(j-1)*LineHeight
LineTo memDCgr, cowi-1, HeaderHeight+(j-1)*LineHeight
SelectObject memDCgr, hGrayPen
LineTo memDCgr, cowi-1, HeaderHeight+j*LineHeight-2
LineTo memDCgr, 0, HeaderHeight+j*LineHeight-2
ELSE ' Other columns
' Get indices for cell
xx = i + siX.nPos : yy = j + siY.nPos - 1
' Selected column in display
IF xx = SelectCol THEN ColFlag = TRUE
' Get text from array
s = DataArray(xx,yy)
SelectObject memDCgr, hFont
SetBkColor memDCgr,WHITE
END IF
'
' Determine if selected item is here. If so determine its rectangle.
IF yy = SelectRow THEN ' Selected row in display
RowFlag = TRUE
IF xx = SelectCol THEN ' Selected cell in display
x1 = MAX(1,Colstart) : x2 = MIN(Colstart + Cowi, rc.Right-2)
y1 = HeaderHeight+(j-1)*LineHeight-1
y2 = MIN(HeaderHeight+j*LineHeight-1,rc.Bottom-2)
CellFlag = TRUE
END IF
END IF
'
' Add "..." to truncated entries
GetTextMetrics memDCgr, @tm
GetTextExtentPoint32 memDCgr, s, LEN(s), @lpSize
Dim Spac AS LONG
Spac = cowi - Spacing - 3
DO WHILE Spac < lpSize.cx
chrs = cowi / tm.tmAveCharWidth
IF k>=chrs THEN s = "..." : EXIT DO
s = LEFT$(s,chrs-k)+"..."
GetTextExtentPoint32 memDCgr, s, BYVAL LEN(s), @lpSize
k+=1
LOOP
'
' Write cell text
TextOut memDCgr, (ColStart+Spacing), _
(HeaderHeight+1+(j-1)*LineHeight), s, BYVAL LEN(s)
'
' Prepare to draw next column
ColStart = ColStart + ColWidth(i + idx)
i+=1
'
LOOP ' End of column loop
'
' Finished with row: Draw horizontal line
' Row header part: black
SelectObject memDCgr, GetStockObject(BLACK_PEN)
MoveToEx memDCgr, 0, HeaderHeight+j*LineHeight-1, BYVAL NULL
LineTo memDCgr, rc2.Right, HeaderHeight+j*LineHeight-1
' Remaining part: gray
SelectObject memDCgr, hGrayPen
LineTo memDCgr, rc.Right, HeaderHeight+j*LineHeight-1
'
LOOP ' End of row loop
' If selected item is in display window, then show it.
IF CellFlag THEN
SelectObject memDCgr, hFatPen
MoveToEx memDCgr,x1,y1,BYVAL NULL : LineTo memDCgr,x2,y1
LineTo memDCgr,x2,y2 : LineTo memDCgr,x1,y2 : LineTo memDCgr,x1,y1
END IF
IF i <= Columns THEN
' Update number of columns in a displayed page
PageColumns = i
' Update horizontal scroll bar accordingly
siX.nPage = PageColumns
siX.nPos = MAX&(siX.nMin, MIN&(siX.nPos, siX.nMax - siX.nPage + 1))
SetScrollInfo hwnd, SB_HORZ, @siX, TRUE
END IF
hDCgr = BeginPaint(hwnd, @Ps)
' Copy virtual grid window onto screen.
Res = BitBlt(hDCgr,0,HeaderHeight,Rc.Right,Rc.Bottom,memDCgr,0,HeaderHeight,SRCCOPY)
EndPaint hwnd, @Ps
CASE WM_NOTIFY
IF LoWord(wparam) = FORM1_HEADER THEN
hdnptr = Cast(HD_NOTIFY Ptr,lparam)
hdiptr = hdnptr->pitem
SELECT CASE hdnptr->hdr.code
CASE HDN_TRACK ' May be replaced by HDN_ENDTRACK
IF 0<>EditFlag THEN FinishEdit
GetClientRect hwnd,@Rc
hdiptr->cxy = MAX(MinWidth, hdiptr->cxy)
IF hdnptr->iItem = 0 THEN idx = 0 ELSE idx = siX.nPos
ColWidth(hdnptr->iItem + idx) = hdiptr->cxy
rc.Top = HeaderHeight
InvalidateRect hwnd, @rc, FALSE
'
CASE HDN_ITEMCLICK ' Column header clicked: Edit column header cell.
IF 0<>EditFlag THEN FinishEdit
IF hdnptr->iItem = 0 THEN idx = 0 ELSE idx = siX.nPos + 1
y1 = 0 : y2 = HeaderHeight
IF idx = 0 THEN
x1 = 0 : x2 = ColWidth(0)
ELSE
i = ColWidth(0)
FOR j = idx TO hdnptr->iItem + idx - 1
i = i + ColWidth(j )
NEXT
x2 = i : x1 = i - ColWidth(hdnptr->iItem + idx-1)
END IF
SendMessage hEdit,WM_SETFONT,Cast(WPARAM,hFontBold),MAKELONG(TRUE,0)
' Move edit window to selected column header and display it there.
MoveWindow hEdit,x1+4,y1+1,x2-x1-7,y2-y1-4,1
ShowWindow hEdit, SW_SHOW
SetFocus hEdit
' Set column header text in the edit control.
idx = MAX(1,idx) : HeadCol = hdnptr->iItem + idx-1
SetWindowText hEdit, BYVAL STRPTR(DataArray(HeadCol,0))
SendMessage hEdit,EM_SETSEL,0,-1 ' Set caret
SendMessage hEdit,EM_SETSEL,-1,1 ' to end of string.
EditFlag = TRUE
CorrectFlag = TRUE
HeadEditFlag = TRUE
CASE HDN_ITEMDBLCLICK ' not used
CASE ELSE
END SELECT
END IF
CASE WM_SIZE
SetFocus hwnd
IF 0<>EditFlag THEN FinishEdit
GetClientRect hwnd, @rc
' Get new estimates of size variables for grid display
PageRows = (Rc.Bottom - HeaderHeight) \ LineHeight
PageColumns = Rc.Right \ Colwidth(Columns-1) + 1
' Update scroll bars
siY.nPage = PageRows
siY.nPos = MAX&(siY.nMin, MIN&(siY.nPos, siY.nMax - siY.nPage + 1))
SetScrollInfo hwnd, SB_VERT, @siY, TRUE
siX.nPage = PageColumns
siX.nPos = MAX&(siX.nMin, MIN&(siX.nPos, siX.nMax - siX.nPage + 1))
SetScrollInfo hwnd, SB_HORZ, @siX, TRUE
' (re)size header according to dimensions of grid window
layout.prc = @rc
layout.pwpos = @winpos
Res = Header_Layout(hHead , @layout) ' make header layout
HeaderHeight = winpos.cy ' save height of header
MoveWindow hHead , winpos.x, winpos.y-1,winpos.cx, winpos.cy+1, 1
' (re)create the virtual window
IF memDCgr THEN DeleteDC memDCgr
IF hBitGr THEN DeleteObject hBitGr
hDCgr = GetDC(hwnd)
memDCgr = CreateCompatibleDC(hDCgr)
hBitGr = CreateCompatibleBitmap(hDCgr,Rc.Right,Rc.Bottom)
SelectObject memDCgr, hBitGr
SelectObject memDCgr, hFont
Res = PatBlt(memDCgr, 0, 0, Rc.Right, Rc.Bottom, PATCOPY)
InvalidateRect hwnd, @rc, FALSE
CASE WM_DESTROY
'
IF 0<>EditFlag THEN FinishEdit
IF hGrayPen THEN DeleteObject hGrayPen
IF hLightGrayPen THEN DeleteObject hLightGrayPen
IF hFatPen THEN DeleteObject hFatPen
IF hFont THEN DeleteObject hFont
IF hFontBold THEN DeleteObject hFontBold
IF memDCgr THEN DeleteDC memDCgr
IF hBitGr THEN DeleteObject hBitGr
' Important! Remove the subclassing
SetWindowLong hEdit, GWL_WNDPROC, CLng(gOldSubClassEdit)
'
END SELECT
' Pass unprocessed messages on to the default handler
FUNCTION = DefWindowProc(hwnd, Msg, WPARAM, LPARAM)
'
END FUNCTION
FUNCTION SubClassEditKeys (hwnd As HWND, Msg As UINT,wparam As WPARAM,lparam as LPARAM)As LRESULT
' Subclass callback function for processing key messages for edit control.
Dim res AS DWORD, i AS Long,j AS Long,k As Long,t As String
SELECT CASE Msg
CASE WM_CHAR
SELECT CASE wparam ' Holds the code.
' Specify what action should be taken.
CASE VK_RETURN,VK_LINEFEED ' End editing of cell and move one cell down
FinishEdit
IF 0=HeadEditFlag AND RowHeaderEditFlag <> 2 THEN
RowHeaderEditFlag = FALSE
VScrollNotify = SB_LINEDOWN
SendMessage hGrid ,WM_VSCROLL,MAKELONG(VScrollNotify,0),0
END IF
HeadEditFlag = FALSE : RowHeaderEditFlag = FALSE : EXIT FUNCTION
CASE VK_TAB ' End editing of cell and move one cell right
FinishEdit
IF 0=HeadEditFlag AND RowHeaderEditFlag <> 2 THEN
RowHeaderEditFlag = FALSE
HScrollNotify = SB_LINERIGHT
SendMessage hGrid ,WM_HSCROLL,MAKELONG(HScrollNotify,0),0
END IF
HeadEditFlag = FALSE : RowHeaderEditFlag = FALSE : EXIT FUNCTION
CASE VK_ESCAPE ' Cancel edit: leave original cell text unchanged
EditFlag = FALSE : CorrectFlag = FALSE : HeadEditFlag = FALSE : RowHeaderEditFlag = FALSE
ShowWindow hEdit, SW_HIDE
SetFocus hGrid
InvalidateRect hGrid,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 wparam
CASE VK_DELETE,VK_LEFT,VK_RIGHT
CASE ELSE
IF 0<>HeadEditFlag OR RowHeaderEditFlag = 1 THEN FUNCTION = 0 : EXIT FUNCTION
END SELECT
VScrollNotify = -1 : HScrollNotify = -1
SELECT CASE wparam
CASE VK_DELETE
IF 0<>CorrectFlag THEN ' Remove character right of caret
res = SendMessage(hEdit, EM_GETSEL, 0, 0)
j = HIWORD(res) ' Caret position
t=CONTROL_GET_TEXT( hGrid,ID_EDITCHILD)
t = LEFT$(t,j)+MID$(t,j+2)
CONTROL_SET_TEXT hGrid ,ID_EDITCHILD,t
SendMessage hEdit, EM_SETSEL, j,j ' Reset caret
FUNCTION = 0 : EXIT FUNCTION
END IF
CASE VK_UP : VScrollNotify = SB_LINEUP
CASE VK_DOWN : VScrollNotify = SB_LINEDOWN
CASE VK_LEFT
IF 0<>CorrectFlag THEN ' Move caret left
res = SendMessage(hEdit, EM_GETSEL, 0, 0)
j = MAX(HiWord(res)-1,0) ' Caret is at the (upper limit of the) selection
SendMessage hEdit, EM_SETSEL, j,j ' Set caret at new position
FUNCTION = 0 : EXIT FUNCTION
ELSE ' Move to next cell to the left
HScrollNotify = SB_LINELEFT
END IF
CASE VK_RIGHT
IF 0<>CorrectFlag THEN ' Move caret right
k = SendMessage(hEdit, EM_LINELENGTH, 0, 0)
res = SendMessage(hEdit, EM_GETSEL, 0, 0)
j = MIN(HiWord(res)+1,k)
SendMessage hEdit, EM_SETSEL, j,j
FUNCTION = 0 : EXIT FUNCTION
ELSE ' Move to next cell to the right
HScrollNotify = SB_LINERIGHT
END IF
CASE VK_PRIOR : VScrollNotify = SB_PAGEUP
CASE VK_NEXT : VScrollNotify = SB_PAGEDOWN
CASE VK_HOME : VScrollNotify = SB_TOP : HScrollNotify = SB_LEFT
CASE VK_END : VScrollNotify = SB_BOTTOM : HScrollNotify = SB_RIGHT
CASE ELSE : FUNCTION = 0 : EXIT FUNCTION
END SELECT
'
IF VScrollNotify > -1 THEN SendMessage hGrid,WM_VSCROLL,MAKELONG(VScrollNotify,0),0
IF HScrollNotify > -1 THEN SendMessage hGrid,WM_HSCROLL,MAKELONG(HScrollNotify,0),0
'
END SELECT
' Pass the message on to the original window procedure.
FUNCTION = CallWindowProc(gOldSubClassEdit, hwnd, Msg, wparam, lparam)
END FUNCTION
SUB FinishEdit
Dim HScrollNotify AS LONG
IF 0<>HeadEditFlag THEN
DataArray(HeadCol,0)= CONTROL_GET_TEXT(hGrid,ID_EDITCHILD)
ELSEIF RowHeaderEditFlag = 1 THEN
DataArray(0,EditRow)=CONTROL_GET_TEXT(hGrid,ID_EDITCHILD)
RowHeaderEditFlag = 2
ELSE
DataArray(SelectCol,SelectRow)=CONTROL_GET_TEXT(hGrid,ID_EDITCHILD)
END IF
EditFlag = FALSE
CorrectFlag = FALSE
SendMessage hEdit,WM_SETFONT,Cast(WPARAM,hFont),MAKELONG(TRUE,0) ' normal font (default)
ShowWindow hEdit, SW_HIDE
SetFocus hGrid
InvalidateRect hGrid ,NULL, FALSE
UpdateWindow hGrid
END SUB