another grid

Windows specific questions.
Post Reply
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

another grid

Post by aloberoger »

grid.bi

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
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: another grid

Post by aloberoger »

testgrid.bas

Code: Select all

#Include Once "Grid.bi"
 
#Define CRLF Chr(13,0) 


Const Form1_FILE                                     = 500
' ------------------------------------------
Const Form1_DEFAULT                                  = 505
Const Form1_OPENFILE                                 = 510
Const Form1_SAVEAS                                   = 515
Const Form1_SEPARATOR_524                            = 524
Const Form1_EXIT                                     = 525
' ------------------------------------------
Const Form1_HELP                                     = 700
' ------------------------------------------
Const Form1_HELP1                                    = 705
Const Form1_ABOUT                                    = 710

DECLARE FUNCTION InitApplication() AS LONG
DECLARE FUNCTION InitInstance(As Long) AS LONG
DIM Shared g_szClassName AS ZString * 32
DIM Shared hForm1 As HWND    ' Dialog handle
DIM Shared hForm1_Menu0 As HMENU
DIM Shared hForm1_Menu1 As HMENU
DIM Shared hForm1_Menu3 As HMENU
DIM Shared PAFU AS STRING     ' path and file for input
DIM Shared PAFUout AS STRING  ' path and file for output
DIM Shared Delim AS STRING    ' Delimiter for saving and loading files
                          ' Set to $TAB (=CHR$(9)) in this program.
                          ' You may change this.
                          
Function PARSECOUNT( source As String, delimiter As String=",")As Long
	Dim As Long i,s,c,l
	s=1
	l=1
	Do
		i=Instr(s,source,Any delimiter)
		If i>0 Then
			c+=1
			s=i+l
		End If 
	Loop Until i=0
	Function=c+1
End Function
FUNCTION  PARSE (source as String, delimiter as String=",", index as Integer)as String
	Dim As Long i,s,c,l
	s=1
	l=Len(delimiter)
	do
		If c=index-1 then
			function=mid(source,s,instr(s,source,delimiter)-s)
			exit function
		end if
		i=instr(s,source,delimiter)
		If i>0 then
			c+=1
			s=i+l
		end if 
	loop until i=0
End Function


  Declare   FUNCTION MainWndProc (hwnd As HWND, Msg As UINT,wparam As WPARAM,lparam as LPARAM)As LRESULT                        
'*******************************************************************************
FUNCTION WINMAIN (BYVAL hInstance     AS HINSTANCE, _
                  BYVAL hPrevInstance AS HINSTANCE, _
                  lpCmdLine           AS ZString PTR, _
                  BYVAL nCmdShow      AS LONG) AS LONG
    Dim Msg AS MSG
    ' Initialize the common control library
    'InitComCtl32()
    InitCommoncontrols()
    IF (0=(InitApplication())) THEN FUNCTION = FALSE : EXIT FUNCTION
    IF (0=(InitInstance(nCmdShow))) THEN FUNCTION = FALSE : EXIT FUNCTION
    ' Create menu
    hForm1_Menu0=CreateMenu()
    ' -----------
     hForm1_Menu1=CreateMenu() 
     
    InsertMenu  hForm1_Menu0,0,MF_POPUP Or MF_ENABLED , CInt(hForm1_Menu1), StrPtr("&File")
    
    AppendMenu hForm1_Menu1, MF_STRING Or MF_ENABLED,Form1_DEFAULT, StrPtr("Use &Default data") 
    AppendMenu hForm1_Menu1, MF_STRING Or MF_ENABLED,Form1_OPENFILE, StrPtr("&Open Data File")
    AppendMenu hForm1_Menu1, MF_STRING Or MF_ENABLED,Form1_SAVEAS, StrPtr("Save Data File &As") 
     
   AppendMenu hForm1_Menu1, MF_SEPARATOR, 0, " "
    AppendMenu hForm1_Menu1, MF_STRING Or MF_ENABLED,Form1_EXIT, StrPtr("E&xit") 
    
    hForm1_Menu3=CreateMenu()
   
    InsertMenu  hForm1_Menu0,0,MF_POPUP Or MF_ENABLED , CInt(hForm1_Menu3), StrPtr("&Help")
    ' - - - - - - - - - - - - - -
     AppendMenu hForm1_Menu3, MF_STRING Or MF_ENABLED,Form1_HELP1, StrPtr( "&Description of program") 
    AppendMenu hForm1_Menu3, MF_STRING Or MF_ENABLED,Form1_ABOUT, StrPtr("&About") 
    SetMenu(hForm1 ,hForm1_Menu0)
     
    ShowWindow hForm1 , nCmdShow
    UpdateWindow hForm1 
    ' Create message loop
    WHILE GetMessage(@Msg, NULL, 0, 0)
        TranslateMessage @Msg
        DispatchMessage @Msg
    WEND
    FUNCTION = msg.wParam
