'------------------------------------------------------------------------------
#COMPILE EXE
#REGISTER NONE
#DIM ALL
'------------------------------------------------------------------------------
' Initial Declares - eliminate unnecessary macros in COMMCTRL.INC
'------------------------------------------------------------------------------
%NOANIMATE = 1 ' Animate contro l
%NOBUTTON = 1 ' Button
%NOCOMBO = 1 ' Combo box
%NOCOMBOEX = 1 ' ComboBoxEx
%NODATETIMEPICK = 1 ' Date/time picker
%NODRAGLIST = 1 ' Drag list control
%NOEDIT = 1 ' Edit control
%NOFLATSBAPIS = 1 ' Flat scroll bar
' %NOHEADER = 1 ' Header control
%NOHOTKEY = 1 ' HotKey control
%NOIMAGELIST = 1 ' Image APIs
%NOIPADDRESS = 1 ' IP Address edit control
%NOLIST = 1 ' List box control
%NOLISTVIEW = 1 ' ListView control
%NOMENUHELP = 1 ' Menu help
%NOMONTHCAL = 1 ' MonthCal
%NOMUI = 1 ' MUI
%NONATIVEFONTCTL = 1 ' Native Font control
%NOPAGESCROLLER = 1 ' Pager
%NOPROGRESS = 1 ' Progress control
%NOREBAR = 1 ' Rebar control
' %NOSTATUSBAR = 1 ' Status bar
%NOTABCONTROL = 1 ' Tab control
%NOTOOLBAR = 1 ' Tool bar
%NOTOOLTIPS = 1 ' Tool tips
%NOTRACKBAR = 1 ' Track bar
%NOTRACKMOUSEEVENT = 1 ' Track Mouse Event
%NOTREEVIEW = 1 ' TreeView
%NOUPDOWN = 1 ' Up Down arrow control
' ----------------------------------------------------------
#INCLUDE "WIN32API.INC"
#INCLUDE "COMMCTRL.INC"
#INCLUDE "INITCTRL.INC"
#INCLUDE "COMDLG32.INC"'******************************************************************************
'** Potential Include File Part ***********************************************
'******************************************************************************
'------------------------------------------------------------------------
%FORM1_HEADER = 130
%FORM1_GRID = 135
%ID_EDITCHILD = 140
'
GLOBAL hGrid& ' Handle of grid control
GLOBAL hHead& ' Handle of header control of grid control
GLOBAL hEdit& ' Handle of edit control in grid
GLOBAL Rows AS LONG ' Total number of rows in array
GLOBAL Columns AS LONG ' Total number of columns in array
GLOBAL DataArray() AS STRING ' Two dimensional text array to be displayed
GLOBAL ColWidth() AS LONG ' Array to hold the column widths
GLOBAL HeaderHeight AS LONG ' Height of header control
GLOBAL LineHeight AS LONG ' Height of one line in grid control
GLOBAL gOldSubClassEdit&
GLOBAL SelectCol AS LONG
GLOBAL SelectRow AS LONG
GLOBAL VScrollNotify AS WORD
GLOBAL HScrollNotify AS WORD
GLOBAL EditFlag AS LONG
GLOBAL CorrectFlag AS LONG
GLOBAL HeadEditFlag AS LONG
GLOBAL RowHeaderEditFlag AS LONG
GLOBAL HeadCol AS LONG
GLOBAL EditRow AS LONG
GLOBAL hFont AS LONG
GLOBAL siX AS SCROLLINFO
'------------------------------------------------------------------------------
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 LONG
LOCAL hDC&,LogPixelsY&
LOCAL 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.
LogPixelsY = 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,LogPixelsY,72) ' better than: -(FontTypeSize * LogPixelsY) \ 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
LOCAL wc AS WNDCLASS
LOCAL szClassName AS ASCIIZ * 11
szClassName = "HEADERGRID"
wc.style = %CS_HREDRAW OR %CS_VREDRAW OR %CS_DBLCLKS OR %CS_GLOBALCLASS
wc.lpfnWndProc = CODEPTR(GridCallBack)
wc.cbClsExtra = 0
wc.cbWndExtra = 0
wc.hInstance = GetModuleHandle(BYVAL %NULL)
wc.hIcon = %NULL
wc.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wc.hbrBackground = GetStockObject(%WHITE_BRUSH)
wc.lpszMenuName = %NULL
wc.lpszClassName = VARPTR(szClassName)
FUNCTION = RegisterClass(wc)
END FUNCTION
'******************************************************************************
CALLBACK FUNCTION GridCallBack
' Callback Handle CBHNDL is: hGrid&
LOCAL szString AS ASCIIZ * 256
LOCAL layout AS HDLAYOUT
LOCAL winpos AS WINDOWPOS
STATIC headitem AS HD_ITEM
STATIC hCtr&,Res&,s AS ASCIIZ * 250
LOCAL hdnptr AS HD_NOTIFY PTR
LOCAL hdiptr AS HD_ITEM PTR
LOCAL MinWidth AS LONG : MinWidth = 40
LOCAL rc AS RECT ,i&,j&,hdc&,k&,chrs&,idx&,M&
LOCAL rc2 AS RECT
LOCAL hDCgr AS LONG
LOCAL ColStart AS LONG
STATIC TextHeight AS LONG
LOCAL lpSize AS SIZEL
LOCAL Spacing AS LONG : Spacing = 6
LOCAL ps AS PAINTSTRUCT
LOCAL tm AS TEXTMETRIC
STATIC hFontBold AS LONG , hFatPen AS LONG
STATIC hGrayPen AS LONG, hLightGrayPen AS LONG
STATIC memDCgr AS LONG, hBitGr AS LONG
STATIC siY AS SCROLLINFO
STATIC ptsCursor AS POINTAPI
STATIC PageRows AS LONG ' Number of rows on a page
STATIC PageColumns AS LONG ' Number of columns on a page
STATIC CellFlag&, ColFlag&, RowFlag&
STATIC x1&,y1&,x2&,y2&
'
SELECT CASE CBMSG
CASE %WM_CREATE
'
' Create Header and set its font.
IF ISFALSE hHead& THEN
hHead& = CreateWindow("SysHeader32",BYVAL 0, %WS_CHILD OR %WS_BORDER _
OR %HDS_BUTTONS,0,0,0,0,CBHNDL,%FORM1_HEADER, _
GetModuleHandle(BYVAL %NULL), BYVAL %NULL)
hFontBold = MakeFont(8,%FW_BOLD,0,0,0,"MS Sans Serif")
SendMessage hHead&,%WM_SETFONT,hFontBold,MAKLNG(%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 = VARPTR(s)
headitem.cchTextMax = LEN(headitem.pszText)
headitem.cxy = ColWidth(i&)
Header_InsertItem hHead&, i&, VARPTR(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 = VARPTR(s)
headitem.cchTextMax = LEN(headitem.pszText)
SendMessage hHead&, %HDM_SETITEM, i&, VARPTR(headitem)
NEXT
END IF
'
IF ISFALSE memDCgr THEN
' Create a virtual window for grid
hDCgr = GetDC(CBHNDL)
memDCgr = CreateCompatibleDC(hDCgr)
hBitGr = CreateCompatibleBitmap(hDCgr,Rc.nRight,Rc.nBottom)
SelectObject memDCgr, hBitGr
SelectObject memDCgr, hFont
GetTextMetrics memDCgr, tm
LineHeight = tm.tmHeight + tm.tmInternalLeading
Res& = PatBlt(memDCgr, 0, 0, Rc.nRight, Rc.nBottom, %PATCOPY)
END IF
'
IF ISFALSE hEdit THEN
' Create edit control
hEdit = CreateWindow("EDIT",BYVAL %NULL,%WS_CHILD OR %ES_AUTOHSCROLL, _
0, 0, 0, 0,CBHNDL,%ID_EDITCHILD, _
GetWindowLong(CBHNDL,%GWL_HINSTANCE),BYVAL %NULL)
SendMessage hEdit&,%WM_SETFONT,hFont,MAKLNG(%TRUE,0)
' Subclass Edit Control
gOldSubClassEdit& = SetWindowLong(hEdit&, %GWL_WNDPROC, CODEPTR(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(CBHNDL, %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(CBHNDL, %SB_HORZ, siX, %TRUE)
'
SetFocus CBHNDL
InvalidateRect CBHNDL, BYVAL %NULL , %FALSE
'
CASE %WM_VSCROLL
SetFocus CBHNDL
IF ISTRUE EditFlag THEN CALL FinishEdit
HeadEditFlag = %FALSE
SELECT CASE LOWRD(CBWPARAM)
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 INCR SelectRow
IF SelectRow > siY.nPos + siY.nPage - 1 THEN INCR siY.nPos
ELSE ' Scroll bar clicked
INCR siY.nPos
END IF
CASE %SB_LINEUP
IF VScrollNotify = %SB_LINEUP THEN ' Up key pressed
IF SelectRow > 1 THEN DECR SelectRow
IF SelectRow < siY.nPos THEN DECR siY.nPos
ELSE ' Scroll bar clicked
DECR siY.nPos
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(CBHNDL, %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(CBHNDL, %SB_VERT, siY, %TRUE)
GetClientRect CBHNDL, rc : Rc.nTop = HeaderHeight
InvalidateRect CBHNDL, rc , %FALSE
EXIT FUNCTION
'
CASE %WM_HSCROLL
SetFocus CBHNDL
IF ISTRUE EditFlag THEN CALL FinishEdit
HeadEditFlag = %FALSE
SELECT CASE LOWRD(CBWPARAM)
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 DECR SelectCol
IF SelectCol < siX.nPos + 1 THEN DECR siX.nPos
ELSE ' Scroll bar clicked
DECR siX.nPos
END IF
CASE %SB_LINERIGHT
IF HScrollNotify = %SB_LINERIGHT THEN ' Right key pressed
IF SelectCol < Columns-1 THEN INCR SelectCol
IF SelectCol > siX.nPos + siX.nPage - 2 THEN INCR siX.nPos
ELSE ' Scroll bar clicked
INCR siX.nPos
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(CBHNDL, %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(CBHNDL, %SB_HORZ, siX, %TRUE)
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
UpdateWindow CBHNDL
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 CBHNDL
IF ISTRUE EditFlag THEN CALL FinishEdit
HeadEditFlag = %FALSE
SELECT CASE CBWPARAM
' Exit if character is not relevant.
CASE %VK_TAB,%VK_LINEFEED, %VK_RETURN, 32 TO 255
CASE ELSE : FUNCTION = 0 : EXIT FUNCTION
END SELECT
' First: If selected cell not in view, then scroll it into view.
IF ISFALSE ColFlag OR ISFALSE RowFlag THEN
IF ISFALSE ColFlag THEN
siX.nPos = SelectCol - 1
siX.nPos = MAX&(siX.nMin, MIN&(siX.nPos, siX.nMax - siX.nPage + 1))
Res& = SetScrollInfo(CBHNDL, %SB_HORZ, siX, %TRUE)
END IF
IF ISFALSE RowFlag THEN
siY.nPos = SelectRow
siY.nPos = MAX&(siY.nMin, MIN&(siY.nPos, siY.nMax - siY.nPage + 1))
Res& = SetScrollInfo(CBHNDL, %SB_VERT, siY, %TRUE)
END IF
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
UpdateWindow CBHNDL
END IF
'
' Identify character and perform relevant action.
SELECT CASE CBWPARAM
CASE %VK_TAB
HScrollNotify = %SB_LINERIGHT
SendMessage CBHNDL,%WM_HSCROLL,MAKLNG(HScrollNotify,0),0
FUNCTION = 0 : EXIT FUNCTION
CASE %VK_LINEFEED, %VK_RETURN
VScrollNotify = %SB_LINEDOWN
SendMessage CBHNDL,%WM_VSCROLL,MAKLNG(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 CBHNDL,%ID_EDITCHILD,CHR$(CBWPARAM)
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 CBHNDL
IF ISTRUE EditFlag THEN CALL FinishEdit
HeadEditFlag = %FALSE
' Process arrow keys etc. for grid. hGrid& needs to have focus.
VScrollNotify = -1 : HScrollNotify = -1
SELECT CASE CBWPARAM
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 ISFALSE ColFlag OR ISFALSE RowFlag THEN
IF ISFALSE ColFlag THEN
siX.nPos = SelectCol - 1
siX.nPos = MAX&(siX.nMin, MIN&(siX.nPos, siX.nMax - siX.nPage + 1))
Res& = SetScrollInfo(CBHNDL, %SB_HORZ, siX, %TRUE)
END IF
IF ISFALSE RowFlag THEN
siY.nPos = SelectRow
siY.nPos = MAX&(siY.nMin, MIN&(siY.nPos, siY.nMax - siY.nPage + 1))
Res& = SetScrollInfo(CBHNDL, %SB_VERT, siY, %TRUE)
END IF
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
UpdateWindow CBHNDL
END IF
'
' Move edit window to selected cell and display it there.
MoveWindow 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 CBHNDL,%WM_VSCROLL,MAKLNG(VScrollNotify,0),0
IF HScrollNotify > -1 THEN SendMessage CBHNDL,%WM_HSCROLL,MAKLNG(HScrollNotify,0),0
'
CASE %WM_LBUTTONDBLCLK ' Not used
CASE %WM_LBUTTONDOWN ' Click to place selected cell at click position
'
SetFocus CBHNDL
IF ISTRUE EditFlag THEN CALL FinishEdit
HeadEditFlag = %FALSE
'
' Get cursor position in client area.
ptsCursor.x = LOWRD(CBLPARAM) : ptsCursor.y = HIWRD(CBLPARAM)
'
' 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,hFontBold,MAKLNG(%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
LOCAL kk&,jj& : kk=Colwidth(0) : jj = siX.nPos + 1
DO WHILE kk < ptsCursor.x AND jj < Columns
kk = kk + Colwidth(jj) : INCR jj
LOOP
SelectCol = jj - 1
END IF
'
' Get row index for cell corresponding to this point.
SelectRow = siY.nPos + (ptsCursor.y - HeaderHeight) \ LineHeight
'
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
'
CASE %WM_PAINT
'
' Draw grid
STATIC PrevX AS LONG
IF siX.nPos <> PrevX OR ISTRUE HeadEditFlag THEN ' Horizontal scrolling has taken place
' Then update header items
FOR i& = 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 = VARPTR(s)
headitem.cchTextMax = LEN(headitem.pszText)
SendMessage hHead&, %HDM_SETITEM, i&, VARPTR(headitem)
NEXT
END IF
PrevX = siX.nPos
'
GetClientRect CBHNDL,rc
rc.nTop = HeaderHeight
Res&=FillRect(memDCgr, rc, GetStockObject(%WHITE_BRUSH))
GetClientRect CBHNDL,rc2
rc2.nTop = HeaderHeight
TextHeight = 0 : j = 0
CellFlag = %FALSE : RowFlag = %FALSE : ColFlag = %FALSE
'
' Row loop
DO WHILE (TextHeight < rc.nBottom - rc.nTop) AND (j + siY.nPos <= Rows)
'
INCR j : TextHeight = TextHeight + LineHeight
ColStart = 0 : i = 0
'
' Column loop
DO WHILE (ColStart < rc.nRight) AND (i + siX.nPos <= Columns)
LOCAL cowi&
IF i = 0 THEN idx = 0 ELSE idx = siX.nPos
cowi = ColWidth(i + idx) : k = 2
IF ColStart + cowi > rc.nRight THEN cowi = rc.nRight - ColStart
IF cowi <= 0 THEN EXIT DO
'
' Paint row header column and draw vertical lines
IF j = 1 THEN ' First line
IF i = 0 THEN ' Row header column: Paint it light gray
rc2.nRight = 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, BYVAL %NULL
LineTo memDCgr, Colstart, rc.nBottom
END IF
END IF
'
' Get array indices, select font and colors for text and background.
LOCAL 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
' 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.nRight-2)
y1 = HeaderHeight+(j-1)*LineHeight-1
y2 = MIN(HeaderHeight+j*LineHeight-1,rc.nBottom-2)
CellFlag = %TRUE
END IF
END IF
'
' Add "..." to truncated entries
GetTextMetrics memDCgr, tm
GetTextExtentPoint32 memDCgr, s, LEN(s), lpSize
LOCAL Space AS LONG
Space = cowi - Spacing - 3
DO WHILE Space < 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
INCR k
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)
INCR i
'
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.nRight, HeaderHeight+j*LineHeight-1
' Remaining part: gray
SelectObject memDCgr, hGrayPen
LineTo memDCgr, rc.nRight, 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 CBHNDL, %SB_HORZ, siX, %TRUE
END IF
'
hDCgr = BeginPaint(CBHNDL, Ps)
'
' Copy virtual grid window onto screen.
Res& = BitBlt(hDCgr,0,HeaderHeight,Rc.nRight,Rc.nBottom,memDCgr,0,HeaderHeight,%SRCCOPY)
'
EndPaint CBHNDL, Ps
'
CASE %WM_NOTIFY
IF LOWRD(CBWPARAM) = %FORM1_HEADER THEN
hdnptr = CBLPARAM
hdiptr = @hdnptr.pitem
SELECT CASE @hdnptr.hdr.code
CASE %HDN_TRACK ' May be replaced by %HDN_ENDTRACK
IF ISTRUE EditFlag THEN CALL FinishEdit
GetClientRect CBHNDL,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.nTop = HeaderHeight
InvalidateRect CBHNDL, rc, %FALSE
'
CASE %HDN_ITEMCLICK ' Column header clicked: Edit column header cell.
IF ISTRUE EditFlag THEN CALL 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,hFontBold,MAKLNG(%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 CBHNDL
IF ISTRUE EditFlag THEN CALL FinishEdit
GetClientRect CBHNDL, rc
' Get new estimates of size variables for grid display
PageRows = (Rc.nBottom - HeaderHeight) \ LineHeight
PageColumns = Rc.nRight \ Colwidth(Columns-1) + 1
'
' Update scroll bars
siY.nPage = PageRows
siY.nPos = MAX&(siY.nMin, MIN&(siY.nPos, siY.nMax - siY.nPage + 1))
SetScrollInfo CBHNDL, %SB_VERT, siY, %TRUE
siX.nPage = PageColumns
siX.nPos = MAX&(siX.nMin, MIN&(siX.nPos, siX.nMax - siX.nPage + 1))
SetScrollInfo CBHNDL, %SB_HORZ, siX, %TRUE
'
' (re)size header according to dimensions of grid window
layout.prc = VARPTR(rc)
layout.pwpos = VARPTR(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(CBHNDL)
memDCgr = CreateCompatibleDC(hDCgr)
hBitGr = CreateCompatibleBitmap(hDCgr,Rc.nRight,Rc.nBottom)
SelectObject memDCgr, hBitGr
SelectObject memDCgr, hFont
Res& = PatBlt(memDCgr, 0, 0, Rc.nRight, Rc.nBottom, %PATCOPY)
InvalidateRect CBHNDL, rc, %FALSE
'
CASE %WM_DESTROY
'
IF ISTRUE EditFlag THEN CALL 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, gOldSubClassEdit&
'
END SELECT
' Pass unprocessed messages on to the default handler
FUNCTION = DefWindowProc(CBHNDL, CBMSG, CBWPARAM, CBLPARAM)
'
END FUNCTION
'
CALLBACK FUNCTION SubClassEditKeys
' Subclass callback function for processing key messages for edit control.
LOCAL res AS DWORD, i&,j&,k&,t$
'
SELECT CASE CBMSG
'
CASE %WM_CHAR
SELECT CASE CBWPARAM ' Holds the code.
' Specify what action should be taken.
CASE %VK_RETURN,%VK_LINEFEED ' End editing of cell and move one cell down
CALL FinishEdit
IF ISFALSE HeadEditFlag AND RowHeaderEditFlag <> 2 THEN
RowHeaderEditFlag = %FALSE
VScrollNotify = %SB_LINEDOWN
SendMessage hGrid&,%WM_VSCROLL,MAKLNG(VScrollNotify,0),0
END IF
HeadEditFlag = %FALSE : RowHeaderEditFlag = %FALSE : EXIT FUNCTION
CASE %VK_TAB ' End editing of cell and move one cell right
CALL FinishEdit
IF ISFALSE HeadEditFlag AND RowHeaderEditFlag <> 2 THEN
RowHeaderEditFlag = %FALSE
HScrollNotify = %SB_LINERIGHT
SendMessage hGrid&,%WM_HSCROLL,MAKLNG(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 CBWPARAM
CASE %VK_DELETE,%VK_LEFT,%VK_RIGHT
CASE ELSE
IF ISTRUE HeadEditFlag OR RowHeaderEditFlag = 1 THEN FUNCTION = 0 : EXIT FUNCTION
END SELECT
VScrollNotify = -1 : HScrollNotify = -1
SELECT CASE CBWPARAM
CASE %VK_DELETE
IF ISTRUE CorrectFlag THEN ' Remove character right of caret
res = SendMessage(hEdit, %EM_GETSEL, 0, 0)
j = HIWRD(res) ' Caret position
CONTROL GET TEXT hGrid&,%ID_EDITCHILD TO t
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 ISTRUE CorrectFlag THEN ' Move caret left
res = SendMessage(hEdit, %EM_GETSEL, 0, 0)
j = MAX(HIWRD(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 ISTRUE CorrectFlag THEN ' Move caret right
k = SendMessage(hEdit, %EM_LINELENGTH, 0, 0)
res = SendMessage(hEdit, %EM_GETSEL, 0, 0)
j = MIN(HIWRD(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,MAKLNG(VScrollNotify,0),0
IF HScrollNotify > -1 THEN SendMessage hGrid&,%WM_HSCROLL,MAKLNG(HScrollNotify,0),0
'
END SELECT
' Pass the message on to the original window procedure.
FUNCTION = CallWindowProc(gOldSubClassEdit&, CBHNDL, CBMSG, CBWPARAM, CBLPARAM)
END FUNCTION
'
SUB FinishEdit
LOCAL HScrollNotify AS LONG
IF ISTRUE HeadEditFlag THEN
CONTROL GET TEXT hGrid&,%ID_EDITCHILD TO DataArray(HeadCol,0)
ELSEIF RowHeaderEditFlag = 1 THEN
CONTROL GET TEXT hGrid&,%ID_EDITCHILD TO DataArray(0,EditRow)
RowHeaderEditFlag = 2
ELSE
CONTROL GET TEXT hGrid&,%ID_EDITCHILD TO DataArray(SelectCol,SelectRow)
END IF
EditFlag = %FALSE
CorrectFlag = %FALSE
SendMessage hEdit&,%WM_SETFONT,hFont,MAKLNG(%TRUE,0) ' normal font (default)
ShowWindow hEdit&, %SW_HIDE
SetFocus hGrid&
InvalidateRect hGrid&,BYVAL %NULL, %FALSE
UpdateWindow hGrid&
END SUB
'
'******************************************************************************
'** Program Main Part *********************************************************
'******************************************************************************
' ----------------------------------------------------------
%Form1_FILE = 500
' ----------------------------------------------------------
%Form1_DEFAULT = 505
%Form1_OPENFILE = 510
%Form1_SAVEAS = 515
%Form1_SEPARATOR_524 = 524
%Form1_EXIT = 525
' ----------------------------------------------------------
%Form1_HELP = 700
' ----------------------------------------------------------
%Form1_HELP1 = 705
%Form1_ABOUT = 710
DECLARE FUNCTION InitApplication() AS LONG
DECLARE FUNCTION InitInstance(LONG) AS LONG
GLOBAL g_szClassName AS ASCIIZ * 32
GLOBAL hForm1& ' Dialog handle
GLOBAL hForm1_Menu0&
GLOBAL hForm1_Menu1&
GLOBAL hForm1_Menu3&
GLOBAL PAFU AS STRING ' path and file for input
GLOBAL PAFUout AS STRING ' path and file for output
GLOBAL Delim AS STRING ' Delimiter for saving and loading files
' Set to $TAB (=CHR$(9)) in this program.
' You may change this.
'*******************************************************************************
FUNCTION WINMAIN (BYVAL hInstance AS LONG, _
BYVAL hPrevInstance AS LONG, _
lpCmdLine AS ASCIIZ PTR, _
BYVAL nCmdShow AS LONG) AS LONG
LOCAL Msg AS tagMSG
' Initialize the common control library
CALL InitComCtl32()
IF (ISFALSE(InitApplication())) THEN FUNCTION = %False : EXIT FUNCTION
IF (ISFALSE(InitInstance(nCmdShow))) THEN FUNCTION = %False : EXIT FUNCTION
' Create menu
MENU NEW BAR TO hForm1_Menu0&
' ---------------------------
MENU NEW POPUP TO hForm1_Menu1&
MENU ADD POPUP, hForm1_Menu0& ,"&File", hForm1_Menu1&, %MF_ENABLED
' - - - - - - - - - - - - - -
MENU ADD STRING, hForm1_Menu1&, "Use &Default data", %Form1_DEFAULT, %MF_ENABLED
MENU ADD STRING, hForm1_Menu1&, "&Open Data File", %Form1_OPENFILE, %MF_ENABLED
MENU ADD STRING, hForm1_Menu1&, "Save Data File &As", %Form1_SAVEAS, %MF_GRAYED
MENU ADD STRING, hForm1_Menu1&, "-", %Form1_SEPARATOR_524, %MF_ENABLED
MENU ADD STRING, hForm1_Menu1&, "E&xit", %Form1_EXIT, %MF_ENABLED
MENU NEW POPUP TO hForm1_Menu3&
MENU ADD POPUP, hForm1_Menu0& ,"&Help", hForm1_Menu3&, %MF_ENABLED
' - - - - - - - - - - - - - -
MENU ADD STRING, hForm1_Menu3&, "&Description of program", %Form1_HELP1, %MF_ENABLED
MENU ADD STRING, hForm1_Menu3&, "&About", %Form1_ABOUT, %MF_ENABLED
MENU ATTACH hForm1_Menu0&, hForm1&
ShowWindow hForm1&, nCmdShow
UpdateWindow hForm1&
' Create message loop
WHILE GetMessage(Msg, %NULL, 0, 0)
TranslateMessage Msg
DispatchMessage Msg
WEND
FUNCTION = msg.wParam
END FUNCTION
'*******************************************************************************
FUNCTION InitApplication() AS LONG
LOCAL 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 = CODEPTR(MainWndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = GetModuleHandle(BYVAL %NULL)
wcex.hCursor = LoadCursor( %NULL, BYVAL %IDC_ARROW )
wcex.hbrBackground = GetStockObject(%LTGRAY_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR( 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
LOCAL szTitle AS ASCIIZ * 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, _
BYVAL %NULL, _
BYVAL %NULL, _
GetModuleHandle(BYVAL %NULL), _
BYVAL %NULL)
IF (ISFALSE(hForm1&)) THEN FUNCTION = %False : EXIT FUNCTION
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
LOCAL Xp& ' Horizontal position (upper-left corner)
LOCAL Yp& ' Vertical position (upper-left corner)
LOCAL W& ' Width
LOCAL H& ' Height
'
SendMessage hForm1&, %WM_SETREDRAW, %FALSE, BYVAL %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, BYVAL %NULL ' enable redraw
END SUB
' --------------------------------------------------------------------------
SUB Form1_DEFAULT_Select() ' Produce default data set.
LOCAL I&,hDC&
LOCAL lpSize AS SIZEL
LOCAL st AS ASCIIZ * 250
LOCAL s AS STRING
LOCAL PI2 AS DOUBLE
PI2 = ATN(1) * 8 ' two PI
' Make default test data set.
DATA "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:Columns+1,0:Rows)' Column zero and row zero are used for headers.
REDIM ColWidth(0:Columns+1)
hDC = GetDC(hHead&)
FOR I&=0 TO Columns + 1
IF I&<= Columns THEN
DataArray(I&,0) = READ$(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
INCR Columns ' 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(65,90))+"."+CHR$(RND(65,90))+"."+CHR$(RND(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(38,80)/10+ROUND(VAL(DataArray(3,I&)),0)/10))
DataArray(5,I&)=LTRIM$(STR$(RND(19,70)/10+ROUND(VAL(DataArray(3,I&)),0)/10))
DataArray(6,I&)=LTRIM$(STR$(ROUND(RND(-41,20)/3+VAL(DataArray(3,I&))*2.1,0)))
DataArray(7,I&)=LTRIM$(STR$(ROUND(RND(95,160)+VAL(DataArray(3,I&)),0)))
DataArray(8,I&)=LTRIM$(STR$(ROUND(RND(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
LOCAL 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
LOCAL 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
LOCAL Path AS STRING
LOCAL f AS STRING
LOCAL Style AS DWORD
LOCAL hFile AS LONG
LOCAL 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& = MSGBOX ("Output file name the same as input file name. Do you want this ?",%MB_ICONHAND OR %MB_YESNO, "Problem:")
IF res&=%IDNO THEN GOTO igen
END IF
hFile = FREEFILE
OPEN PAFUout FOR OUTPUT AS hFile
Delim = $TAB ' 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, $CRLF; ' End the line.
NEXT
CLOSE hFile
FUNCTION = 1
END IF
END FUNCTION
' ------------------------------------------------
FUNCTION FilNameOpen() AS LONG
LOCAL Path AS STRING
LOCAL f AS STRING
LOCAL Style AS DWORD
LOCAL hFile AS LONG
LOCAL b$,i&,j&,x&,k&
LOCAL 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 = $TAB
' 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
MSGBOX "This file cannot be read by this program!"+$CRLF+" Try again.",%MB_ICONHAND,"Problem:"
CLOSE hFile
GOTO igen
END IF
k&=0
DO WHILE NOT (EOF(hFile) OR k&>20)
INCR k&
LINE INPUT# hFile, b$
j& = PARSECOUNT(b$,Delim)
IF j&<>x& THEN ' not the same number of fields per line
MSGBOX "This file cannot be read by this program!"+$CRLF+" Try again.",%MB_ICONHAND,"Problem:"
CLOSE hFile
GOTO igen
END IF
LOOP
IF k&<2 THEN ' too few lines
MSGBOX "This file cannot be read by this program!"+$CRLF+" Try again.",%MB_ICONHAND,"Problem:"
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:Columns+1,0: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)
INCR Rows ' number of rows
LINE INPUT# hFile, b$
REDIM PRESERVE DataArray(0:Columns+1,0: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&)
LOCAL lpSize AS SIZEL
LOCAL st AS ASCIIZ * 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
'
INCR Columns ' 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()
LOCAL St AS STRING
St="Header based virtual grid control with cell editing "+$CRLF+$CRLF+ _
"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."+$CRLF+$CRLF+ _
"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."+$CRLF+$CRLF+ _
"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."+$CRLF+$CRLF+ _
"Thanks to the PowerBasic Forum for great inspiration."+$CRLF+$CRLF+ _
"Good luck!"+$CRLF+$CRLF+ _
"Erik Christensen ---- e.chr@email.dk "
MSGBOX St,%MB_ICONINFORMATION,"Virtual grid control with cell editing"
END SUB
' ------------------------------------------------
SUB Form1_ABOUT_Select
LOCAL St AS STRING
St="Virtual grid control program with cell editing, import and export of TAB-separated text (ASCII) files for PB for Windows 7. Program version 1.0 - November 9, 2002"+$CRLF+$CRLF+ _
"By Erik Christensen, Copenhagen, Denmark e.chr@email.dk"+$CRLF+$CRLF+ _
"The use of this Public Domain program and its consequences are your own responsibility. However, any comment you may have is welcome."+$CRLF+$CRLF+ _
"Good Luck!"
MSGBOX St,%MB_ICONINFORMATION,"About this program"
END SUB
' ------------------------------------------------
CALLBACK FUNCTION MainWndProc
DIM MinMaxPtr AS MINMAXINFO PTR
DIM hStatusBar AS STATIC DWORD
DIM StatusText AS ASCIIZ * 250
STATIC First AS LONG
LOCAL rc AS RECT, i&,j&,Res&
DIM StatusBarHeight AS STATIC LONG
SELECT CASE CBMSG
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:Columns+1,0:Rows)' Column zero and row zero are used for headers.
REDIM ColWidth(0: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", BYVAL 0, %WS_VISIBLE OR _
%WS_CHILD OR %WS_HSCROLL OR %WS_VSCROLL OR %WS_BORDER, _
0,0,0,0,CBHNDL, %FORM1_GRID, GetModuleHandle(BYVAL %NULL), BYVAL 0)
' Adapt window to Work Area on screen (desktop).
SystemParametersInfo %SPI_GETWORKAREA, 0, BYVAL VARPTR(Rc), 0
MoveWindow CBHNDL, 0, 0, Rc.nRight - Rc.nLeft, Rc.nBottom - Rc.nTop, 0
'
' The next few lines define a status bar.
' NB: The area of the status bar is subtracted from the available client area.
GetClientRect CBHNDL, rc
hStatusBar = CreateStatusWindow(%SBARS_SIZEGRIP OR %WS_CHILD OR %WS_VISIBLE OR %WS_CLIPSIBLINGS OR %CCS_BOTTOM, "", CBHNDL, 0)
StatusText = " Dialog Size in pixels: X: "+FORMAT$(rc.nRight,"####")+" Y: "+FORMAT$(rc.nBottom,"####")
SendMessage hStatusBar, %WM_SETTEXT, 0, VARPTR(StatusText)
GetClientRect hStatusBar, rc
StatusBarHeight& = rc.nBottom
ShowWindow hGrid&, %SW_SHOW
First = 1
END IF
'
CASE %WM_SIZE
' Get size of dialog after tracking.
GetClientRect CBHNDL, rc
' Resize status bar
MoveWindow hStatusBar, rc.nLeft,rc.nBottom-StatusBarHeight, _
rc.nRight - rc.nLeft, StatusBarHeight, %TRUE
' Perform proportional resizing of controls.
CALL ResizeControls(rc.nRight,rc.nBottom)
StatusText = " Dialog Size in pixels: X: "+FORMAT$(rc.nRight,"####")+" Y: "+FORMAT$(rc.nBottom,"####")
SendMessage hStatusBar, %WM_SETTEXT, 0, VARPTR(StatusText)
InvalidateRect CBHNDL, BYVAL %NULL, %FALSE
'
CASE %WM_GETMINMAXINFO
MinMaxPtr=CBLPARAM
' 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 LOWRD(CBWPARAM)
' 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(CBHNDL, CBMSG, CBWPARAM, CBLPARAM)
END FUNCTION
' ------------------------------------------------
PowerBASIC Forums
UBBFriend: Email This Page to Someone! 
posted November 09, 2002 01:44 AM
