'*******************
'* ColorBlocks.bas *
'*******************
$AppType GUI
$Optimize Off
$Compress Off
$Include "Windows.inc"
$Resource IDI_COLORBLOCKS As "ColorBlocks.ico"
$Const xSteps = 5
$Const ySteps = 4
Dim message As MSG
Dim rct As RECT
Dim wcex As WNDCLASSEX
Dim ps As PAINTSTRUCT
Dim hInst As Integer
Dim hWindow As Integer
Dim xSize As Integer
Dim ySize As Integer
Dim strClassName As String
Dim strAppTitle As String
Function OnSize(hWnd As Integer, uMsg As Integer, _
wParam As Integer, lParam As Integer) As Integer
xSize = LoWord(lParam) / xSteps
ySize = HiWord(lParam) / ySteps
Result = 0
End Function
Function OnPaint(hWnd As Integer, uMsg As Integer, _
wParam As Integer, lParam As Integer) As Integer
Dim hdc As Integer
Dim PalIndex As Integer
Dim i As Integer
Dim j As Integer
Dim hPen As Integer
Dim hPenPrevious As Integer
Dim hBrush As Integer
Dim hBrushPrevious As Integer
hdc = BeginPaint(hWnd, ps)
j = 0
while j < ySteps
i = 0
while i < xSteps
PalIndex = j * xSteps + 0x01000000 + i
hPen = CreatePen(PS_SOLID, 1, PalIndex)
hPenPrevious = SelectObject(hdc, hPen)
hBrush = CreateSolidBrush(PalIndex)
hBrushPrevious = SelectObject(hdc, hBrush)
rct.left = i * xSize
rct.top = j * ySize
rct.right = (i + 1) * xSize - 1
rct.bottom = (j + 1) * ySize - 1
Rectangle(hdc, rct.left, rct.top, rct.right,rct.bottom)
DeleteObject(hPenPrevious)
DeleteObject(hBrushPrevious)
i = i + 1
Wend
j = j + 1
Wend
EndPaint(hWnd, ps)
Result = 0
End Function
Function OnClose(hWnd As Integer, uMsg As Integer, _
wParam As Integer, lParam As Integer) As Integer
If MessageBox(hWnd, "Exit application?", _
strAppTitle, MB_YESNO + MB_ICONQUESTION) = IDYES Then
DestroyWindow(hWnd)
Result = 0
Else
Result = 1
End If
End Function
Function WindowProc(hWnd As Integer, uMsg As Integer, _
wParam As Integer, lParam As Integer) As Integer
If uMsg = WM_SIZE Then
Result = OnSize(hWnd, uMsg, wParam, lParam)
ElseIf uMsg = WM_PAINT Then
Result = OnPaint(hWnd, uMsg, wParam, lParam)
ElseIf uMsg = WM_CLOSE Then
Result = OnClose(hWnd, uMsg, wParam, lParam)
ElseIf uMsg = WM_DESTROY Then
PostQuitMessage(0)
Result = 0
Else
Result = DefWindowProc(hWnd, uMsg, wParam, lParam)
End If
End Function
'***
strAppTitle = "Color Blocks"
strClassName = "KoolBClass"
hInst = GetModuleHandle(0)
wcex.cbSize = SizeOf(WNDCLASSEX)
wcex.style = CS_VREDRAW + CS_HREDRAW + CS_CLASSDC
wcex.lpfnwndproc = CodePtr(WindowProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInst
wcex.hIcon = LoadIcon(hInst, MakeIntResource(IDI_COLORBLOCKS))
wcex.hCursor = LoadCursor(0, MakeIntResource(IDC_ARROW))
wcex.hbrBackground = GetStockObject(WHITE_BRUSH)
wcex.lpszMenuName = ""
wcex.lpszClassName = strClassName
wcex.hIconSm = 0
If (RegisterClassEx(wcex)) = 0 Then
MessageBox(0, "RegisterClassEx failed.", strAppTitle, MB_OK)
ExitProcess(0)
End If
hWindow = CreateWindowEx(WS_EX_APPWINDOW + WS_EX_WINDOWEDGE, _
strClassName, strAppTitle, _
WS_OVERLAPPEDWINDOW + WS_VISIBLE, _
CW_USEDEFAULT, CW_USEDEFAULT, _
583, 488, _
0, 0, wcex.hInstance, 0)
If hWindow = 0 Then
MessageBox(0, "CreateWindowEx failed.", strAppTitle, MB_OK)
ExitProcess(0)
End If
While GetMessage(message, 0, 0, 0) > 0
TranslateMessage(message)
DispatchMessage(message)
Wend