END Function
End WINMAIN(getmodulehandle(0),NULL,Command,SW_SHOW)


'*******************************************************************************
FUNCTION InitApplication() AS LONG
    Dim wcex AS WNDCLASSEX
    g_szClassName      = "GridClass"
    wcex.cbSize        = SIZEOF(wcex)
    wcex.style         = CS_HREDRAW OR CS_VREDRAW OR CS_DBLCLKS OR CS_GLOBALCLASS
    wcex.lpfnWndProc   = @MainWndProc 
    wcex.cbClsExtra    = 0
    wcex.cbWndExtra    = 0
    wcex.hInstance     = GetModuleHandle(NULL)
    wcex.hCursor       = LoadCursor( NULL, BYVAL IDC_ARROW )
    wcex.hbrBackground = GetStockObject(LTGRAY_BRUSH)
    wcex.lpszMenuName  = NULL
    wcex.lpszClassName = StrPtr( g_szClassName )
    wcex.hIcon         = LoadIcon( NULL, BYVAL IDI_APPLICATION )
    wcex.hIconSm       = LoadIcon( NULL, BYVAL IDI_APPLICATION )
    FUNCTION = RegisterClassEx (@wcex)
END FUNCTION
'*******************************************************************************
FUNCTION InitInstance(nCmdShow AS LONG) AS LONG
    Dim szTitle AS ZString * 64
    szTitle = "Header Based Grid Control With Cell Editing"
    hForm1  = CreateWindowEx(  0, _
                            g_szClassName, _
                            szTitle, _
                            WS_BORDER OR WS_DLGFRAME OR WS_THICKFRAME OR WS_CAPTION OR _
                            WS_SYSMENU OR WS_MINIMIZEBOX OR WS_MAXIMIZEBOX _
                            OR WS_VISIBLE OR DS_MODALFRAME OR DS_3DLOOK OR _
                            DS_NOFAILCREATE OR DS_SETFONT OR CS_HREDRAW AND CS_VREDRAW, _
                            CW_USEDEFAULT, _
                            CW_USEDEFAULT, _
                            CW_USEDEFAULT, _
                            CW_USEDEFAULT, _
                            NULL, _
                            NULL, _
                            GetModuleHandle(NULL), _
                             NULL)
    IF (0=(hForm1 )) THEN Return FALSE  
    FUNCTION = TRUE
END FUNCTION
'
SUB ResizeControls(BYVAL X AS LONG,BYVAL Y AS LONG)
    ' In this routine the positions and sizes of all controls
    ' are specified as proportions (~percentages) of the dialog
    ' X and Y dimensions. Imagine when doing the design that the
    ' dialog area is 100 x 100 in percent. Define the position and
    ' size of the controls according to this area. When resizing is
    ' done, the proportions (~percentages) defining each control are
    ' never changed - only X and Y (defining the absolute size of the
    ' dialog) are changed.
    '
    ' Variables defining position and size of each control in turn
    Dim Xp AS Long ' Horizontal position (upper-left corner)
    Dim Yp As Long ' Vertical position   (upper-left corner)
    Dim W As Long  ' Width
    Dim H AS Long  ' Height
    '
    SendMessage hForm1 , WM_SETREDRAW, FALSE, NULL ' Disable redraw temporarily to reduce flicker.
    ' Resize GRID.
    Xp = .01*X : Yp = .001*Y : W = .98*X : H = .91*Y
    ' Adjust height to avoid clipping of last line of grid.
    H = (H - HeaderHeight - GetSystemMetrics(SM_CYHSCROLL)) \ LineHeight
    H = H * LineHeight + HeaderHeight + GetSystemMetrics(SM_CYHSCROLL) + 2
    MoveWindow hGrid ,Xp,Yp,W,H,TRUE
    SendMessage hForm1 , WM_SETREDRAW, TRUE, NULL ' enable redraw
