'=========================================================================== ' Subject: GRAPHICS DRAWING PROGRAM FOR PB Date: 07-06-99 (17:29) ' Author: Dave Navarro, Jr. Code: PBCC ' Origin: dave@powerbasic.com Packet: PBCC.ABC '=========================================================================== '------------------------------------------------------------------------------- ' ' COOL.BAS for 32-bit PB/CC 2.0 ' Copyright (c) 1999 by PowerBASIC, Inc. ' ' A simple graphics drawing program ' Ported from PB/DOS to PB/CC 6.0 by Lance Edmonds 1999 ' Original PB/DOS code by Dave Navarro. ' ' Uses a 30mSec Timer to do the drawing updates, and uses less than 1% of the ' processor time (as measured on an AMD K6-266/64Mb/1Mb S3 Trio video card) ' '------------------------------------------------------------------------------ #DIM ALL #COMPILE EXE #OPTION VERSION4 #INCLUDE "WIN32API.INC" DEFLNG a-z $IF %DEF(%pb_dll32) $ClassName = "PB/DLL Simple Graphics Demo" $ELSE $ClassName = "PB/CC Simple Graphics Demo" $ENDIF '------------------------------------------------------------------------------ FUNCTION WinMain (BYVAL hInstance AS LONG, _ BYVAL hPrevInstance AS LONG, _ lpCmdLine AS ASCIIZ PTR, _ BYVAL iCmdShow AS LONG) AS LONG LOCAL Msg AS tagMsg LOCAL wndclass AS WndClassEx LOCAL szClassName AS ASCIIZ * 80 LOCAL hWnd AS LONG LOCAL hTimer AS LONG szClassName = $ClassName wndclass.cbSize = SIZEOF(WndClass) wndclass.style = %CS_HREDRAW OR %CS_VREDRAW wndclass.lpfnWndProc = CODEPTR( WndProc ) wndclass.cbClsExtra = 0 wndclass.cbWndExtra = 0 wndclass.hInstance = hInstance wndclass.hIcon = LoadIcon( hInstance, "PROGRAM" ) wndclass.hCursor = LoadCursor( %NULL, BYVAL %IDC_ARROW ) wndclass.hbrBackground = GetStockObject( %BLACK_BRUSH ) wndclass.lpszMenuName = %NULL wndclass.lpszClassName = VARPTR(szClassName) wndclass.hIconSm = LoadIcon( hInstance, BYVAL %IDI_APPLICATION ) RegisterClassEx wndclass ' Create a window using the registered class hWnd = CreateWindowEx(0, _ ' extended Window style $ClassName, _ ' window class name $ClassName, _ ' window caption %WS_OVERLAPPEDWINDOW, _ ' window style %CW_USEDEFAULT, _ ' initial x position %CW_USEDEFAULT, _ ' initial y position %CW_USEDEFAULT, _ ' initial x size %CW_USEDEFAULT, _ ' initial y size %HWND_DESKTOP, _ ' parent window handle BYVAL 0, _ ' window menu handle hInstance, _ ' program instance handle BYVAL %NULL) ' creation parameters ShowWindow hWnd, iCmdShow UpdateWindow hWnd ' Create a timer event every 30 mSec hTimer = SetTimer(hWnd, 0, 30, BYVAL %NULL) WHILE GetMessage(Msg, %NULL, 0, 0) TranslateMessage Msg DispatchMessage Msg WEND ' Destroy the timer KillTimer hWnd, 0 FUNCTION = msg.wParam END FUNCTION ' WinMain '------------------------------------------------------------------------------ FUNCTION WndProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _ BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG DIM Rct AS RECT DIM PS AS PAINTSTRUCT DIM hDC AS LONG DIM Pt AS POINTAPI STATIC hOldPen AS LONG DIM x1(40) AS STATIC LONG, x2(40) AS STATIC LONG, y1(40) AS STATIC LONG, y2(40) AS STATIC LONG DIM a1(40) AS STATIC LONG, a2(40) AS STATIC LONG, b1(40) AS STATIC LONG, b2(40) AS STATIC LONG STATIC x1 AS LONG, x2 AS LONG, y1 AS LONG, y2 AS LONG STATIC a1 AS LONG, a2 AS LONG, b1 AS LONG, b2 AS LONG STATIC c1 AS LONG, c2 AS LONG STATIC xd1 AS LONG, xd2 AS LONG STATIC yd1 AS LONG, yd2 AS LONG STATIC ad1 AS LONG, ad2 AS LONG STATIC bd1 AS LONG, bd2 AS LONG STATIC iOk AS LONG, Change1 AS LONG, Change2 AS LONG SELECT CASE wMsg CASE %WM_CREATE RANDOMIZE TIMER GetClientRect hWnd, Rct x1 = RND(10, Rct.nRight - 10) : x2 = RND(10, Rct.nRight - 10) y1 = RND(10, Rct.nBottom - 10) : y2 = RND(10, Rct.nBottom - 10) a1 = RND(10, Rct.nRight - 10) : a2 = RND(10, Rct.nRight - 10) b1 = RND(10, Rct.nBottom - 10) : b2 = RND(10, Rct.nBottom - 10) c1 = RGB(255,255,0) ' Yellow c2 = RGB(0,112,255) ' Blue xd1 = 9 : xd2 = 7 yd1 = 6 : yd2 = 10 ad1 = -11 : ad2 = 7 bd1 = 4 : bd2 = -13 Change1 = 0 Change2 = 0 iOk = -1 EXIT FUNCTION CASE %WM_SIZE iOk = 0 InvalidateRect hWnd, BYVAL %NULL, %TRUE SendMessage hWnd, %WM_CREATE, 0, 0 EXIT FUNCTION CASE %WM_COMMAND CASE %WM_SYSCOMMAND IF wParam = %SC_CLOSE THEN DestroyWindow hWnd EXIT FUNCTION END IF CASE %WM_PAINT IF ISFALSE iOk THEN EXIT SELECT hDC = BeginPaint(hWnd, PS) ARRAY DELETE x1(1) : ARRAY DELETE x2(1) ARRAY DELETE y1(1) : ARRAY DELETE y2(1) ARRAY DELETE a1(1) : ARRAY DELETE a2(1) ARRAY DELETE b1(1) : ARRAY DELETE b2(1) hOldPen = SelectObject(hDC, CreatePen(%PS_SOLID, 1, c1)) MoveToEx hDC, x1, y1, BYVAL %NULL LineTo hDC, x2, y2 DeleteObject SelectObject(hDC, GetStockObject(%Black_Pen)) MoveToEx hDC, x1(1), y1(1), byval %NULL LineTo hDC, x2(1), y2(1) DeleteObject SelectObject(hDC, CreatePen(%PS_SOLID, 1, c2)) MoveToEx hDC, a1, b1, byval %NULL LineTo hDC, a2, b2 ', c2 DeleteObject SelectObject(hDC, GetStockObject(%Black_Pen)) MoveToEx hDC, a1(1), b1(1), byval %NULL LineTo hDC, a2(1), b2(1) DeleteObject SelectObject(hDC, hOldPen) EndPaint hWnd, PS EXIT FUNCTION CASE %WM_Timer IF ISFALSE iOk THEN EXIT SELECT GetClientRect hWnd, Rct InvalidateRect hWnd, BYVAL %NULL, %FALSE UpdateWindow hWnd x1(40) = x1 : x2(40) = x2 y1(40) = y1 : y2(40) = y2 a1(40) = a1 : a2(40) = a2 b1(40) = b1 : b2(40) = b2 x1 = x1 + xd1 : x2 = x2 + xd2 y1 = y1 + yd1 : y2 = y2 + yd2 a1 = a1 + ad1 : a2 = a2 + ad2 b1 = b1 + bd1 : b2 = b2 + bd2 IF (x1 < 1) OR (x1 => Rct.nRight -1) THEN xd1 = -xd1 INCR Change1 END IF IF (x2 < 1) OR (x2 => Rct.nRight -1) THEN xd2 = -xd2 INCR Change1 END IF IF (a1 < 1) OR (a1 => Rct.nRight -1) THEN ad1 = -ad1 INCR Change2 END IF IF (a2 < 1) OR (a2 => Rct.nRight -1) THEN ad2 = -ad2 INCR Change2 END IF IF (y1 < 1) OR (y1 => Rct.nBottom -1) THEN yd1 = -yd1 INCR Change1 END IF IF (y2 < 1) OR (y2 => Rct.nBottom -1) THEN yd2 = -yd2 INCR Change1 END IF IF (b1 < 1) OR (b1 => Rct.nBottom -1) THEN bd1 = -bd1 INCR Change2 END IF IF (b2 < 1) OR (b2 => Rct.nBottom - 1) THEN bd2 = -bd2 INCR Change2 END IF IF Change1 => 4 THEN c1 = RGB(RND(1,4) * 64, RND(1,4) * 64, RND(1,4) * 64) Change1 = 0 END IF IF Change2 => 4 THEN c2 = RGB(RND(1,4) * 64, RND(1,4) * 64, RND(1,4) * 64) Change2 = 0 END IF EXIT FUNCTION CASE %WM_DESTROY PostQuitMessage 0 EXIT FUNCTION END SELECT FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam) END FUNCTION