flattering ball

[Frank Brübach]

hi. a simple but funny supplement of "bounce" example by petzold. this blue ball is flattering, bouncing and walking slowly down to earth.

my 5 cents for today

Code Select Expand


#COMPILE EXE
#DIM ALL
#INCLUDE "win32api.inc"

%ID_TIMER = 1

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WINMAIN (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
                  BYVAL pszCmdLine AS ASCIIZ PTR, BYVAL iCmdShow AS LONG) AS LONG

   LOCAL szAppName AS ASCIIZ * 256
   LOCAL msg       AS tagMsg
   LOCAL hWnd      AS DWORD
   LOCAL wc        AS WNDCLASS
   LOCAL szCaption AS ASCIIZ * 256

   szAppName        = "Bounce"
   wc.style         = %CS_HREDRAW OR %CS_VREDRAW
   wc.lpfnWndProc   = CODEPTR(WndProc)
   wc.cbClsExtra    = 0
   wc.cbWndExtra    = 0
   wc.hInstance     = hInstance
   wc.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wc.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wc.hbrBackground = GetStockObject(%WHITE_BRUSH)' or %BLUE or Transparence)
   wc.lpszMenuName  = %NULL
   wc.lpszClassName = VARPTR(szAppName)

   IF ISFALSE RegisterClass(wc) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   szCaption = "Flattering Ball walks slowly down"
   hWnd = CreateWindow (szAppName, _             ' window class name
                        szCaption, _             ' 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
                        %NULL, _                 ' parent window handle
                        %NULL, _                 ' window menu handle
                        hInstance, _             ' program instance handle
                        %NULL)                   ' creation parameters

   ShowWindow hWnd, iCmdShow
   UpdateWindow hWnd

   WHILE GetMessage(msg, %NULL, 0, 0)
      TranslateMessage msg
      DispatchMessage msg
   WEND

   FUNCTION = Msg.wParam

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hWnd AS DWORD, BYVAL message AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   STATIC hBitmap  AS DWORD
   STATIC cxClient AS LONG
   STATIC cyClient AS LONG
   STATIC xCenter  AS LONG
   STATIC yCenter  AS LONG
   STATIC cxTotal  AS LONG
   STATIC cyTotal  AS LONG
   STATIC cxRadius AS LONG
   STATIC cyRadius AS LONG
   STATIC cxMove   AS LONG
   STATIC cyMove   AS LONG
   STATIC xPixel   AS LONG
   STATIC yPixel   AS LONG
   LOCAL  hBrush   AS DWORD
   LOCAL  hdc      AS DWORD
   LOCAL  hdc1     AS DWORD
   LOCAL  hdcMem   AS DWORD
   LOCAL  hdcMem1  AS DWORD
   LOCAL  iScale   AS LONG

   SELECT CASE message

     CASE %WM_CREATE
         hdc = GetDC(hwnd)
         hdc1 = GetDC(hwnd)
         xPixel = GetDeviceCaps(hdc, %ASPECTX)
         yPixel = GetDeviceCaps(hdc, %ASPECTY)
         ReleaseDC hwnd, hdc
         SetTimer hwnd, %ID_TIMER, 60, %NULL
         FUNCTION = 0
         EXIT FUNCTION

     CASE %WM_SIZE
         cxClient = LOWRD(lParam)
         cyClient = HIWRD(lParam)
         xCenter = cxClient  \ 4
         yCenter = cyClient  \ 4
         iScale = MIN&(cxClient * xPixel, cyClient * yPixel) \ 16
         cxRadius = iScale \ xPixel
         cyRadius = iScale \ yPixel
         cxMove = MAX&(1, cxRadius \ 4) '2
         cyMove = MAX&(1, cyRadius \ 4) '2
         cxTotal = 4 * (cxRadius + cxMove)
         cyTotal = 4 * (cyRadius + cyMove)
         IF hBitmap THEN DeleteObject hBitmap
         hdc = GetDC(hwnd)
         hdcMem = CreateCompatibleDC(hdc)
         hBitmap = CreateCompatibleBitmap(hdc, cxTotal, cyTotal)
         ReleaseDC hwnd, hdc
         SelectObject hdcMem, hBitmap
         Rectangle hdcMem, -1, -1, cxTotal + 2, cyTotal + 2
         hBrush = CreateHatchBrush(%HS_DIAGCROSS, 0)
         SelectObject hdcMem, hBrush
         SetBkColor hdcMem, RGB(RND(1,55), 0, 255)
         ELLIPSE hdcMem, cxMove, cyMove, cxTotal - cxMove, cyTotal - cyMove
         DeleteDC hdcMem
         DeleteObject hBrush
         FUNCTION = 0
         EXIT FUNCTION

      CASE %WM_TIMER
         IF ISFALSE hBitmap THEN EXIT FUNCTION
         hdc = GetDC(hwnd)
         hdcMem = CreateCompatibleDC(hdc)
         SelectObject hdcMem, hBitmap
         BitBlt hdc, xCenter - cxTotal \ 2, _
                     yCenter - cyTotal \ 2, cxTotal, cyTotal, _
                hdcMem, 0, 0, %SRCCOPY
         ReleaseDC hwnd, hdc
         DeleteDC hdcMem
         xCenter = xCenter+0.5 + cxMove'*COS(yCenter+gettickcount*12)
         yCenter = yCenter+0.5 + cyMove*SIN(xCenter+gettickcount*24)
         IF (xCenter + cxRadius) >= cxClient OR (xCenter - cxRadius <= 0) THEN cxMove = -cxMove
         IF (yCenter + cyRadius) >= cyClient OR (yCenter - cyRadius) <= 0 THEN cyMove = -cyMove
         FUNCTION = 0
         EXIT FUNCTION

     CASE %WM_DESTROY
         IF hBitmap THEN DeleteObject hBitmap
         KillTimer hwnd, %ID_TIMER
         PostQuitMessage 0
         FUNCTION = 0
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProc(hWnd, message, wParam, lParam)

END FUNCTION
' ========================================================================================



servus, frank