END SUB

Function rnd_range (first As Double, last As Double) As Double
    Function = Rnd * (last - first) + first
End Function

Function _ROUND  (s As Double,n As Integer) As Double
	Return cint(10^n*s)/10^n
End Function

SUB Form1_DEFAULT_Select() ' Produce default data set.
    Dim I As Long,hDC As HDC
    Dim lpSize AS SIZEL
    Dim st AS ZString * 250
    Dim s AS STRING
    Dim PI2 AS DOUBLE
    PI2 = ATN(1) * 8 ' two PI
    ' Make default test data set.
    Dim DATAS(1 To ...) As string ={"Rec. - ID ","Weight (kg)","Height (cm)","Body Mass Index (BMI)","Hemoglobin (mmol/l)","Glucose (mmol/l)","ALT (IU/l)","Systolic Blood Pressure (mm Hg)","Diastolic Blood Pressure (mm Hg)"}
    Columns=8 ' number of columns
    Rows=1000   ' number of rows
    'RESET DataArray() : RESET ColWidth()
    REDIM DataArray(0 To Columns+1,0 To Rows)' Column zero and row zero are used for headers.
    REDIM ColWidth(0 To Columns+1)
    hDC = GetDC(hHead )
    FOR I =0 TO Columns + 1
        IF I <= Columns THEN
             DataArray(I ,0) = DATAS(I +1)
             IF I  = 0 THEN st = "" ELSE st = FORMAT$(I )+"   "
             st = st + DataArray(I ,0)
             GetTextExtentPoint32 hDC, st, LEN(st), @lpSize
             ColWidth(I ) = lpSize.cx + 10'tot' + 20 'lpSize.cx + 20
        ELSE
             ColWidth(I ) = 2000
        END IF
    NEXT
    ReleaseDC hHead , hDC
      Columns+=1 ' Provide for one extra visible empty column
    RANDOMIZE 1.5 ' The same seed ensures same data set each time you selects default data
    '
    'This function is used to create random values having a normal distribution
    'with a specified Mean and Standard Deviation (SD):
    'X = SQR(-2*LOG(RND))*COS(PI2*RND)*Standard_Deviation+Mean
    '
    FOR I =1 TO Rows
        DataArray(0,I)=CHR$(rnd_range(65,90))+"."+CHR$(rnd_range(65,90))+"."+CHR$(rnd_range(65,90))+"."
        DataArray(1,I)=LTRIM$(STR$(_ROUND(SQR(-2*LOG(RND))*COS(PI2*RND)*17+84,1)))
        DataArray(2,I)=LTRIM$(STR$(_ROUND(SQR(-2*LOG(RND))*COS(PI2*RND)*18+182,1)))
        DataArray(3,I)=LTRIM$(STR$(_ROUND(VAL(DataArray(1,I))*10000/VAL(DataArray(2,I))^2,1)))
        DataArray(4,I)=LTRIM$(STR$(rnd_range(38,80)/10+_ROUND(VAL(DataArray(3,I)),0)/10))
        DataArray(5,I)=LTRIM$(STR$(rnd_range(19,70)/10+_ROUND(VAL(DataArray(3,I)),0)/10))
        DataArray(6,I)=LTRIM$(STR$(_ROUND(rnd_range(-41,20)/3+VAL(DataArray(3,I))*2.1,0)))
        DataArray(7,I)=LTRIM$(STR$(_ROUND(rnd_range(95,160)+VAL(DataArray(3,I)),0)))
        DataArray(8,I)=LTRIM$(STR$(_ROUND(rnd_range(45,80)+VAL(DataArray(3,I)),0)))
    NEXT
