Very well done, Macq! Some minor points:
1. You declare WndProc as a function. That's possible but very unusual, as nobody will ever use the returned value
2. Your generous use of global (static) variables at the entry to WndProc will not please everybody
3.
Integers are 64 bits long in 64-bit code; what you need to make both the 32- and the 64-bit compiler happy are 32-bit
long variables
4. The empty declaration of WinMain is not necessary; just put WinMain(GetModuleHandle(null), null, Command, SW_NORMAL) at the end of the source, as shown below
5. Gcc-64 complains about
format '%d' expects argument of type 'int', but argument 3 has type 'long long int' in sprintf(). The web is full of contradicting suggestions, try your luck...:
Code: Select all
' above: Static as long index
dim as uint index2=index
sprintf(buf, "This is key line %3d, index=%3d", index2+1, index2)
None of this works, but Gcc is happy if you eliminate the index
+1. It looks like the ugly C++ typecasting disease. This works, but don't ask me why:
sprintf(buf, "This is key line %3d, index=%3d", cast(long, index+1), index)
Same for
.lpfnWndProc = cast(any ptr, @WndProc) ' cast eliminates the dumb warning suspicious pointer assignment
Here is a version that declares WndProc as a Sub, and uses longs where 32-bit values are enough:
Code: Select all
' Macq TestScroll.bas
#include once "windows.bi"
#include once "crt.bi" ' for sprintf
#define MAXLINES 200
#define WINDOWWIDTH1 550
'' ::::::::
'' name: WndProc
'' desc: Processes windows messages
''
'' ::::::::
Sub WndProc (ByVal hw As HWND, _
ByVal message As UINT, _
ByVal wParam As WPARAM, _
ByVal lParam As LPARAM)
Static as string lines(MAXLINES)
Static as long colours(MAXLINES)
Static as long rainbow(6) = {&H0000FF,&H00A0FF,&H00F0F0,&H00FF00,&HFF8000,&HFF00B0,&HF000FF}
Static as long rotate = 0
Static as long index ' current index into lines() and colours(0); see sprintf
Static as long yChar ' Height of a character box in this window
Static as long nDispLines ' Number of lines that will fit in this window
Static as long VscrollPos = 0 ' The position of the scroll box in the "page" (si.nPos)
Static as boolean ScrollBarEnabled = False
Static as SCROLLINFO si
Dim hdc As HDC ' handle to device (screen) context
lines(0) = "------Top-Line-------"
colours(0) = rainbow(6)
''
'' Process messages
''
Select Case(message)
''
'' Window was created
''
Case WM_CREATE
dim as TEXTMETRIC tm ' info about the current font for this window
hdc = GetDC(hw)
SelectObject(hdc,GetStockObject(OEM_FIXED_FONT))
GetTextMetrics(hdc,@tm)
yChar = tm.tmHeight
ReleaseDC(hw,hdc)
return
case WM_SIZE
VscrollPos = max(0,min(VscrollPos,index-nDispLines+1))
InvalidateRect(hw,null,true) ' Cause re-paint
return
Case WM_MOUSEWHEEL
' wParam The high-order word indicates the distance the wheel is rotated.
' A positive value indicates that the wheel was rotated forward, away from the user
' wParam
' The low-order word indicates whether various virtual keys are down.
' lParam contains x,y of mouse pointer
dim as integer temp, mousewheel = GET_WHEEL_DELTA_WPARAM(wParam)
temp = VscrollPos ' save a copy
VscrollPos -= mousewheel / 40 ' One "notch" is 120 to allow for micro-wheel movements
VscrollPos = max(0,min(VscrollPos,index-nDispLines+1)) ' Possibly move 3 lines, up or down. 120/40 = 3 :-)
if(VscrollPos <> temp) then
InvalidateRect(hw,null,true) ' Cause re-paint
endif
return
Case WM_VSCROLL ' User is clicking or dragging the vertical scroll bar
dim as integer temp = VscrollPos ' save a copy
select case LoWord(wParam)
case SB_LINEUP
VscrollPos -= 1
case SB_LINEDOWN
VscrollPos += 1
case SB_PAGEUP
VscrollPos -= (nDispLines - 1)
case SB_PAGEDOWN
VscrollPos += (nDispLines - 1)
case SB_THUMBTRACK
VscrollPos = Hiword(wParam)
case SB_THUMBPOSITION
VscrollPos = Hiword(wParam)
end select
VscrollPos = max(0,min(VscrollPos,index-nDispLines+1))
if(VscrollPos <> temp) then
InvalidateRect(hw,null,true) ' Cause re-paint
endif
return
''
'' Windows is being repainted
''
'Case WM_COMMAND ' A Menu Item was selected
Case WM_PAINT
Dim As RECT rct
Dim As PAINTSTRUCT ps
GetClientRect(hw, @rct)
nDispLines = (rct.bottom / yChar) - 1
if((not ScrollBarEnabled) and ((index+1)>nDispLines)) then
ScrollBarEnabled = true
EnableScrollBar(hw,SB_VERT,ESB_ENABLE_BOTH) ' Verticle scroll bar with both arrows
ShowScrollBar(hw,SB_VERT,true)
endif
'-------------------------
if(ScrollBarEnabled) then
si.cbSize = SizeOf(si)
si.fMask = SIF_RANGE or SIF_PAGE Or SIF_POS
si.nMin = 0
si.nMax = index
si.nPage = nDispLines
si.nPos = VscrollPos
SetScrollInfo(hw,SB_VERT,@si,true)
'print "yChar =";yChar ,"nDispLines=";nDispLines,"VscrollPos@si=";VscrollPos,"index=";index
endif
'===========
'Begin Paint
'===========
hdc = BeginPaint(hw, @ps)
SelectObject(hdc,GetStockObject(OEM_FIXED_FONT))
SetBkMode(hdc,TRANSPARENT)
'SetTextColor(hdc,&HF0F0F0)
for i as integer = VscrollPos to min(index,VscrollPos+nDispLines-1)
SetTextColor(hdc,colours(i))
'print "i=";i,"colours(i)=";colours(i)
DrawText(hdc,lines(i),-1,@rct,DT_LEFT)
rct.top += yChar
next i
'print "yChar=";yChar ,"nDispLines=";nDispLines,"VscrollPos=";VscrollPos
EndPaint(hw, @ps)
return
''
'' Key pressed
''
Case WM_KEYDOWN
dim as integer temp = VscrollPos ' save a copy
select case lobyte(wParam)
case VK_ESCAPE
PostMessage(hw,WM_QUIT,0,0) 'Close our main window, if Esc key pressed
case VK_UP
VscrollPos -= 1
case VK_DOWN
VscrollPos += 1
case VK_PRIOR
VscrollPos -= (nDispLines - 1)
case VK_NEXT
VscrollPos += (nDispLines - 1)
case VK_RETURN
index += 1
if(index > MAXLINES) then index = MAXLINES
dim as string * 64 buf
sprintf(buf,"This is key line %3d, index=%3d",index+1,index)
lines(index) = buf
colours(index) = rainbow(rotate) : rotate = (rotate + 1) mod 7
InvalidateRect(hw,null,true) ' Cause re-paint
end select
VscrollPos = max(0,min(VscrollPos,index-nDispLines+1))
if(VscrollPos <> temp) then
InvalidateRect(hw,null,true) ' Cause re-paint
endif
return
''
'' User clicked the form
Case WM_LBUTTONDOWN
index += 1
if(index > MAXLINES) then index = MAXLINES
dim as string * 64 buf
sprintf(buf,"This is mouse line %3d, index=%3d",index+1,index)
lines(index) = buf
colours(index) = rainbow(rotate) : rotate = (rotate + 1) mod 7
InvalidateRect(hw,null,true) ' Cause re-paint
return
''
'' Window was closed
''
Case WM_DESTROY
PostQuitMessage(0)
return
End Select
''
'' Message doesn't concern us, send it to the default handler
''
DefWindowProc(hw, message, wParam, lParam)
End Sub
'' ::::::::
'' name: WinMain
'' desc: A WIN32 GUI program entry point
''
'' ::::::::
Function WinMain (ByVal hInstance As HINSTANCE, _
ByVal hPrevInstance As HINSTANCE, _
szCmdLine As String, _
ByVal iCmdShow As Integer) As Integer
Dim wMsg As MSG
Dim wcls As WNDCLASS
Dim szAppName As String
Dim hWnd As HWND
' Read an icon from shell32.dll
Dim As HANDLE hIconLib, hDll
hIconLib = LoadLibrary("shell32")
wcls.hIcon = LoadIcon(hIconLib,cptr(any ptr,44)) ' get an icon
FreeLibrary(hIconLib)
''
'' Setup window class
''
szAppName = "TestScroll"
With wcls
.style = CS_HREDRAW Or CS_VREDRAW
.lpfnWndProc = @WndProc ' warning suspicious pointer assignment
.cbClsExtra = 0
.cbWndExtra = 0
.hInstance = hInstance
''.hIcon = LoadIcon(NULL, IDI_APPLICATION)
.hCursor = LoadCursor(NULL, IDC_ARROW)
'.hbrBackground = GetStockObject(GRAY_BRUSH)
.hbrBackground = CreateSolidBrush(&H610000)
.lpszMenuName = NULL
.lpszClassName = strptr(szAppName)
End With
''
'' Register the window class
''
If(RegisterClass(@wcls) = FALSE) Then
MessageBox(null, "Failed to register wcls!", szAppName, MB_ICONERROR)
Else
''
'' Create the window and show it
''
dim rxy as RECT
SystemParametersInfo(SPI_GETWORKAREA,0,@rxy,0)
Dim vsize as integer = rxy.bottom * 0.5 ' The virtical size of the main client area
hWnd = CreateWindowEx(0, _
szAppName, _
"Testing Scroll", _
WS_TILEDWINDOW, _
(rxy.Right - WINDOWWIDTH1)/2, _
(rxy.bottom - vsize)/2, _
WINDOWWIDTH1, _
vsize, _
NULL, _
NULL, _
hInstance, _
NULL)
ShowWindow(hWnd, iCmdShow)
ShowScrollBar(Hwnd,SB_VERT,false)
UpdateWindow(hWnd)
''
'' Process windows messages
''
While(GetMessage(@wMsg, NULL, 0, 0) <> FALSE)
TranslateMessage(@wMsg)
DispatchMessage(@wMsg)
Wend
End If
''
'' Program has ended
''
Function = wMsg.wParam
End Function
WinMain(GetModuleHandle(null), null, Command, SW_NORMAL)