Code: Select all
'========================================================================
'' GFX_NULL demo, with resizable window, full-programmed
'' menu, and keyboard accelerators.
'========================================================================
#include "fbgfx.bi"
#include "windows.bi"
'========================================================================
dim shared as BITMAPV4HEADER bmi
dim shared as RECT rcw
dim shared as HACCEL hAccel
dim shared as integer _color = &hffffff
'' This corrects for a problem with the ACCEL structure, at least as
'' it was defined until recently, without the field = 2.
type _ACCEL field = 2
fVirt as BYTE
key as WORD
cmd as WORD
end type
'========================================================================
function InitMenu() as HMENU
dim as HMENU hMenu, hFileMenu
dim as _ACCEL accl( 0 to 2)
hMenu = CreateMenu
hFileMenu = CreateMenu
AppendMenu( hMenu, MF_POPUP, cast(UINT_PTR,hFileMenu), "&Select" )
AppendMenu( hFileMenu, MF_STRING, 1000, !"&Red\tCtrl+R" )
AppendMenu( hFileMenu, MF_SEPARATOR, 0, 0 )
AppendMenu( hFileMenu, MF_STRING, 1001, !"&Green\tCtrl+G" )
AppendMenu( hFileMenu, MF_SEPARATOR, 0, 0 )
AppendMenu( hFileMenu, MF_STRING, 1002, !"&Blue\tCtrl+B" )
accl(0).fVirt = FCONTROL or FVIRTKEY
accl(0).key = asc("R")
accl(0).cmd = 1000
accl(1).fVirt = FCONTROL or FVIRTKEY
accl(1).key = asc("G")
accl(1).cmd = 1001
accl(2).fVirt = FCONTROL or FVIRTKEY
accl(2).key = asc("B")
accl(2).cmd = 1002
hAccel = CreateAcceleratorTable( cast(LPACCEL,@accl(0)), 3 )
return hMenu
end function
'========================================================================
function WindowProc( byval hWnd as HWND,_
byval uMsg as uint,_
byval wParam as WPARAM,_
byval lParam as LPARAM ) as LRESULT
select case uMsg
case WM_CREATE
SetMenu( hWnd, InitMenu() )
GetClientRect( hWnd, @rcw )
with bmi
.bV4Size = len(BITMAPV4HEADER)
.bv4width = rcw.right+1
.bv4height = -(rcw.bottom+1)
.bv4planes = 1
.bv4bitcount = 32
.bv4v4compression = 0
.bv4sizeimage = (rcw.right+1) * (rcw.bottom+1) * 4
.bV4RedMask = &h0f00
.bV4GreenMask = &h00f0
.bV4BlueMask = &h000f
.bV4AlphaMask = &hf000
end with
ScreenRes rcw.right+1, rcw.bottom+1, 32, 1, FB.GFX_NULL
case WM_PAINT
dim as PAINTSTRUCT ps
dim as RECT rc
GetClientRect( hWnd, @rc )
BeginPaint( hWnd, @ps )
with rc
StretchDIBits( ps.hdc, _
0, _
0, _
.right - .left + 1, _
.bottom - .top + 1, _
0, _
0, _
.right - .left + 1, _
.bottom - .top + 1, _
screenptr, _
cptr( BITMAPINFO ptr, @bmi), _
DIB_RGB_COLORS, SRCCOPY )
end with
EndPaint( hWnd, @ps )
case WM_SIZE
'' Update the necessary variables and reinitialize the
'' graphics mode so the GFX code can generate everything
'' at the new size.
with rcw
.right = loword(lParam)-1
.bottom = hiword(lParam)-1
end with
with bmi
.bv4width = loword(lParam)
.bv4height = -(hiword(lParam))
.bv4sizeimage = loword(lParam) * hiword(lParam) * 4
end with
ScreenRes rcw.right+1, rcw.bottom+1, 32, 1, FB.GFX_NULL
case WM_ERASEBKGND
'' This corrects a severe flicker problem by preventing the
'' default window procedure from processing WM_ERASEBKGND.
case WM_COMMAND
select case loword(wParam)
case 1000
_color = &hff0000
case 1001
_color = &hff00
case 1002
_color = &hff
end select
case WM_CLOSE
DestroyWindow( hWnd )
case WM_DESTROY
DestroyAcceleratorTable( hAccel )
PostQuitMessage( null )
case else
return DefWindowProc( hWnd, uMsg, wParam, lParam )
end select
return 0
end function
'========================================================================
function WinMain ( byval hInstance as HINSTANCE,_
byval hPrevInstance as HINSTANCE,_
byval lpCmdLine as LPSTR,_
byval nCmdShow as integer ) as integer
dim hWnd as HWND
dim wMsg as MSG
dim as integer wx, wy, nWidth, nHeight
dim wcx as WNDCLASSEX
dim className as string = "test_class"
with wcx
.cbSize = sizeof( WNDCLASSEX )
.style = CS_HREDRAW or CS_VREDRAW or CS_BYTEALIGNWINDOW
.lpfnWndProc = cast( WNDPROC, @WindowProc )
.cbClsExtra = null
.cbWndExtra = null
.hInstance = hInstance
.hbrBackground = cast( HBRUSH,COLOR_WINDOW + 1 )
.lpszMenuName = null
.lpszClassName = strptr( className )
.hIcon = LoadIcon( null, IDI_APPLICATION )
.hCursor = LoadCursor ( null, IDC_ARROW )
.hIconSm = 0
end with
RegisterClassEx( @wcx )
nWidth = 400
nHeight = 300
wx = (GetSystemMetrics( SM_CXSCREEN ) / 2) - nWidth / 2
wy = (GetSystemMetrics( SM_CYSCREEN ) / 2) - nHeight / 2
hWnd = CreateWindowEx( 0,_
strptr( className ),_
"Test",_
WS_OVERLAPPEDWINDOW,_
wx, wy, nWidth, nHeight,_
null, null,_
hInstance, null )
ShowWindow( hWnd, nCmdShow )
UpdateWindow( hWnd )
do
if PeekMessage( @wMsg, null, 0, 0, PM_REMOVE ) then
if wMsg.message = WM_QUIT then exit do
if TranslateAccelerator( hWnd, hAccel, @wMsg ) = 0 then
TranslateMessage( @wMsg )
DispatchMessage( @wMsg )
end if
else
'' This code runs whenever there is no message to process.
line (rcw.left+1,rcw.top)-(rcw.right-1,rcw.bottom-1), _color
line (rcw.right-1,rcw.top)-(rcw.left+1,rcw.bottom-1), _color
RedrawWindow( hwnd, 0, 0, RDW_INVALIDATE )
end if
loop
return wMsg.wParam
end function
'========================================================================
end WinMain( GetModuleHandle( null ), null, command$, SW_NORMAL )
'========================================================================