'    MSGBOX "This random data base is artificial and any similarity to any known person is completely accidental !",MB_ICONINFORMATION,"Random default data"
    EnableMenuItem hForm1_Menu1, Form1_SAVEAS, MF_BYCOMMAND OR MF_ENABLED
    SendMessage hGrid ,WM_CREATE,0,0 ' Force updating: (re-)creation of grid
END SUB
 
FUNCTION FileNam(BYVAL Src AS STRING) AS STRING
  Dim x AS LONG
  FOR x = LEN(Src) TO 1 STEP -1
    IF (ASC(Src, x) = 92) OR (ASC(Src, x) = 58) THEN EXIT FOR
  NEXT x
  FUNCTION = MID$(Src, x + 1)
END FUNCTION
 
FUNCTION FilePath(BYVAL Src AS STRING) AS STRING
  Dim x AS LONG
  FOR x = LEN(Src) TO 1 STEP -1
    IF (ASC(Src, x) = 92) OR (ASC(Src, x) = 58) THEN EXIT FOR
  NEXT x
  FUNCTION = LEFT$(Src, x)
END FUNCTION
 
FUNCTION FilNameSave() AS LONG
   Dim Path   AS STRING
   Dim f      AS STRING
   Dim Style  AS DWORD
   Dim hFile  AS LONG
   Dim AS Long i ,j ,res ,fl 
igen:
   PAFUout=""
   Path=FilePath(PAFU)
   f=""
   Style = OFN_HIDEREADONLY OR OFN_LONGNAMES
   IF SaveFileDialog(0, "Save File", f, Path, _
       "Text Files|*.txt|All Files|*.*", "txt", Style) THEN
       '
       PAFUout=f
       IF PAFU=PAFUout THEN
           Res = MessaGeBOX( NULL, "Output file name the same as input file name. Do you want this ?", "Problem:",MB_ICONHAND OR MB_YESNO) 
           IF Res=IDNO THEN GOTO igen
       END IF
       hFile = FREEFILE
       OPEN PAFUout FOR OUTPUT AS hFile
       Delim = Chr(9) ' saves in TAB-delimited text format.
                    ' This format can be imported in most
                    ' spreadsheet and data base programs
                    ' like EXCEL and ACCESS.
       ' Save the data - one row at a time
       FOR j =0 TO Rows
           FOR I=0 TO Columns-1
               PRINT# hFile, DataArray(I,j );
               ' Put delimiter after each field except the last.
               IF I<Columns-1 THEN  PRINT# hFile,Delim;
           NEXT
           PRINT# hFile, Chr(10,13) ' End the line.
       NEXT
       CLOSE hFile
       FUNCTION = 1
   END IF
END FUNCTION
 
FUNCTION FilNameOpen() AS LONG
   Dim Path   AS STRING
   Dim f      AS STRING
   Dim Style  AS DWORD
   Dim hFile  AS LONG
   Dim b As String,i AS  Long,j AS  Long,x AS  Long,k AS  Long
   Dim hDC  AS  HDC
   Path     = CURDIR$
