Vista and the Win API

Windows specific questions.
Mysoft
Posts: 774
Joined: Jul 28, 2005 13:56
Location: Brazil, Santa Catarina, Indaial (ouch!)
Contact:

Postby Mysoft » Mar 29, 2008 6:11

well.. i have not seen anything wrong in the code... except for one thing...

the color in the second example... RGB(255,255,255) this will not work with WINAPI that expect RGBA(255,255,255,0) and with RGB freebasic sends RGB(255,255,255,255) (so it have send white and it was actually plotted in black...) but its only that ;P (also the screen from DJ. PETERS is showing colors (fixed?) so...) the problem probabily lies with windows...

and i recommend to draw in a arbitrary HDC+BITMAP and only after that put it on the screen... (you will lose the instant drawing... but when the windows got draw again it will be MUCH faster... like a real buffer)

Code: Select all



#include once "windows.bi"

Declare Function WinMain ( Byval hInstance As HINSTANCE, _
                                      Byval hPrevInstance As HINSTANCE, _
                                      szCmdLine As String, _
                                      Byval iCmdShow As Integer ) As Integer
       
    End WinMain( GetModuleHandle( null ), null, Command$, SW_NORMAL )

Function WndProc ( Byval hWnd As HWND, _
                   Byval message As UINT, _
                   Byval wParam As WPARAM, _
                   Byval lParam As LPARAM ) As LRESULT
   
   Function = 0
 
   Dim As Integer i, xp , yp
   static mybmp as hbitmap
   static mydc as hdc

    Select Case( message )

        Case WM_CREATE           
            dim dskrct as RECT
            dim appdc as hdc
           
            GetClientRect( getdesktopwindow, @dskrct)
            appdc = getdc(hwnd)
            mydc = Createcompatibledc(appdc)
            mybmp = createcompatiblebitmap(appdc,dskrct.right,dskrct.bottom)
            selectobject(mydc,mybmp)
           
            ' **** drawing in the buffer ****
            FillRect(mydc,@dskrct,GetStockObject( WHITE_BRUSH ))
           
            For i = 0 To 500000
             xp = Cint(Rnd * 1000)
             yp = Cint(Rnd * 1000)
             SetPixelV( mydc, xp,yp, RGBA(rnd*255,rnd*255,rnd*255,0) )
           Next
           
            releasedc(hwnd,appdc)
           
            Exit Function

        Case WM_PAINT
            Dim rct As RECT
            Dim pnt As PAINTSTRUCT
            Dim hDC As HDC
         
            hDC = BeginPaint( hWnd, @pnt )
            GetClientRect( hWnd, @rct )
           
            ' *** blitting the buffer ****
            selectobject ( mydc, mybmp)                     
            bitblt(hdc,0,0,rct.right,rct.bottom,mydc,0,0,srccopy)
         
            EndPaint( hWnd, @pnt )
           
            Exit Function

        Case WM_KEYDOWN
            If( lobyte( wParam ) = 27 ) Then
                PostMessage( hWnd, WM_CLOSE, 0, 0 )
            End If

        Case WM_DESTROY
            PostQuitMessage( 0 )
            Exit Function
    End Select
   
    Function = DefWindowProc( hWnd, message, wParam, lParam )   
   
End Function

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
   
    Function = 0
 
    szAppName = "PixelTest"
   
    With wcls
        .style         = CS_HREDRAW Or CS_VREDRAW
        .lpfnWndProc   = @WndProc
        .cbClsExtra    = 0
        .cbWndExtra    = 0
        .hInstance     = hInstance
        .hIcon         = LoadIcon( NULL, IDI_APPLICATION )
        .hCursor       = LoadCursor( NULL, IDC_ARROW )
        .hbrBackground = null
        .lpszMenuName  = NULL
        .lpszClassName = Strptr( szAppName )
    End With
       
    If( RegisterClass( @wcls ) = FALSE ) Then
       MessageBox( null, "Failed to register wcls!", szAppName, MB_ICONERROR )
       Exit Function
    End If

    hWnd = CreateWindowEx( 0, _
                           szAppName, _
                           "Pixel Test", _
                           WS_OVERLAPPEDWINDOW, _
                           CW_USEDEFAULT, _
                           CW_USEDEFAULT, _
                           CW_USEDEFAULT, _
                           CW_USEDEFAULT, _
                           NULL, _
                           NULL, _
                           hInstance, _
                           NULL )
           
    ShowWindow( hWnd, iCmdShow )
    UpdateWindow( hWnd )
   
    While( GetMessage( @wMsg, NULL, 0, 0 ) <> FALSE )   
        TranslateMessage( @wMsg )
        DispatchMessage( @wMsg )
    Wend
   
    Function = wMsg.wParam

