Code: Select all
#Include Once "babygrid.bi"
'function forward declarations
'BABYGRID code originaly by David Hillard translated to FreeBasic by ALOBER
'This code must retain this copyright message
Function ShowLastError()As DWORD
Dim As DWORD nLastError ' Numéro de l'erreur
Dim As LPTSTR lpMessageBuffer ' Récupération du message
nLastError = GetLastError()
/' Formatage du message '/
FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER Or FORMAT_MESSAGE_FROM_SYSTEM, _
NULL, nLastError, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), _
Cast(PVOID Ptr,@lpMessageBuffer), 0, NULL)
/' Affichage du message '/
MessageBox(NULL, lpMessageBuffer, "ERROR", MB_OK Or MB_ICONERROR)
LocalFree(lpMessageBuffer)
return nLastError
End Function
Function HomeColumnNthVisible(ByVal SI As Integer) As Integer
Dim j As Integer
Dim hc As Integer
Dim count As Integer
count = 0
hc = BGHS(SI).homecol
For j = 1 To hc
If BGHS(SI).columnwidths(j)>0 Then
count += 1
End If
Next j
Return count
End Function
Sub RefreshGrid(ByVal hWnd As HWND)
Dim rect As RECT
Dim SI As Integer
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 0)
SI = FindGrid(CUInt(GetMenu(hWnd)))
If BGHS(SI).EDITING <> 0 Then
DisplayEditString(hWnd, SI, "")
End If
End Sub
Function GetNextColWithWidth(ByVal SI As Integer, ByVal startcol As Integer, ByVal direction As Integer) As Integer
'calls with direction == 1 for right, direction == -1 for left
'returns 0 if no more cols in that direction, else column number
Dim j As Integer
Dim ReturnValue As Integer
j = startcol
If direction = 1 Then
j += 1
End If
If direction <> 1 Then
j -= 1
End If
Do While (BGHS(SI).columnwidths(j) = 0) And (j<=BGHS(SI).cols) And (j>0)
If direction = 1 Then
j += 1
End If
If direction <> 1 Then
j -= 1
End If
Loop
If (BGHS(SI).columnwidths(j) > 0) And (j<=BGHS(SI).cols) Then
ReturnValue = j
Else
ReturnValue = 0
End If
Return ReturnValue
End Function
Function GetRowOfMouse(ByVal SI As Integer, ByVal y As Integer) As Integer
Dim ReturnValue As Integer
If y<=(BGHS(SI).titleheight) Then
Return -1
End If
If (y>=BGHS(SI).titleheight) And (y<=BGHS(SI).headerrowheight + BGHS(SI).titleheight) Then
Return 0
End If
y = y-(BGHS(SI).headerrowheight + BGHS(SI).titleheight)
y = y\BGHS(SI).rowheight
ReturnValue = BGHS(SI).homerow + y
If ReturnValue > BGHS(SI).rows Then
ReturnValue = -1
End If
Return ReturnValue
End Function
Function GetColOfMouse(ByVal SI As Integer, ByVal x As Integer) As Integer
Dim ReturnValue As Integer
Dim j As Integer
If x<=BGHS(SI).columnwidths(0) Then
Return 0
End If
x-=BGHS(SI).columnwidths(0)
j = BGHS(SI).homecol
Do While x>0
x-=BGHS(SI).columnwidths(j)
j += 1
Loop
j -= 1
ReturnValue = j
If BGHS(SI).EXTENDLASTCOLUMN <> 0 Then
If j>BGHS(SI).cols Then
ReturnValue = BGHS(SI).cols
End If
Else
If j>BGHS(SI).cols Then
ReturnValue = -1
End If
End If
Return ReturnValue
End Function
Function OutOfRange(ByVal cell As LPBGCELL) As BOOL
If (cell->row >MAX_ROWS) Or (cell->col > MAX_COLS) Then
Return TRUE
Else
Return FALSE
End If
End Function
Sub SetCell(cell As LPBGCELL , row As Integer, col As Integer)
cell->row = row
cell->col = col
End Sub
Function DetermineDataType(ByVal data_ As String ) As Integer
'return values:
' 1 = Text or Alpha
' 2 = Numeric
' 3 = Boolean TRUE
' 4 = Boolean FALSE
' 5 = Graphic - user drawn (cell text begins with ~)
Dim j As Integer
Dim k As Integer
Dim numberofperiods As Integer
Dim tbuffer As ZSTRING*1000
Dim DIGIT As Integer
Dim ALPHA_ As Integer
Dim WHITESPACE As Integer
strcpy(tbuffer,data_) 'tbuffer = *data_
tbuffer=Trim(tbuffer)
k = Len(tbuffer)
tbuffer=Ucase(tbuffer)
'is it boolean?
If 0=StrCmp(tbuffer,"TRUE") Then
Return 3
End If
If 0=StrCmp(tbuffer,"FALSE") Then
Return 4
End If
'is it graphic (~)
If tbuffer[0]=Asc("~") Then
Return 5
End If
DIGIT = 0
ALPHA_ = 0
WHITESPACE = 0
numberofperiods = 0
For j = 0 To k - 1
If isalpha(tbuffer[j]) Then
ALPHA_ = 1
End If
If IsDigit(tbuffer[j]) Then
DIGIT = 1
End If
If iswspace(tbuffer[j]) Then
WHITESPACE = 1
End If
If tbuffer[j]=Asc(".") Then
numberofperiods += 1
End If
If tbuffer[j]=Asc("+") Then
If j>0 Then
ALPHA_ = 1
End If
End If
If tbuffer[j]=Asc("-") Then
If j>0 Then
ALPHA_ = 1
End If
End If
Next j
If (ALPHA_) Or (WHITESPACE) Then
Return 1
End If
If (DIGIT) And ((0=ALPHA_)) And ((0=WHITESPACE)) Then
If numberofperiods>1 Then
Return 1
Else
Return 2
End If
End If
Return 1
End Function
Sub CalcVisibleCellBoundaries(ByVal SelfIndex As Integer)
Dim gridx As Integer
Dim gridy As Integer
Dim j As Integer
gridx = BGHS(SelfIndex).gridwidth
gridy = BGHS(SelfIndex).gridheight
j = BGHS(SelfIndex).homecol
BGHS(SelfIndex).leftvisiblecol = BGHS(SelfIndex).homecol
BGHS(SelfIndex).topvisiblerow = BGHS(SelfIndex).homerow
'calc columns visible
'first subtract the width of col 0;
gridx = gridx - BGHS(SelfIndex).columnwidths(0)
Do
gridx = gridx - BGHS(SelfIndex).columnwidths(j)
j += 1
Loop While (gridx >= 0) And (j<BGHS(SelfIndex).cols)
If j>BGHS(SelfIndex).cols Then
j = BGHS(SelfIndex).cols
End If
BGHS(SelfIndex).rightvisiblecol = j
'calc rows visible;
gridy = gridy - BGHS(SelfIndex).headerrowheight
j = BGHS(SelfIndex).homerow
Do
gridy = gridy - BGHS(SelfIndex).rowheight
j += 1
Loop While (gridy > 0) And (j<BGHS(SelfIndex).rows)
If j>BGHS(SelfIndex).rows Then
j = BGHS(SelfIndex).rows
End If
BGHS(SelfIndex).bottomvisiblerow = j
End Sub
Function GetCellRect(ByVal hWnd As HWND, ByVal SI As Integer, ByVal r As Integer, ByVal c As Integer) As RECT
Dim rect As RECT
Dim offset As Integer
Dim j As Integer
'c and r must be greater than zero
'get column offset
'first get col 0 width
offset = BGHS(SI).columnwidths(0)
For j = BGHS(SI).homecol To c - 1
offset += BGHS(SI).columnwidths(j)
Next j
rect.left = offset
rect.right = offset + BGHS(SI).columnwidths(c)
If BGHS(SI).EXTENDLASTCOLUMN <> 0 Then
'see if this is the last column
If 0=GetNextColWithWidth(SI, c, 1) Then
'extend this column
Dim trect As RECT
Dim temp As Integer
GetClientRect(hWnd, @trect)
temp = (offset +(trect.right - rect.left))-rect.left
If temp > BGHS(SI).columnwidths(c) Then
rect.right = offset + (trect.right - rect.left)
End If
End If
End If
'now get the top and bottom of the rect
offset = BGHS(SI).headerrowheight+BGHS(SI).titleheight
For j = BGHS(SI).homerow To r - 1
offset += BGHS(SI).rowheight
Next j
rect.top = offset
rect.bottom = offset + BGHS(SI).rowheight
Return rect
End Function
Sub DisplayTitle(ByVal hWnd As HWND, ByVal SI As Integer, ByVal hfont As HFONT)
Dim rect As RECT
Dim gdc As HDC
Dim holdfont As HFONT
GetClientRect(hWnd, @rect)
gdc = GetDC(hWnd)
SetBkMode(gdc,TRANSPARENT)
holdfont = Cast(HFONT,(SelectObject(gdc,hfont)))
rect.bottom = BGHS(SI).titleheight
DrawEdge(gdc, @rect, EDGE_ETCHED, BF_MIDDLE Or BF_RECT Or BF_ADJUST)
DrawTextEx(gdc, BGHS(SI).title, -1, @rect, DT_END_ELLIPSIS Or DT_CENTER Or DT_WORDBREAK Or DT_NOPREFIX, NULL)
SelectObject(gdc,holdfont)
ReleaseDC(hWnd,gdc)
End Sub
Sub DisplayColumn(ByVal hWnd As HWND, ByVal SI As Integer, ByVal c As Integer, ByVal offset As Integer, ByVal hfont As HFONT, ByVal hcolumnheadingfont As HFONT)
Dim gdc As HDC
Dim rect As RECT
Dim rectsave As RECT
Dim holdfont As HFONT
Dim r As Integer
Dim buffer As ZSTRING*1000
Dim iDataType As Integer
Dim iProtection As Integer
If BGHS(SI).columnwidths(c)=0 Then
Return
End If
gdc = GetDC(hWnd)
SetBkMode(gdc,TRANSPARENT)
ShowHscroll(hWnd,SI)
ShowVscroll(hWnd, SI)
holdfont = Cast(HFONT,SelectObject(gdc,hcolumnheadingfont))
SetTextColor(gdc,BGHS(SI).textcolor)
'display header row
r = 0
rect.left = offset + 0
rect.top = BGHS(SI).titleheight '0
rect.right = BGHS(SI).columnwidths(c) + offset
rect.bottom = BGHS(SI).headerrowheight + BGHS(SI).titleheight
If BGHS(SI).EXTENDLASTCOLUMN Then
'see if this is the last column
If 0=GetNextColWithWidth(SI,c,1) Then
'extend this column
Dim trect As RECT
GetClientRect(hWnd, @trect)
rect.right = offset + (trect.right - rect.left)
End If
Else
If 0=GetNextColWithWidth(SI,c,1) Then
'repaint right side of grid
Dim trect As RECT
Dim holdbrush As HBRUSH
Dim holdpen As HPEN
GetClientRect(hWnd, @trect)
trect.left=offset+(rect.right-rect.left)
holdbrush = Cast(HBRUSH,SelectObject(gdc,GetStockObject(GRAY_BRUSH)))
holdpen = Cast(HPEN,SelectObject(gdc,GetStockObject(NULL_PEN)))
Rectangle(gdc,trect.left,trect.top+BGHS(SI).titleheight,trect.right+1,trect.bottom+1)
SelectObject(gdc,holdbrush)
SelectObject(gdc,holdpen)
End If
End If
SetCell(@BGcell, r, c)
strcpy(buffer,"")
SendMessage(hWnd, BGM_GETCELLDATA, CUInt(@BGcell), CInt(StrPtr(buffer)))
If BGHS(SI).COLUMNSNUMBERED Then
If c>0 Then
Dim high As Integer
Dim low As Integer
high = ((c-1)/26)
low = c Mod 26
If high = 0 Then
high = 32
Else
high +=64
End If
If low = 0 Then
low = 26
End If
low += 64
wsprintf(buffer,!"%c%c",high,low)
End If
End If
rectsave = rect
DrawEdge(gdc, @rect, EDGE_ETCHED, BF_MIDDLE Or BF_RECT Or BF_ADJUST)
DrawTextEx(gdc, buffer, -1, @rect, DT_END_ELLIPSIS Or DT_CENTER Or DT_WORDBREAK Or DT_NOPREFIX, NULL)
rect = rectsave
r = BGHS(SI).topvisiblerow
'set font for grid body
SelectObject(gdc,hfont)
Do While r<=BGHS(SI).bottomvisiblerow
'try to set cursor row to different display color
If (r = BGHS(SI).cursorrow) And (c>0) And (BGHS(SI).DRAWHIGHLIGHT) Then
If BGHS(SI).GRIDHASFOCUS Then
SetTextColor(gdc,BGHS(SI).highlighttextcolor)
Else
SetTextColor(gdc,_RGB(0,0,0)) 'set black text for nonfocus grid hilight
End If
Else
SetTextColor(gdc,_RGB(0,0,0))
End If
rect.top = rect.bottom
rect.bottom = rect.top + BGHS(SI).rowheight
rectsave = rect
SetCell(@BGcell, r, c)
strcpy(buffer,"")
SendMessage(hWnd, BGM_GETCELLDATA, cUInt(@BGcell), CInt(StrPtr(buffer)))
If (c = 0) And (BGHS(SI).ROWSNUMBERED) Then
wsprintf(buffer,!"%d",r)
End If
If c = 0 Then
DrawEdge(gdc, @rect, EDGE_ETCHED, BF_MIDDLE Or BF_RECT Or BF_ADJUST)
Else
Dim hbrush As HBRUSH
Dim holdbrush As HBRUSH
Dim hpen As HPEN
Dim holdpen As HPEN
iProtection = SendMessage(hWnd, BGM_GETPROTECTION, CUInt(@BGcell), 0)
If BGHS(SI).DRAWHIGHLIGHT Then 'highlight on
If r = BGHS(SI).cursorrow Then
If BGHS(SI).GRIDHASFOCUS Then
hbrush = CreateSolidBrush(BGHS(SI).highlightcolor)
Else
hbrush = CreateSolidBrush(_RGB(200,200,200))
End If
Else
If iProtection = 1 Then
hbrush = CreateSolidBrush(BGHS(SI).protectcolor)
Else
hbrush = CreateSolidBrush(BGHS(SI).unprotectcolor)
End If
End If
Else
If iProtection = 1 Then
hbrush = CreateSolidBrush(BGHS(SI).protectcolor)
Else
hbrush = CreateSolidBrush(BGHS(SI).unprotectcolor)
End If
End If
hpen = CreatePen(PS_SOLID,1,BGHS(SI).gridlinecolor)
holdbrush = Cast(HBRUSH,SelectObject(gdc,hbrush))
holdpen = Cast(HPEN,SelectObject(gdc,hpen))
Rectangle(gdc,rect.left,rect.top,rect.right,rect.bottom)
SelectObject(gdc,holdbrush)
SelectObject(gdc,holdpen)
DeleteObject(hbrush)
DeleteObject(hpen)
End If
rect.right -= 2
rect.left += 2
iDataType = SendMessage(hWnd, BGM_GETTYPE, CUInt(@BGcell), 0)
If (iDataType < 1) or (iDataType > 5) Then
iDataType = 1 'default to alphanumeric data type.. can't happen
End If
If c = 0 Then
iDataType = 2
End If
If iDataType = 1 Then 'ALPHA
If BGHS(SI).ELLIPSIS Then
DrawTextEx(gdc, buffer , -1, @rect, DT_END_ELLIPSIS Or DT_LEFT Or DT_VCENTER Or DT_SINGLELINE Or DT_NOPREFIX, NULL)
Else
DrawTextEx(gdc, buffer , -1, @rect, DT_LEFT Or DT_WORDBREAK Or DT_EDITCONTROL Or DT_NOPREFIX, NULL)
End If
End If
If iDataType = 2 Then 'NUMERIC
DrawTextEx(gdc, buffer , -1, @rect, DT_END_ELLIPSIS Or DT_RIGHT Or DT_VCENTER Or DT_SINGLELINE Or DT_NOPREFIX, NULL)
End If
If iDataType = 3 Then 'BOOLEAN TRUE
Dim k As Integer
Dim excess As Integer
k = 2
rect.top +=k
rect.bottom -=k
rect.left +=0
rect.right -=0
If (rect.bottom - rect.top)>24 Then
excess = (rect.bottom - rect.top)-16
rect.top += CInt((excess\2))
rect.bottom -= CInt((excess\2))
End If
DrawFrameControl(gdc, @rect, DFC_BUTTON, DFCS_BUTTONCHECK Or DFCS_CHECKED)
End If
If iDataType = 4 Then 'BOOLEAN FALSE
Dim k As Integer
Dim excess As Integer
k = 2
rect.top +=k
rect.bottom -=k
rect.left +=0
rect.right -=0
If (rect.bottom - rect.top)>24 Then
excess = (rect.bottom - rect.top)-16
rect.top += CInt((excess\2))
rect.bottom -= CInt((excess\2))
End If
DrawFrameControl(gdc, @rect, DFC_BUTTON, DFCS_BUTTONCHECK)
End If
If iDataType = 5 Then 'user drawn graphic
Dim wParam As WPARAM
buffer[0]=&H20
BGHS(SI).ownerdrawitem = CInt(buffer)
wParam = MAKEWPARAM(CUInt(GetMenu(hWnd)),BGN_OWNERDRAW)
SendMessage(GetParent(hWnd), WM_COMMAND, wParam, CLng(@rect))
End If
If BGHS(SI).EDITING Then
DisplayEditString(hWnd,SI,"")
End If
rect = rectsave
r += 1
Loop 'end while r<=bottomvisiblerow
'repaint bottom of grid
Dim trect As RECT
Dim holdbrush As HBRUSH
Dim holdpen As HPEN
GetClientRect(hWnd, @trect)
trect.top = rect.bottom
trect.left = rect.left
trect.right = rect.right
holdbrush = Cast(HBRUSH,SelectObject(gdc,GetStockObject(GRAY_BRUSH)))
holdpen = Cast(HPEN,SelectObject(gdc,GetStockObject(NULL_PEN)))
Rectangle(gdc,trect.left,trect.top,trect.right+1,trect.bottom+1)
SelectObject(gdc,holdbrush)
SelectObject(gdc,holdpen)
SelectObject(gdc,holdfont)
DeleteObject(holdfont)
ReleaseDC(hWnd,gdc)
End Sub
Sub DrawCursor(ByVal hWnd As HWND, ByVal SI As Integer)
Dim rect As RECT
Dim rectwhole As RECT
Dim gdc As HDC
Dim hpen As HPEN
Dim holdpen As HPEN
Dim rop As Integer
If BGHS(SI).rows = 0 Then
Return
End If
GetClientRect(hWnd, @rect)
'if active cell has scrolled off the top, don't draw a focus rectangle
If BGHS(SI).cursorrow < BGHS(SI).homerow Then Return
'if active cell has scrolled off to the left, don't draw a focus rectangle
If BGHS(SI).cursorcol < BGHS(SI).homecol Then Return
rect = GetCellRect(hWnd,SI,BGHS(SI).cursorrow,BGHS(SI).cursorcol)
rectwhole = rect
gdc = GetDC(hWnd)
BGHS(SI).activecellrect = rect
rop = GetROP2(gdc)
SetROP2(gdc,R2_XORPEN)
SelectObject(gdc,Cast(HBRUSH,GetStockObject(NULL_BRUSH)))
hpen = CreatePen(PS_SOLID,3,BGHS(SI).cursorcolor) 'width of 3
holdpen = Cast(HPEN,SelectObject(gdc,hpen))
Rectangle(gdc,rect.left,rect.top,rect.right,rect.bottom)
SelectObject(gdc,holdpen)
DeleteObject(hpen)
SetROP2(gdc,rop)
ReleaseDC(hWnd,gdc)
End Sub
Sub SetCurrentCellStatus(ByVal hWnd As HWND, ByVal SelfIndex As Integer)
SetCell(@BGcell, BGHS(SelfIndex).cursorrow, BGHS(SelfIndex).cursorcol)
If SendMessage(hWnd, BGM_GETPROTECTION, CUInt(@BGcell), 0) Then
BGHS(SelfIndex).CURRENTCELLPROTECTED = 1
Else
BGHS(SelfIndex).CURRENTCELLPROTECTED = 0
End If
End Sub
Function GetASCII(ByVal wParam As WPARAM, ByVal lParam As LPARAM) As BYTE
Dim returnvalue As Integer
Dim mbuffer As ZString*100
Dim result As Integer
Dim keys(255) As Byte
Dim dwReturnedValue As WORD
GetKeyboardState(@keys(0))
result = ToAscii_(CUInt(wParam), CUInt((lParam Shr 16) And &Hff), @keys(0), @dwReturnedValue, 0)
returnvalue = CByte(dwReturnedValue)
If returnvalue < 0 Then
returnvalue = 0
End If
wsprintf(mbuffer,!"return value = %d",returnvalue)
If result<>1 Then
returnvalue = 0
End If
Return CByte(returnvalue)
End Function
Sub SetHomeRow(ByVal hWnd As HWND, ByVal SI As Integer, ByVal row As Integer, ByVal col As Integer)
Dim gridrect As RECT
Dim cellrect As RECT
'get rect of grid window
GetClientRect(hWnd, @gridrect)
'get rect of current cell
cellrect = GetCellRect(hWnd,SI,row,col)
If (cellrect.bottom > gridrect.bottom) And ((cellrect.bottom - cellrect.top)<(gridrect.bottom-(BGHS(SI).headerrowheight+BGHS(SI).titleheight))) Then
Do While cellrect.bottom > gridrect.bottom
BGHS(SI).homerow += 1
If row = BGHS(SI).rows Then
gridrect.top = gridrect.bottom - (BGHS(SI).rowheight)
InvalidateRect(hWnd, @gridrect, 1)
Else
InvalidateRect(hWnd, @gridrect, 0)
End If
cellrect = GetCellRect(hWnd,SI,row,col)
Loop
Else
If (cellrect.bottom - cellrect.top)>=(gridrect.bottom - (BGHS(SI).headerrowheight+BGHS(SI).titleheight)) Then
BGHS(SI).homerow += 1
End If
End If
cellrect = GetCellRect(hWnd,SI,row,col)
Do While (row < BGHS(SI).homerow)
BGHS(SI).homerow -= 1
InvalidateRect(hWnd, @gridrect, 0)
cellrect = GetCellRect(hWnd,SI,row,col)
Loop
'set the vertical scrollbar position
SetScrollPos(hWnd,SB_VERT,BGHS(SI).homerow,1)
End Sub
Sub SetHomeCol(ByVal hWnd As HWND, ByVal SI As Integer, ByVal row As Integer, ByVal col As Integer)
Dim gridrect As RECT
Dim cellrect As RECT
'get rect of grid window
GetClientRect(hWnd, @gridrect)
'get rect of current cell
cellrect = GetCellRect(hWnd,SI,row,col)
'determine if scroll left or right is needed
Do While (cellrect.right > gridrect.right) And (cellrect.left <> BGHS(SI).columnwidths(0))
'scroll right is needed
BGHS(SI).homecol += 1
cellrect = GetCellRect(hWnd,SI,row,col)
InvalidateRect(hWnd, @gridrect, 0)
Loop
cellrect = GetCellRect(hWnd,SI,row,col)
Do While (BGHS(SI).cursorcol < BGHS(SI).homecol) And (BGHS(SI).homecol > 1)
'scroll left is needed
BGHS(SI).homecol -= 1
cellrect = GetCellRect(hWnd,SI,row,col)
InvalidateRect(hWnd, @gridrect, 0)
Dim k As Integer
k = HomeColumnNthVisible(SI)
SetScrollPos(hWnd,SB_HORZ,k,1)
Loop
End Sub
Sub ShowVscroll(ByVal hWnd As HWND, ByVal SI As Integer)
'if more rows than can be visible on grid, display vertical scrollbar
'otherwise, hide it.
Dim gridrect As RECT
Dim totalpixels As Integer
Dim rowsvisibleonscreen As Integer
GetClientRect(hWnd, @gridrect)
totalpixels = gridrect.bottom
totalpixels -= BGHS(SI).titleheight
totalpixels -= BGHS(SI).headerrowheight
totalpixels -= (BGHS(SI).rowheight * BGHS(SI).rows)
rowsvisibleonscreen = (gridrect.bottom - (BGHS(SI).headerrowheight+BGHS(SI).titleheight)) / BGHS(SI).rowheight
If totalpixels < 0 Then
'show vscrollbar
ShowScrollBar(hWnd,SB_VERT,1)
SetScrollRange(hWnd,SB_VERT,1,(BGHS(SI).rows-rowsvisibleonscreen)+1,1)
BGHS(SI).VSCROLL = 1
Else
'hide vscrollbar
ShowScrollBar(hWnd,SB_VERT,0)
BGHS(SI).VSCROLL = 0
End If
End Sub
Sub ShowHscroll(ByVal hWnd As HWND, ByVal SI As Integer)
'if more rows than can be visible on grid, display vertical scrollbar
'otherwise, hide it.
Dim gridrect As RECT
Dim totalpixels As Integer
Dim colswithwidth As Integer
Dim j As Integer
GetClientRect(hWnd, @gridrect)
totalpixels = gridrect.right
totalpixels -= BGHS(SI).columnwidths(0)
colswithwidth = 0
For j = 1 To BGHS(SI).cols
totalpixels -= BGHS(SI).columnwidths(j)
If BGHS(SI).columnwidths(j)>0 Then
colswithwidth += 1
End If
Next j
If totalpixels < 0 Then
'show hscrollbar
ShowScrollBar(hWnd,SB_HORZ,1)
SetScrollRange(hWnd,SB_HORZ,1,colswithwidth,1)
BGHS(SI).HSCROLL = 1
Else
'hide hscrollbar
ShowScrollBar(hWnd,SB_HORZ,0)
BGHS(SI).HSCROLL = 0
End If
End Sub
Sub NotifyRowChanged(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_ROWCHANGED)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_SELCHANGE)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyColChanged(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_COLCHANGED)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_SELCHANGE)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyEndEdit(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_EDITEND)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyDelete(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_DELETECELL)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyEditBegin(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_EDITBEGIN)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyEditEnd(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_EDITEND)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyF1(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_F1)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyF2(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_F2)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyF3(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_F3)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyF4(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_F4)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyF5(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_F5)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyF6(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_F6)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyF7(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_F7)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyF8(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_F8)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyF9(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_F9)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyF10(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_F10)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyF11(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_F11)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyF12(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_F12)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub NotifyCellClicked(ByVal hWnd As HWND, ByVal SI As Integer)
Dim wParam As WPARAM
Dim lParam As LPARAM
lParam = MAKELPARAM(BGHS(SI).cursorrow,BGHS(SI).cursorcol)
wParam = MAKEWPARAM(CUInt(BGHS(SI).gridmenu),BGN_CELLCLICKED)
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
End Sub
Sub GetVisibleColumns(ByVal hWnd As HWND, ByVal SI As Integer)
Dim j As Integer
Dim value As Integer
value = 0
For j = 1 To BGHS(SI).cols
If BGHS(SI).columnwidths(j) > 0 Then
value += 1
End If
Next j
BGHS(SI).visiblecolumns = value
SetScrollRange(hWnd,SB_HORZ,1,value,1)
End Sub
Function GetNthVisibleColumn(ByVal hWnd As HWND, ByVal SI As Integer, ByVal n As Integer) As Integer
Dim j As Integer
Dim count As Integer
Dim value As Integer
j = 1
count = 0
value = n-1
Do While j<=BGHS(SI).cols
If BGHS(SI).columnwidths(j)>0 Then
count += 1
If count = n Then
value = j
End If
End If
j += 1
Loop
Return value
End Function
Sub CloseEdit(ByVal hWnd As HWND, ByVal SI As Integer)
Dim r As Integer
Dim c As Integer
Dim cell As _BGCELL
r = BGHS(SI).cursorrow
c = BGHS(SI).cursorcol
cell.row = r
cell.col = c
SendMessage(hWnd, BGM_SETCELLDATA, CUInt(@cell), Clng(StrPtr(BGHS(SI).editstring)))
BGHS(SI).editstring = ""
RefreshGrid(hWnd)
BGHS(SI).EDITING = 0
HideCaret(hWnd)
NotifyEditEnd(hWnd, SI)
End Sub
Sub DisplayEditString(ByVal hWnd As HWND, ByVal SI As Integer, ByVal tstring As ZString Ptr)
Dim r As Integer
Dim c As Integer
Dim holdfont As HFONT
Dim rt As RECT
Dim cdc As HDC
r = BGHS(SI).cursorrow
c = BGHS(SI).cursorcol
ShowCaret(hWnd)
If (r<BGHS(SI).homerow) Or (c<BGHS(SI).homecol) Then
HideCaret(hWnd)
Return
End If
rt = GetCellRect(hWnd,SI,r,c)
rt.top += 2
rt.bottom -= 2
rt.right -=2
rt.left += 2
cdc = GetDC(hWnd)
Rectangle(cdc,rt.left,rt.top,rt.right,rt.bottom)
rt.top += 2
rt.bottom -= 2
rt.right -= 2
rt.left += 2
If Len(BGHS(SI).editstring)<=300 Then
BGHS(SI).editstring &= *tstring
BGHS(SI).editstringdisplay = BGHS(SI).editstring
Else
MessageBeep(0)
End If
holdfont = Cast(HFONT,SelectObject(cdc,BGHS(SI).hfont))
rt.right -= 5
DrawText(cdc, BGHS(SI).editstringdisplay, -1, @rt, DT_RIGHT Or DT_VCENTER Or DT_SINGLELINE)
rt.right +=5
ShowCaret(hWnd)
Dim rh As Integer
Dim ah As Integer
rh = BGHS(SI).rowheight
ah = BGHS(SI).fontascentheight
SetCaretPos(rt.right-4,rt.top+CInt((rh\2))-ah+2)
SelectObject(cdc,holdfont)
ReleaseDC(hWnd,cdc)
End Sub
'//////////////////////////////////////////////////////////////////////
'//////////////////////////////////////////////////////////////////////
'//////////////////////////////////////////////////////////////////////
Function RegisterGridClass(ByVal hInstance As Const HINSTANCE) As ATOM
'initialize BGHS structure
Dim j As Integer
Dim k As Integer
For j = 0 To MAX_GRIDS - 1
BGHS(j).gridmenu = 0
BGHS(j).hlist1 = NULL
BGHS(j).protect = "U"
BGHS(j).rows = 100
BGHS(j).cols = 255
BGHS(j).homerow = 1
BGHS(j).homecol = 1
BGHS(j).rowheight = 21
BGHS(j).headerrowheight = 21
BGHS(j).ROWSNUMBERED = 1
BGHS(j).COLUMNSNUMBERED = 1
BGHS(j).EDITABLE = 0
BGHS(j).EDITING = 0
BGHS(j).AUTOROW = 1
BGHS(j).cursorcol = 1
BGHS(j).cursorrow = 1
BGHS(j).columnwidths(0)=50
BGHS(j).ADVANCEROW = 1
BGHS(j).DRAWHIGHLIGHT = 1
BGHS(j).cursorcolor = _RGB(255,255,255)
BGHS(j).protectcolor = _RGB(255,255,255)
BGHS(j).unprotectcolor = _RGB(255,255,255)
BGHS(j).highlightcolor = _RGB(0,0,128)
BGHS(j).gridlinecolor = _RGB(220,220,220)
BGHS(j).highlighttextcolor = _RGB(255,255,255)
BGHS(j).textcolor = _RGB(0,0,0)
BGHS(j).titleheight = 0
BGHS(j).EXTENDLASTCOLUMN = 1
BGHS(j).SHOWINTEGRALROWS = 1
BGHS(j).SIZING = 0
BGHS(j).ELLIPSIS = 1
BGHS(j).COLAUTOWIDTH = 0
BGHS(j).COLUMNSIZING = 0
BGHS(j).ALLOWCOLUMNRESIZING = 0
BGHS(j).cursortype = 0
BGHS(j).hcolumnheadingfont = NULL
BGHS(j).htitlefont = NULL
BGHS(j).editstring = ""
For k = 1 To MAX_COLS - 1
BGHS(j).columnwidths(k)=50
Next k
Next j
Dim wcx As WNDCLASSEX
wcx.cbClsExtra=0
wcx.cbSize=sizeof(WNDCLASSEX)
wcx.cbWndExtra=0
wcx.hCursor=NULL
wcx.hIcon=NULL
wcx.hIconSm=NULL
wcx.hInstance = hInstance
wcx.hbrBackground=Cast(HBRUSH,GetStockObject(GRAY_BRUSH))
wcx.lpfnWndProc=@GridProc
wcx.lpszClassName=StrPtr("BABYGRID")
wcx.lpszMenuName=NULL
wcx.style=CS_BYTEALIGNCLIENT
Return RegisterClassEx(@wcx)
End Function
Sub SizeGrid(ByVal hWnd As HWND, ByVal SI As Integer)
SendMessage(hWnd,WM_SIZE,SIZE_MAXIMIZED,MAKELPARAM(BGHS(SI).wannabewidth,BGHS(SI).wannabeheight))
SendMessage(hWnd,WM_SIZE,SIZE_MAXIMIZED,MAKELPARAM(BGHS(SI).wannabewidth,BGHS(SI).wannabeheight))
End Sub
Function FindLongestLine(ByVal hdc As HDC, ByVal text As zstring Ptr, ByVal size As SIZE Ptr) As Integer
Dim longest As Integer
Dim lines As Integer
Dim j As Integer
Dim temptext As ZSTRING*1000
Dim p As String
longest = 0
lines = 1
For j = 0 To CInt(strLen(text))- 1
If text[j] = Asc(Lf) Then
lines += 1
End If
Next j
temptext = *text
p=*strtok(temptext,!"\n")
Do While (p <> "")
GetTextExtentPoint32(hdc,p,Len(p),size)
If size->cx > longest Then
longest = size->cx
End If
p = *strtok(!"\0",!"\n")
Loop
'MessageBox(NULL,text,"FindLongestLine",MB_OK)
Return longest
End Function
Function GridProc(ByVal hWnd As HWND, ByVal message As UINT, ByVal wParam As WPARAM, ByVal lParam As LPARAM) As Integer
Dim wmId As Integer
Dim ps As PAINTSTRUCT
Dim hdc As HDC
Dim buffer As ZSTRING*1000
Dim SelfIndex As Integer
Dim ReturnValue As Integer
Dim hInst As HINSTANCE
Dim iDataType As Integer
SelfIndex = FindGrid(CUInt(GetMenu(hWnd)))
'update the grid width and height variable
Static rect As RECT
GetClientRect(hWnd, @rect)
BGHS(SelfIndex).gridwidth = rect.right - rect.left
BGHS(SelfIndex).gridheight = rect.bottom - rect.top
ReturnValue = 0
Select Case message
Case WM_COMMAND
wmId = LOWORD(wParam)
' Parse the menu selections:
Select Case wmId
Case Else
Return DefWindowProc(hWnd, message, wParam, lParam)
End Select
Case WM_PAINT
hdc = BeginPaint(hWnd, @ps)
Dim rt As RECT
GetClientRect(hWnd, @rt)
CalcVisibleCellBoundaries(SelfIndex)
'display title
DisplayTitle(hWnd,SelfIndex,BGHS(SelfIndex).htitlefont)
'display column 0;
DisplayColumn(hWnd,SelfIndex,0,0,BGHS(SelfIndex).hfont,BGHS(SelfIndex).hcolumnheadingfont)
Dim c As Integer
Dim j As Integer
Dim k As Integer
Dim offset As Integer
offset = BGHS(SelfIndex).columnwidths(0)
j = BGHS(SelfIndex).leftvisiblecol
k = BGHS(SelfIndex).rightvisiblecol
For c = j To k
DisplayColumn(hWnd,SelfIndex,c,offset,BGHS(SelfIndex).hfont,BGHS(SelfIndex).hcolumnheadingfont)
offset+=BGHS(SelfIndex).columnwidths(c)
Next c
DeleteDC(hdc)
EndPaint(hWnd, @ps)
'
If GetFocus()=hWnd Then
PostMessage(hWnd,BGM_DRAWCURSOR,CUInt(SelfIndex),0)
End If
Case BGM_PAINTGRID
Dim rect As RECT
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 1)
UpdateWindow(hWnd)
MessageBeep(0)
Case WM_SETTEXT
Dim j As Integer
Dim linecount As Integer
Dim size As SIZE
Dim gdc As HDC
Dim holdfont As HFONT
If Len(*Cast(ZString Ptr,lParam))>300 Then
BGHS(SelfIndex).title = "Title too long (300 chars max)"
Else
BGHS(SelfIndex).title =*Cast(ZString Ptr,lParam)
End If
gdc = GetDC(hWnd)
'get linecount of title;
If Len(BGHS(SelfIndex).title) > 0 Then
linecount = 1
For j = 0 To CInt(Len((BGHS(SelfIndex).title)))- 1
If BGHS(SelfIndex).title[j]=Asc(Lf) Then
linecount += 1
End If
Next j
holdfont = Cast(HFONT,SelectObject(gdc,BGHS(SelfIndex).htitlefont))
GetTextExtentPoint32(gdc, BGHS(SelfIndex).title, Len(BGHS(SelfIndex).title), @size)
SelectObject(gdc,holdfont)
BGHS(SelfIndex).titleheight = CInt(((size.cy *1.2) * linecount))
Else
'no title
BGHS(SelfIndex).titleheight = 0
End If
ReleaseDC(hWnd,gdc)
RefreshGrid(hWnd)
SizeGrid(hWnd,SelfIndex)
Case BGM_GETROWS
ReturnValue = BGHS(SelfIndex).rows
Case BGM_GETCOLS
ReturnValue = BGHS(SelfIndex).cols
Case BGM_GETCOLWIDTH
ReturnValue = BGHS(SelfIndex).columnwidths(wParam)
Case BGM_GETROWHEIGHT
ReturnValue = BGHS(SelfIndex).rowheight
Case BGM_GETHEADERROWHEIGHT
ReturnValue = BGHS(SelfIndex).headerrowheight
Case BGM_GETOWNERDRAWITEM
ReturnValue = BGHS(SelfIndex).ownerdrawitem
Case BGM_DRAWCURSOR
DrawCursor(hWnd,wParam)
Case BGM_SETCURSORPOS
DrawCursor(hWnd,SelfIndex)
If ((CInt(wParam) <= BGHS(SelfIndex).rows) And (CInt(wParam) > 0)) And ((CInt(lParam) <= BGHS(SelfIndex).cols) And (CInt(lParam) > 0)) Then
BGHS(SelfIndex).cursorrow=wParam
BGHS(SelfIndex).cursorcol=lParam
Else
DrawCursor(hWnd,SelfIndex)
Exit Select
End If
SetHomeRow(hWnd,SelfIndex,BGHS(SelfIndex).cursorrow,BGHS(SelfIndex).cursorcol)
SetHomeCol(hWnd,SelfIndex,BGHS(SelfIndex).cursorrow,BGHS(SelfIndex).cursorcol)
DrawCursor(hWnd,SelfIndex)
RefreshGrid(hWnd)
Case BGM_SHOWHILIGHT
BGHS(SelfIndex).DRAWHIGHLIGHT = CInt(wParam)
RefreshGrid(hWnd)
Case BGM_EXTENDLASTCOLUMN
BGHS(SelfIndex).EXTENDLASTCOLUMN = CInt(wParam)
RefreshGrid(hWnd)
Case BGM_SHOWINTEGRALROWS
BGHS(SelfIndex).SHOWINTEGRALROWS = CInt(wParam)
SizeGrid(hWnd,SelfIndex)
RefreshGrid(hWnd)
Case BGM_SETCOLAUTOWIDTH
BGHS(SelfIndex).COLAUTOWIDTH = CInt(wParam)
Case BGM_SETALLOWCOLRESIZE
BGHS(SelfIndex).ALLOWCOLUMNRESIZING = CInt(wParam)
Case BGM_PROTECTCELL
LPBGcell=Cast(_BGCELL Ptr,wParam)
If OutOfRange(LPBGcell) Then
wParam = MAKEWPARAM(CUInt(GetMenu(hWnd)),BGN_OUTOFRANGE)
lParam = 0
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
ReturnValue = -1
Exit Select
End If
wsprintf(buffer,!"%05d-%03d",LPBGcell->row,LPBGcell->col)
'see if that cell is already loaded
FindResult = BinarySearchListBox(BGHS(SelfIndex).hlist1,buffer)
If FindResult <> LB_ERR Then
'it was found, get the text, modify text delete it from list, add modified to list
SendMessage(BGHS(SelfIndex).hlist1,LB_GETTEXT,FindResult,CInt(StrPtr(buffer)))
If CInt(lParam) Then
buffer[10] = asc("P")
Else
buffer[10] = Asc("U")
End If
SendMessage(BGHS(SelfIndex).hlist1,LB_DELETESTRING,FindResult,0)
SendMessage(BGHS(SelfIndex).hlist1,LB_ADDSTRING,FindResult,CInt(StrPtr(buffer)))
Else
'protecting or unprotecting a cell that isn't in the list
'add it as blank;
buffer &= "|"
If CInt(lParam) Then
buffer &= "PA"
Else
buffer &= "UA"
End If
buffer &= "|"
SendMessage(BGHS(SelfIndex).hlist1,LB_ADDSTRING,FindResult,CInt(StrPtr(buffer)))
End If
Case BGM_NOTIFYROWCHANGED
NotifyRowChanged(hWnd,SelfIndex)
Case BGM_NOTIFYCOLCHANGED
NotifyColChanged(hWnd,SelfIndex)
Case BGM_SETPROTECT
If CInt(wParam) Then
BGHS(SelfIndex).protect = "P"
Else
BGHS(SelfIndex).protect = "U"
End If
Case BGM_AUTOROW
If CInt(wParam) Then
BGHS(SelfIndex).AUTOROW = 1
Else
BGHS(SelfIndex).AUTOROW = 0
End If
Case BGM_SETEDITABLE
If CInt(wParam) Then
BGHS(SelfIndex).EDITABLE = 1
Else
BGHS(SelfIndex).EDITABLE = 0
End If
Case BGM_SETCELLDATA
LPBGcell=Cast(_BGCELL Ptr,wParam)
If OutOfRange(LPBGcell) Then
wParam = MAKEWPARAM(CUInt(GetMenu(hWnd)),BGN_OUTOFRANGE)
lParam = 0
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
ReturnValue = -1
Exit Select
End If
wsprintf(buffer,!"%05d-%03d",LPBGcell->row,LPBGcell->col)
'see if that cell is already loaded
FindResult = BinarySearchListBox(BGHS(SelfIndex).hlist1,buffer)
If FindResult <> LB_ERR Then
'it was found, delete it
SendMessage(BGHS(SelfIndex).hlist1,LB_DELETESTRING,FindResult,0)
End If
'now add it
buffer &= "|"
buffer &= BGHS(SelfIndex).protect
'determine data type (text,numeric, or boolean)(1,2,3)
iDataType = DetermineDataType( *Cast(ZString ptr,lParam))
If iDataType = 1 Then
buffer &= "A"
End If
If iDataType = 2 Then
buffer &= "N"
End If
If iDataType = 3 Then
buffer &= "T"
End If
If iDataType = 4 Then
buffer &= "F"
End If
If iDataType = 5 Then
buffer &= "G"
End If
buffer &= "|"
buffer &= *Cast(ZString ptr,lParam)
FindResult=SendMessage(BGHS(SelfIndex).hlist1,LB_ADDSTRING,0,CInt(StrPtr(buffer)))
'ShowLastError
If FindResult=LB_ERR Then
MessageBeep(0)
End If
Dim rect As RECT
rect = GetCellRect(hWnd,SelfIndex,LPBGcell->row,LPBGcell->col)
InvalidateRect(hWnd, @rect, 0)
'get the last line and adjust grid dimmensions
If BGHS(SelfIndex).AUTOROW Then
Dim j As Integer
j = SendMessage(BGHS(SelfIndex).hlist1,LB_GETCOUNT,0,0)
If j>0 Then
SendMessage(BGHS(SelfIndex).hlist1,LB_GETTEXT,j-1,CInt(StrPtr(buffer)))
buffer[5]= &H00 ' les 5 premiers lettres de buffer 00001-
j = atoi(buffer)
' messagebox NULL,Trim(buffer),"ok2",0
If j>SendMessage(hWnd,BGM_GETROWS,0,0) Then
SendMessage(hWnd,BGM_SETGRIDDIM,j,BGHS(SelfIndex).cols)
End If
Else
'no items in the list
SendMessage(hWnd,BGM_SETGRIDDIM,j,BGHS(SelfIndex).cols)
End If
End If
'adjust the column width if COLAUTOWIDTH==TRUE
If (BGHS(SelfIndex).COLAUTOWIDTH) Or (LPBGcell->row = 0) Then
Dim hdc As HDC
Dim size As SIZE
Dim required_width As Integer
Dim current_width As Integer
Dim required_height As Integer
Dim current_height As Integer
Dim longestline As Integer
Dim holdfont As HFONT
hdc = GetDC(hWnd)
If LPBGcell->row = 0 Then
holdfont = Cast(HFONT,SelectObject(hdc,BGHS(SelfIndex).hcolumnheadingfont) )
Else
holdfont = Cast(HFONT,SelectObject(hdc,BGHS(SelfIndex).hfont))
End If
'if there are \n codes in the string, find the longest line
longestline = FindLongestLine(hdc, cast(ZString Ptr,lParam), @size)
'GetTextExtentPoint32(hdc,(char*)lParam,strlen((char*)lParam),&size);
required_width = longestline+5
required_height = size.cy
'count lines
Dim count As Integer = 1
Dim tbuffer As zString*254
tbuffer = *Cast(ZString ptr,lParam)
For j As Integer = 0 To CInt(Len(tbuffer))- 1
If tbuffer[j]=Asc(!"\n") Then
count += 1
End If
Next j
If ((0= BGHS(SelfIndex).ELLIPSIS)) or (LPBGcell->row = 0) Then
required_height *= count
End If
required_height +=5
SelectObject(hdc,holdfont)
ReleaseDC(hWnd,hdc)
current_width = BGHS(SelfIndex).columnwidths(LPBGcell->col)
If LPBGcell->row = 0 Then
current_height = BGHS(SelfIndex).headerrowheight
If required_height > current_height Then
SendMessage(hWnd,BGM_SETHEADERROWHEIGHT,required_height,0)
End If
Else
current_height = BGHS(SelfIndex).rowheight
If required_height > current_height Then
SendMessage(hWnd,BGM_SETROWHEIGHT,required_height,0)
End If
End If
If required_width > current_width Then
SendMessage(hWnd,BGM_SETCOLWIDTH,LPBGcell->col,required_width)
End If
ReleaseDC(hWnd,hdc)
End If
Case BGM_GETCELLDATA
LPBGcell=Cast(LPBGCELL,wParam)
If OutOfRange(LPBGcell) Then
wParam = MAKEWPARAM(CUInt(GetMenu(hWnd)),BGN_OUTOFRANGE)
lParam = 0
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
ReturnValue = -1
Exit Select
End If
wsprintf(buffer,!"%05d-%03d",LPBGcell->row,LPBGcell->col)
'see if that cell is already loaded
FindResult = BinarySearchListBox(BGHS(SelfIndex).hlist1,buffer)
If FindResult <> LB_ERR Then
Dim j As Integer
Dim k As Integer
Dim c As Integer
Dim tbuffer As ZSTRING*1000
'it was found, get it
SendMessage(BGHS(SelfIndex).hlist1,LB_GETTEXT,FindResult,CInt(lParam))
tbuffer = *Cast(ZString Ptr,lParam)
'messagebox NULL,Trim(tbuffer),"ok1",0
k = Len(tbuffer)
c = 0
For j = 13 To k - 1
buffer[c]=tbuffer[j]
c += 1
Next j
buffer[c]= &H0
strcpy(cast(ZString Ptr,lParam),buffer)
' lParam = Cast(LPARAM,@buffer)
Else
strcpy(cast(ZString Ptr,lParam),"")
'lParam = Cast(LPARAM,NULL)
End If
Case BGM_CLEARGRID
SendMessage(BGHS(SelfIndex).hlist1,LB_RESETCONTENT,0,0)
BGHS(SelfIndex).rows = 0
BGHS(SelfIndex).cursorrow = 1
BGHS(SelfIndex).homerow = 1
BGHS(SelfIndex).homecol = 1
Dim rect As RECT
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 1)
Case BGM_DELETECELL
LPBGcell=Cast(LPBGCELL,wParam)
If OutOfRange(LPBGcell) Then
wParam = MAKEWPARAM(CUInt(GetMenu(hWnd)),BGN_OUTOFRANGE)
lParam = 0
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
ReturnValue = -1
Exit Select
End If
wsprintf(buffer,!"%05d-%03d",LPBGcell->row,LPBGcell->col)
'see if that cell is already loaded
FindResult = BinarySearchListBox(BGHS(SelfIndex).hlist1,buffer)
If FindResult <> LB_ERR Then
'it was found, delete it
SendMessage(BGHS(SelfIndex).hlist1,LB_DELETESTRING,FindResult,0)
NotifyEndEdit(hWnd,SelfIndex)
End If
Case BGM_SETGRIDDIM
If (CInt(wParam)>=0) And (CInt(wParam)<=MAX_ROWS) Then
BGHS(SelfIndex).rows = wParam
Else
If CInt(wParam)<0 Then
BGHS(SelfIndex).rows = 0
Else
BGHS(SelfIndex).rows = MAX_ROWS
End If
End If
If (lParam>0) And (lParam<=MAX_COLS) Then
BGHS(SelfIndex).cols = lParam
Else
If lParam <= 0 Then
BGHS(SelfIndex).cols = 1
Else
BGHS(SelfIndex).cols = MAX_COLS
End If
End If
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 1)
GetVisibleColumns(hWnd,SelfIndex)
Case BGM_SETCOLWIDTH
If (CInt(wParam) <= MAX_COLS) And (CInt(wParam) >= 0) And (CInt(lParam) >= 0) Then
Dim rect As RECT
BGHS(SelfIndex).columnwidths(wParam) = lParam
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 0)
GetVisibleColumns(hWnd,SelfIndex)
End If
Case BGM_SETHEADERROWHEIGHT
If CInt(wParam) >= 0 Then
Dim rect As RECT
BGHS(SelfIndex).headerrowheight = wParam
SizeGrid(hWnd,SelfIndex)
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 0)
End If
Case BGM_GETROW
ReturnValue = BGHS(SelfIndex).cursorrow
Case BGM_GETCOL
ReturnValue = BGHS(SelfIndex).cursorcol
Case BGM_GETTYPE
LPBGcell=Cast(_BGCELL Ptr,wParam)
If OutOfRange(LPBGcell) Then
wParam = MAKEWPARAM(CUInt(GetMenu(hWnd)),BGN_OUTOFRANGE)
lParam = 0
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
ReturnValue = -1
End If
wsprintf(buffer,!"%05d-%03d",LPBGcell->row,LPBGcell->col)
'see if that cell is already loaded
FindResult = BinarySearchListBox(BGHS(SelfIndex).hlist1,buffer)
If FindResult <> LB_ERR Then
'it was found, get it
SendMessage(BGHS(SelfIndex).hlist1,LB_GETTEXT,FindResult,CInt(StrPtr(buffer)))
Select Case buffer[11]
Case Asc("A")
ReturnValue=1
Case Asc("N")
ReturnValue=2
Case Asc("T")
ReturnValue=3
Case Asc("F")
ReturnValue=4
Case Asc("G")
ReturnValue=5
Case Else
ReturnValue =1
End Select
End If
Case BGM_GETPROTECTION
LPBGcell=Cast(LPBGCELL,wParam)
If OutOfRange(LPBGcell) Then
wParam = MAKEWPARAM(CUInt(GetMenu(hWnd)),BGN_OUTOFRANGE)
lParam = 0
SendMessage(GetParent(hWnd),WM_COMMAND,wParam,lParam)
ReturnValue = -1
End If
wsprintf(buffer,!"%05d-%03d",LPBGcell->row,LPBGcell->col)
'see if that cell is already loaded
ReturnValue = 0
FindResult = BinarySearchListBox(BGHS(SelfIndex).hlist1,buffer)
If FindResult <> LB_ERR Then
'it was found, get it
SendMessage(BGHS(SelfIndex).hlist1,LB_GETTEXT,FindResult,CInt(StrPtr(buffer)))
Select Case buffer[10]
Case Asc("U")
ReturnValue=0
Case Asc("P")
ReturnValue=1
Case Else
ReturnValue =0
End Select
End If
Case BGM_SETROWHEIGHT
If wParam <1 Then
wParam = 1
End If
BGHS(SelfIndex).rowheight = wParam
SetHomeRow(hWnd,SelfIndex,BGHS(SelfIndex).cursorrow,BGHS(SelfIndex).cursorcol)
SetHomeCol(hWnd,SelfIndex,BGHS(SelfIndex).cursorrow,BGHS(SelfIndex).cursorcol)
SizeGrid(hWnd,SelfIndex)
Dim rect As RECT
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 0)
Case BGM_SETTITLEHEIGHT
If CInt(wParam)<0 Then
wParam = 0
End If
BGHS(SelfIndex).titleheight = wParam
SetHomeRow(hWnd,SelfIndex,BGHS(SelfIndex).cursorrow,BGHS(SelfIndex).cursorcol)
SetHomeCol(hWnd,SelfIndex,BGHS(SelfIndex).cursorrow,BGHS(SelfIndex).cursorcol)
Dim rect As RECT
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 0)
Case BGM_SETGRIDLINECOLOR
DrawCursor(hWnd,SelfIndex)
BGHS(SelfIndex).gridlinecolor = CUInt(wParam)
DrawCursor(hWnd,SelfIndex)
RefreshGrid(hWnd)
Case BGM_SETCURSORCOLOR
DrawCursor(hWnd,SelfIndex)
BGHS(SelfIndex).cursorcolor = CUInt(wParam)
DrawCursor(hWnd,SelfIndex)
RefreshGrid(hWnd)
Case BGM_SETHILIGHTTEXTCOLOR
BGHS(SelfIndex).highlighttextcolor = CUInt(wParam)
Dim rect As RECT
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 0)
Case BGM_SETHILIGHTCOLOR
BGHS(SelfIndex).highlightcolor = CUInt(wParam)
Dim rect As RECT
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 0)
Case BGM_SETPROTECTCOLOR
BGHS(SelfIndex).protectcolor = CUInt(wParam)
Dim rect As RECT
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 0)
Case BGM_SETUNPROTECTCOLOR
BGHS(SelfIndex).unprotectcolor = CUInt(wParam)
Dim rect As RECT
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 0)
Case BGM_SETELLIPSIS
BGHS(SelfIndex).ELLIPSIS = CInt(wParam)
Dim rect As RECT
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 0)
Case BGM_SETTITLEFONT
BGHS(SelfIndex).htitlefont = Cast(HFONT,wParam )
Dim rect As RECT
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 0)
Case BGM_SETHEADINGFONT
BGHS(SelfIndex).hcolumnheadingfont = Cast(HFONT,wParam )
Dim rect As RECT
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 0)
Case BGM_SETROWSNUMBERED
BGHS(SelfIndex).ROWSNUMBERED = CInt(wParam)
Dim rect As RECT
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 0)
Case BGM_SETCOLSNUMBERED
BGHS(SelfIndex).COLUMNSNUMBERED = CInt(wParam)
Dim rect As RECT
GetClientRect(hWnd, @rect)
InvalidateRect(hWnd, @rect, 0)
Case WM_ENABLE
If wParam = 0 Then
BGHS(SelfIndex).textcolor = _RGB(120,120,120)
Else
BGHS(SelfIndex).textcolor = _RGB(0,0,0)
End If
Case WM_MOUSEMOVE
Dim x As Integer
Dim y As Integer
Dim r As Integer
Dim c As Integer
Dim t As Integer
Dim z As Integer
x = LOWORD(lParam)
y = HIWORD(lParam)
r = GetRowOfMouse(SelfIndex,y)
c = GetColOfMouse(SelfIndex,x)
t = GetColOfMouse(SelfIndex,x+10)
z = GetColOfMouse(SelfIndex,x-10)
If BGHS(SelfIndex).COLUMNSIZING Then
Dim dx As Integer
Dim nx As Integer
Dim cr_ As Integer
dx = x-BGHS(SelfIndex).columntoresizeinitx
nx = BGHS(SelfIndex).columntoresizeinitsize + dx
If nx<=0 Then
nx = 0
End If
cr_ = BGHS(SelfIndex).columntoresize
SendMessage(hWnd,BGM_SETCOLWIDTH,cr_,nx)
End If
If (r = 0) And (c>=-1) And ((t<>c) or (z<>c)) And ((0= BGHS(SelfIndex).COLUMNSIZING)) Then
If (BGHS(SelfIndex).cursortype <> 2) And (BGHS(SelfIndex).ALLOWCOLUMNRESIZING) Then
BGHS(SelfIndex).cursortype = 2
SetCursor(LoadCursor(NULL, IDC_SIZEWE))
End If
Else
If (BGHS(SelfIndex).cursortype <> 1) And ((0= BGHS(SelfIndex).COLUMNSIZING)) Then
BGHS(SelfIndex).cursortype = 1
SetCursor(LoadCursor(NULL, IDC_ARROW))
End If
End If
Case WM_LBUTTONUP
If BGHS(SelfIndex).COLUMNSIZING Then
BGHS(SelfIndex).COLUMNSIZING = 0
SetCursor(LoadCursor(NULL, IDC_ARROW))
BGHS(SelfIndex).cursortype = 1
BGHS(SelfIndex).SHOWINTEGRALROWS=BGHS(SelfIndex).REMEMBERINTEGRALROWS
SizeGrid(hWnd,SelfIndex)
End If