igen:
   f        = "*.TXT"
   Style    = OFN_FILEMUSTEXIST OR OFN_HIDEREADONLY OR OFN_LONGNAMES
   IF OpenFileDialog(0, "Open File", f, Path, _
     "Text Files|*.txt|All Files|*.*", "txt", Style) THEN
      PAFU=f
      Rows = 0
      hFile = FREEFILE
      OPEN PAFU FOR INPUT AS hFile
      LINE Input #hFile, b 

      ' Delimiter:
      Delim = CHR$(9)
      ' TAB (CHR$(9)) delimited text data without quotes are
      ' assumed in this version.
      '
      ' Most spreadsheet and data base programs can export data
      ' in TAB-separated text format to be read by this program.
      ' If you so wishes, you can also use other delimiters, such
      ' as comma, semicolon etc.
      '
      x  = PARSECOUNT(b ,Delim) ' Number of columns or data per row.
                                ' Fields without quotes assumed.
      ' check file
      IF x <1 THEN ' too few delimiters
         MesSaGeBOX (NULL, "This file cannot be read by this program!"+Chr(10,13)+" Try again.","Problem:",MB_ICONHAND)
         CLOSE hFile
         GOTO igen
      END IF
      k =0
      DO WHILE NOT (EOF(hFile) OR k >20)
          k +=1
          LINE Input #hFile, b 
          j  = PARSECOUNT(b ,Delim)
          IF j <>x  THEN ' not the same number of fields per line
              MesSaGeBOX (NULL, "This file cannot be read by this program!"+Chr(10,13)+" Try again.","Problem:",MB_ICONHAND)
              CLOSE hFile
              GOTO igen
          END IF
      LOOP
      IF k <2 THEN ' too few lines
         MesSaGeBOX (NULL,"This file cannot be read by this program!"+Chr(10,13)+" Try again.","Problem:",MB_ICONHAND)
         CLOSE hFile
         GOTO igen
      END IF
      CLOSE hFile
      '
      ' On crude checking file seems OK. Now read the file from start to end.
      hFile = FREEFILE
      OPEN PAFU FOR INPUT AS hFile
      Columns=x -1 ' number of columns (subtract one to adjust to base zero)
      '
      ' Redimension DataArray. Important to set the right number of columns
      ' prior to using REDIM PRESERVE
      REDIM DataArray(0 To Columns+1,0 To 0)
      '
      ' Read data into DataArray - one row at a time
      ' The first row is assumed to be column headers
      Rows=-1
      DO WHILE NOT EOF(hFile)
           Rows +=1' number of rows
          LINE Input #hFile, b 
          REDIM PRESERVE DataArray(0 To Columns+1,0 To Rows)
          FOR I=0 TO Columns
              DataArray(I,Rows)=PARSE$(b ,Delim,I+1) ' Parse index starts with 1
          NEXT
      LOOP
      CLOSE hFile
      '
      ' Set column widths to header item widths.
      hDC = GetDC(hHead )
      Dim lpSize AS SIZEL
      Dim st AS ZString * 250
      FOR I=0 TO Columns + 1
          IF I<= Columns THEN
             IF I = 0 THEN st = "" ELSE st = FORMAT$(I)+"   "
             st = st + DataArray(I,0)
             GetTextExtentPoint32 hDC, st, LEN(st), @lpSize
             ColWidth(I) = lpSize.cx + 10
          ELSE
              ColWidth(I) = 2000
         END IF
      NEXT
      ReleaseDC hHead , hDC
      '
      Columns+=1 ' Provide for one extra visible empty column
      '
      SendMessage hGrid ,WM_CREATE,0,0  ' Force updating: (re-)creation of grid
      FUNCTION = 1
   END IF
END FUNCTION
'
SUB Form1_OPENFILE_Select()
    IF FilNameOpen() THEN
        IF Rows>=2 THEN
            EnableMenuItem hForm1_Menu1, Form1_SAVEAS, MF_BYCOMMAND OR MF_ENABLED
        END IF
    END IF
END SUB
 
SUB Form1_SAVEAS_Select()
    IF FilNameSave() THEN
    END IF
END SUB
 
SUB Form1_HELP1_Select()
    Dim St AS  String*2048
    St="Header based virtual grid control with cell editing " +CRLF 
    St &="This version of the header based virtual grid control enables you to " 
    St &="edit individual cells as well as column and row headers. Like in " 
    St &="Excel new text is placed in the selected cell just by typing the text " 
    St &="on the keyboard. You end entering new text by pressing ENTER, TAB, by " 
    St &="moving the selected cell or by scrolling. Before ending you may " 
    St &="retrieve the old text by pressing ESCAPE. In harmony with Excel you " 
    St &="can perform full editing of a cell by pressing function key 2 (F2). " 
    St &="When editing is started in this way you can insert and delete " 
    St &="characters in any position." & CRLF 
    St &="Editing of column and row headers is started by a mouse click. Full " 
    St &="editing is always possible and editing needs to be ended by pressing " 
    St &="ENTER or TAB. This arrangement makes it more difficult to " 
    St &="accidentally change the headers." & CRLF 
    St &="In this version you can import files from Excel and other similar " 
    St &= "programs if the files have been saved in TAB-separated text format. " 
    St &="You can also save the data in the grid control in TAB-separated text " 
    St &="format, which can be imported in Excel and most other programs." & CRLF 
    St &="Thanks to the PowerBasic Forum for great inspiration." & CRLF 
    St &="Good luck!" & CRLF 
      MesSaGeBOX (NULL, St,"Virtual grid control with cell editing",MB_ICONINFORMATION)