End Function
Mysoft
Posts: 774
Joined: Jul 28, 2005 13:56
Location: Brazil, Santa Catarina, Indaial (ouch!)
Contact:

Postby Mysoft » Mar 29, 2008 7:14

and something i have made while playing it it xD

Code: Select all

#include once "windows.bi"

Declare Function WinMain ( Byval hInstance As HINSTANCE, _
Byval hPrevInstance As HINSTANCE, _
szCmdLine As String, _
Byval iCmdShow As Integer ) As Integer

End WinMain( GetModuleHandle( null ), null, Command$, SW_NORMAL )

Function WndProc ( Byval hWnd As HWND, _
  Byval message As UINT, _
  Byval wParam As WPARAM, _
  Byval lParam As LPARAM ) As LRESULT
 
  Function = 0
 
  Dim As Integer i, xp , yp
 
  static mybmp as hbitmap
  static mydc as hdc
  static as single DOTX(15),DOTY(15),SPDX(15),SPDY(15)
  static as hpen COLOUR(15)
   
  Select Case( message )
 
  Case WM_CREATE           
    dim as rect dskrct,clirct
    dim appdc as hdc
   
    GetClientRect( getdesktopwindow, @dskrct)
    appdc = getdc(hwnd)
    mydc = Createcompatibledc(appdc)
    mybmp = createcompatiblebitmap(appdc,dskrct.right,dskrct.bottom)
    selectobject(mydc,mybmp)
   
    ' **** drawing in the buffer ****
    FillRect(mydc,@dskrct,GetStockObject( BLACK_BRUSH ))
    GetClientRect( hwnd, @clirct)
   
    for COUNT as integer = 0 to 15
      DOTX(COUNT) = rnd*clirct.right
      DOTY(COUNT) = rnd*clirct.bottom
      SPDX(COUNT) = -8+rnd*16
      SPDY(COUNT) = -8+rnd*16
      if abs(SPDX(COUNT)) < 1 then SPDX(COUNT) = 1
      if abs(SPDY(COUNT)) < 1 then SPDY(COUNT) = 1
      COLOUR(COUNT) = createpen(PS_SOLID,2,rgba(rnd*255,rnd*255,rnd*255,0))
    next COUNT
   
    releasedc(hwnd,appdc)
   
    settimer(hwnd,cast(integer,hwnd),1,null)
   
    Exit Function
 
  case WM_TIMER
   
    dim as rect RCT
    dim as integer CNT
   
    selectobject (mydc, mybmp)
    GetClientRect(hwnd,@RCT)
   
    FillRect(mydc,@RCT,GetStockObject( BLACK_BRUSH ))
    MoveToEx(mydc, DOTX(0), DOTY(0), null )
    for COUNT as integer = 1 to 16
      CNT = COUNT and 15
      Selectobject( mydc, COLOUR(CNT) )
      LineTo( mydc, DOTX(CNT), DOTY(CNT) )
      Ellipse( mydc, DOTX(CNT)-5, DOTY(CNT)-5, DOTX(CNT)+5,DOTY(CNT)+5)

      ' *** posx ***
      DOTX(CNT) += SPDX(CNT)
      if DOTX(CNT) < rct.left then
        DOTX(CNT) = rct.left
        SPDX(CNT) = 2 + rnd*6
        deleteobject(COLOUR(CNT))
        COLOUR(CNT) = createpen(PS_SOLID,2,rgba(rnd*255,rnd*255,rnd*255,0))
      elseif DOTX(CNT) > rct.right then
        DOTX(CNT) = rct.right
        SPDX(CNT) = -2 - rnd*6
        deleteobject(COLOUR(CNT))
        COLOUR(CNT) = createpen(PS_SOLID,2,rgba(rnd*255,rnd*255,rnd*255,0))
      end if
      ' *** posy ***
      DOTY(CNT) += SPDY(CNT)
      if DOTY(CNT) < rct.top then
        DOTY(CNT) = rct.top
        SPDY(CNT) = 2 + rnd*6
        deleteobject(COLOUR(CNT))
        COLOUR(CNT) = createpen(PS_SOLID,2,rgba(rnd*255,rnd*255,rnd*255,0))
      elseif DOTY(CNT) > rct.bottom then
        DOTY(CNT) = rct.bottom
        SPDY(CNT) = -2 - rnd*6
        deleteobject(COLOUR(CNT))
        COLOUR(CNT) = createpen(PS_SOLID,2,rgba(rnd*255,rnd*255,rnd*255,0))
      end if
     
    next COUNT
   
    invalidaterect(hwnd,null,false)
   
 
  case WM_MOVE,WM_MOVING
    invalidaterect(hwnd,null,false)
 
  Case WM_PAINT
    Dim rct As RECT
    Dim pnt As PAINTSTRUCT
    Dim hDC As HDC
   
    hDC = BeginPaint( hWnd, @pnt )
    GetClientRect( hWnd, @rct )
   
    ' *** blitting the buffer ****
    selectobject ( mydc, mybmp)   
    bitblt(hdc,0,0,rct.right,rct.bottom,mydc,0,0,SRCCOPY)
   
    EndPaint( hWnd, @pnt )
   
    Exit Function
   
  Case WM_KEYDOWN
    If( lobyte( wParam ) = 27 ) Then
      PostMessage( hWnd, WM_CLOSE, 0, 0 )
    End If
   
  Case WM_DESTROY
    PostQuitMessage( 0 )
    Exit Function
  End Select
 
  Function = DefWindowProc( hWnd, message, wParam, lParam )   
 
End Function

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
 
  Function = 0
 
  szAppName = "PixelTest"
 
  With wcls
    .style         = CS_HREDRAW Or CS_VREDRAW
    .lpfnWndProc   = @WndProc
    .cbClsExtra    = 0
    .cbWndExtra    = 0
    .hInstance     = hInstance
    .hIcon         = LoadIcon( NULL, IDI_APPLICATION )
    .hCursor       = LoadCursor( NULL, IDC_ARROW )
    .hbrBackground = null
    .lpszMenuName  = NULL
    .lpszClassName = Strptr( szAppName )
  End With
 
  If( RegisterClass( @wcls ) = FALSE ) Then
    MessageBox( null, "Failed to register wcls!", szAppName, MB_ICONERROR )
    Exit Function
  End If
 
  hWnd = CreateWindowEx( 0, _
  szAppName, _
  "Pixel Test", _
  WS_OVERLAPPEDWINDOW, _
  CW_USEDEFAULT, _
  CW_USEDEFAULT, _
  CW_USEDEFAULT, _
  CW_USEDEFAULT, _
  NULL, _
  NULL, _
  hInstance, _
  NULL )
 
  ShowWindow( hWnd, iCmdShow )
  UpdateWindow( hWnd )
 
  While( GetMessage( @wMsg, NULL, 0, 0 ) <> FALSE )   
    TranslateMessage( @wMsg )
    DispatchMessage( @wMsg )
  Wend
 
  Function = wMsg.wParam
 
End Function
tinram
Posts: 88
Joined: Nov 30, 2006 13:35
Location: UK

Postby tinram » Mar 29, 2008 10:29

Thank you Mysoft - I didn't know how to do buffering in a Win32 window, and your second example is very cool.

Return to “Windows”

Who is online

Users browsing this forum: No registered users and 4 guests