END SUB
 
SUB Form1_ABOUT_Select
    Dim St AS ZString*2048
    St="Virtual grid control program with cell editing, import and export of TAB-separated text (ASCII) files "+CRLF 
    st &="The use of this Public Domain program and its consequences are your own responsibility. However, any comment you may have is welcome."+CRLF 
    st &="Originally posted by Erik Christensen On PB forum "
    MesSaGeBOX (NULL, St,"About this program",MB_ICONINFORMATION)
END SUB
 
  FUNCTION MainWndProc (hwnd As HWND, Msg As UINT,wparam As WPARAM,lparam as LPARAM)As LRESULT
    DIM MinMaxPtr AS MINMAXINFO PTR
    Static hStatusBar AS  HWND
    DIM StatusText AS ZString * 250
    STATIC First AS LONG
    DIM rc AS RECT, i  AS  Long,j  AS  Long,Res  AS  Long
    Static StatusBarHeight AS  LONG
    SELECT CASE Msg
    	CASE WM_CREATE
          IF First = 0 THEN
            ' Specification of size of Data Array.
            ' Start up data
            Rows=200
            Columns=30
            '
            ' Grid routines are made for arrays no less than (4,20)
            Columns=MAX(4,Columns)
            Rows=MAX(20,Rows)
            ' One empty column is being added.
            REDIM DataArray(0 To Columns+1,0 To Rows)' Column zero and row zero are used for headers.
            REDIM ColWidth(0 To Columns+1) ' Each column may have it own width if you want that at some time.
            ' Fill array with data
            FOR i=0 TO Columns + 1
                IF i = 0 THEN ColWidth(i) = 46 ELSE ColWidth(i) = 130
                IF i > Columns THEN ColWidth(i) = 2000
                FOR j=0 TO Rows
                    IF i=0 THEN      ' Column zero is used for row headers.
                        IF j=0 THEN  ' Label of row header column.
                            DataArray(i,j)= "R\C"
                        ELSE     '    ' Text of row headers.
                           ' IF j<=Rows THEN DataArray(i,j)= format$(j)
                        END IF
                    ELSE     ' i >= 1
                        IF j=0 THEN  ' Row zero is used for column headers.
                          '  IF i<= Columns THEN DataArray(i,j)= format$(i)
                        ELSE ' j >= 1  Item/subitem content
                            IF i <= Columns AND j <= Rows THEN DataArray(i,j)= "Column"+STR$(i)+" Row"+STR$(j)
                        END IF
                    END IF
                NEXT
            NEXT
            Columns = Columns + 1
          '  Rows = Rows
            '
            Res = InitHeaderGridCtrl
            hGrid  = CreateWindow("HEADERGRID",  0, WS_VISIBLE OR _
                                   WS_CHILD OR WS_HSCROLL OR WS_VSCROLL OR WS_BORDER, _
                                  0,0,0,0,hwnd, Cast(HMENU,FORM1_GRID), GetModuleHandle(NULL), BYVAL 0)
            ' Adapt window to Work Area on screen (desktop).
            SystemParametersInfo SPI_GETWORKAREA, 0,@Rc, 0
            MoveWindow hwnd, 0, 0, Rc.Right - Rc.Left, Rc.Bottom - Rc.Top, 0
            
            ' The next few lines define a status bar.
            ' NB: The area of the status bar is subtracted from the available client area.
            GetClientRect hwnd, @rc
            hStatusBar = CreateStatusWindow(SBARS_SIZEGRIP OR WS_CHILD OR WS_VISIBLE OR WS_CLIPSIBLINGS OR CCS_BOTTOM, "", hwnd, 0)
            StatusText = " Dialog Size in pixels: X: "+FORMAT$(rc.Right,"####")+"   Y: "+FORMAT$(rc.Bottom,"####")
            SendMessage hStatusBar, WM_SETTEXT, 0, CInt(StrPtr(StatusText))
            GetClientRect hStatusBar, @rc
            StatusBarHeight = rc.Bottom
            ShowWindow hGrid, SW_SHOW
            First = 1
          END IF
            '
    	CASE WM_SIZE
            ' Get size of dialog after tracking.
            GetClientRect hwnd, @rc
            ' Resize status bar
            MoveWindow hStatusBar, rc.Left,rc.Bottom-StatusBarHeight, _
                rc.Right - rc.Left, StatusBarHeight, TRUE
            ' Perform proportional resizing of controls.
            ResizeControls(rc.Right,rc.Bottom)
            StatusText = " Dialog Size in pixels: X: "+FORMAT$(rc.Right,"####")+"   Y: "+FORMAT$(rc.Bottom,"####")
            SendMessage hStatusBar, WM_SETTEXT, 0, CInt(strPTR(StatusText))
            InvalidateRect hwnd, BYVAL NULL, FALSE
            
    	CASE WM_GETMINMAXINFO
            MinMaxPtr=Cast(MINMAXINFO Ptr,lparam)
            ' Set the minimum size of dialog. You can define these values according to need.
             MinMaxPtr->ptMinTrackSize.x = 400 ' minimum X of dialog in pixels
             MinMaxPtr->ptMinTrackSize.y = 300 ' minimum Y of dialog in pixels
            '
    	CASE WM_COMMAND
            SELECT CASE LOWORD(wparam)
            ' Process Messages to Controls that have no Callback Function
            ' and Process Messages to Menu Items
            	CASE  Form1_DEFAULT
                    Form1_DEFAULT_Select
            	CASE  Form1_OPENFILE
                    Form1_OPENFILE_Select
            	CASE  Form1_SAVEAS
                    Form1_SAVEAS_Select
            	CASE  Form1_HELP1
                    Form1_HELP1_Select
            	CASE Form1_ABOUT
                    Form1_ABOUT_Select
            	CASE  Form1_EXIT
                    PostQuitMessage 0
            END SELECT
    	CASE WM_DESTROY
            PostQuitMessage 0
    END SELECT
    ' Pass unprocessed messages on to the default handler
    FUNCTION = DefWindowProc(hwnd, Msg, wparam, lparam)
END FUNCTION
VANYA
Posts: 1834
Joined: Oct 24, 2010 15:16
Location: Ярославль
Contact:

Re: another grid

Post by VANYA »

Very nice!
noop
Posts: 130
Joined: Sep 18, 2006 10:29

Re: another grid

Post by noop »

Thanks for the post, looks really good!

One cosmetic thing: It flickers sometimes if you try to scroll even if the view cannot change (already at the bottom/top/left/right). Perhaps some check is needed to avoid flickering.
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: another grid

Post by aloberoger »

Code: Select all

in any case at it is completely normal for me 
you can add in  FUNCTION GridCallBack(hwnd As HWND, Msg As UINT,wparam As WPARAM,lparam as LPARAM)As LRESULT 
        Case WM_ERASEBKGND
          Return -1

in the project test  re-examine CRLF into CRLF=chr(13,10) 
the remainder without change 
FB_user_22
Posts: 3
Joined: Jan 30, 2022 18:30

Re: another grid

Post by FB_user_22 »

Getting errors in FreeBasic_1.08.1:
D:\Grid.bi(356) error 42: Variable not declared, GWL_HINSTANCE in 'Cast(HINSTANCE,GetWindowLong(hwnd,GWL_HINSTANCE)),BYVAL NULL)'
D:\Grid.bi(359) error 42: Variable not declared, GWL_WNDPROC in 'gOldSubClassEdit = Cast(WNDPROC,SetWindowLong(hEdit, GWL_WNDPROC, Cast(DWORD,@SubClassEditKeys)))'
D:\Grid.bi(876) error 1: Argument count mismatch, found 'GWL_WNDPROC' in 'SetWindowLong hEdit, GWL_WNDPROC, CLng(gOldSubClassEdit)'
Post Reply