Qbasicnews.com

Qbasicnews.com > General > General/Misc > FreeBasic forum and examples/previews quicklist
Full Version: FreeBasic forum and examples/previews quicklist
You're currently viewing a stripped down version of our content. View the full version with proper formatting.
Pages: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16

zydon

12-16-2004, 05:05 AM
Here is my example of using comctl32 to display calendar object in a window. It's require libcomctl32.a to compile this source code. I use old dev-cpp 4.0 libcomctl32.a file (dated 1999), then copy it into FB's \lib directory and it works okay with FB. Big Grin

[Image: wincal.gif]

Code:
'' filename: wincal.bas

'$include:'kernel32.bi'
'$include:'user32.bi'

const null    = 0
const true    = -1
const false   = 0

''
'' kernel32 Additon
''
declare sub ExitProcess _
        lib "kernel32" _
        alias "ExitProcess" _
        (lpModuleName as integer)

''
'' Comctrl32 Addition :: Require libcomctl32.a
''
const ICC_DATE_CLASSES = 256

type INITCOMMONCONTROLSEX
    dwSize as integer
    dwICC  as integer
end type

declare sub InitCommonControlsEx _
        lib "comctl32" _
        alias "InitCommonControlsEx" _
        (byval lpUdt as long)

dim shared szCalClass as string
    szCalClass = "SysMonthCal32"

dim shared hCal as long
dim iccx as INITCOMMONCONTROLSEX

iccx.dwSize = len( iccx )
iccx.dwICC  = ICC_DATE_CLASSES
InitCommonControlsEx @iccx



''
'' Window Procedure Handler
''
function WndProc ( byval hWnd as long, _
                   byval uMsg as long, _
                   byval wParam as long, _
                   byval lParam as long ) as integer

    WndProc = 0
    select case ( uMsg )
        case WM_CREATE
             hCal = CreateWindowEx( 0, _
                       szCalClass, "", _
                       WS_CHILD or _
                       WS_VISIBLE, _
                       2, 2, 200, 160, _
                       hWnd, null, _
                       hInstance, null )
        case WM_KEYDOWN
            if( (wParam and &hff) = 27 ) then
                PostMessage hWnd, WM_CLOSE, 0, 0
            end if
        case WM_DESTROY
            PostQuitMessage 0            
            exit function
    end select
    WndProc = DefWindowProc( hWnd, uMsg, wParam, lParam )    
end function


''
'' Program entry
''
dim wMsg as MSG
dim wcls as WNDCLASS    
dim hWnd as unsigned long
dim hInstance as long

dim szAppName as string
    szAppName = "WinCal32"

    
wcls.style         = CS_HREDRAW or CS_VREDRAW
wcls.lpfnWndProc   = @WndProc()
wcls.cbClsExtra    = 0
wcls.cbWndExtra    = 0
wcls.hInstance     = hInstance
wcls.hIcon         = LoadIcon( null, IDI_APPLICATION )
wcls.hCursor       = LoadCursor( null, IDC_ARROW )
wcls.hbrBackground = 6  ' default color
wcls.lpszMenuName  = null
wcls.lpszClassName = sadd( szAppName )
    
    
if ( RegisterClass( wcls ) = false ) then
   MessageBox null, "Failed to register wcls!", _
              szAppName, MB_ICONERROR
   Goto Done
end if
    
hWnd = CreateWindowEx( 0, _
         szAppName, "Calendar Demo [ESC to Quit]", _
         WS_CLIPCHILDREN or _
         WS_DLGFRAME or WS_BORDER or _
         WS_VISIBLE, _
         200, 200, 210, 190, _
         null, null, hInstance, null )
                          
''
'' messages loop
''
Again:
   if ( GetMessage( wMsg, null, 0, 0 ) = false ) _
      then goto Done

   TranslateMessage wMsg
   DispatchMessage  wMsg
   Gosub Again


Done:    
    ExitProcess 0

It has been fun for me so far playing with FB. I would try experimenting with other win32 coding using the fantastic FB compiler.

cheers,

zydon.

VonGodric

12-16-2004, 05:22 AM
Hey that's cool. like the calander demo-only could it be a bit bigger?

adosorken

12-16-2004, 06:14 AM
zydon, would you have any interest in creating a comctl32.bi file for FB? Looks like you've already gotten a good start on it. Smile

zydon

12-16-2004, 10:55 PM
adosorken, I'm not sure I'm qualify to do such conversion. But I could try though. I'm not c or cpp user either.

if FB got those $define, $ifdef, $ifndef, $else, $endif and $undef, it would be easier to create comctl32 header for FB. const is likely will store all unuse header defined values into final executable. The above processor directive is just replacing defined values which is only existed in source code. The rest of defined values will not be stored into final output.

Is there any planned FB to have directive keywords in future?


btw, what is sadd()? I seem can't find any description about this keyword.


zydon.

Jofers

12-16-2004, 11:42 PM
String ADDress.
http://qbasicnews.com/qboho/qcksadd.shtml

Antoni Gual

12-17-2004, 03:21 AM
AAAAARGH!!!!
Quote:
Code:
''
'' messages loop
''
Again:
   if ( GetMessage( wMsg, null, 0, 0 ) = false ) _
      then goto Done
   TranslateMessage wMsg
   DispatchMessage  wMsg
   Gosub Again
Done:    
    ExitProcess 0

How many clicks does it stand before it breaks? :o

A GOSUB calling itself recursively...and exiting by a GOTO!!!!! In QB this code would'nt last one minute!

If you want to use GOSUB (just because it's so deprecated.... 8) ), ALWAYS exit it with RETURN or it will eat the stack and the program will blow out...

In this case a better solution would be:

Code:
do while ( GetMessage( wMsg, null, 0, 0 ) = false )
      
   TranslateMessage wMsg
   DispatchMessage  wMsg
loop
    
    ExitProcess 0

BTW: I did'nt know comctl32 had such things as calenders..

adosorken

12-17-2004, 06:41 AM
The calendar control (called MonthView) is part of Microsoft Windows Common Controls 2.

carpiza

12-17-2004, 04:12 PM
The code must be : :wink:

Code:
''
'' messages loop
''

do while ( GetMessage( wMsg, null, 0, 0 ) <> false )

   TranslateMessage wMsg
   DispatchMessage  wMsg

loop
    
Done:
    ExitProcess 0

zydon

12-18-2004, 03:57 AM
Quote:A GOSUB calling itself recursively...and exiting by a GOTO!!!!! In QB this code would'nt last one minute!

Sorry..., I've made chaos to QB community. I've not having any QB experience myself. I used GOSUB just for it's keyword sound good or simply thought it suitable for presenting jump backward. Btw, it still MS Window engine. In win32, all those loops will be terminated by ExitProcess.

WHILE..WEND also can be used. It is just a variation or personal preference on how you want the loop being handled. In the end, it will be translated into machine code as jne, je and jmp for those GOTO and GOSUB as far as I know a little about them... Wink

;--------------------------

Here another example from me. Still win32 and comctl32 demo with a toolbar using internal bitmaps. Just to show the toolbar, have yet got user interraction example since I've to find the way to make a workable button command ID to trap from winproc messages.

[Image: wintb.gif]

Code:
'' filename: wintb.bas

'$include:'kernel32.bi'
'$include:'user32.bi'

const null    = 0
const true    = -1
const false   = 0

'' --------------------------------------------
'' user32 Additon
'' --------------------------------------------
declare function SendMessage _
        Lib "user32" _
        Alias "SendMessageA" _
        (ByVal hWnd As Long, _
         ByVal uMsg As Long, _
         ByVal wParam As Long, _
         ByVal lParam As Long) As Long

'' --------------------------------------------
'' kernel32 Additon
'' --------------------------------------------
declare sub ExitProcess _
        lib "kernel32" _
        alias "ExitProcess" _
        (lpModuleName as integer)

'' --------------------------------------------
'' Comctrl32 Addition :: Require libcomctl32.a
'' --------------------------------------------
type TBADDBITMAP
    handle as LONG
    nID    as LONG
end type

type TBBUTTON
    iBitmap    as LONG
    idCommand  as LONG
    fsState    as BYTE
    fsStyle    as BYTE
    bReserved  as SHORT
    dwData     as LONG
    iString    as LONG
end type

type INITCOMMONCONTROLSEX
    dwSize as LONG
    dwICC  as LONG
end type

#define HINST_COMMCTRL -1
#define ICC_BAR_CLASSES 4
#define IDB_STD_SMALL_COLOR 0

#define TBSTATE_ENABLED 4
#define TBSTYLE_BUTTON  0
#define TBSTYLE_SEP     1
#define TBSTYLE_FLAT    2048

#define CCS_ADJUSTABLE  32
#define CCS_NODIVIDER   64

#define STD_CUT         0
#define STD_COPY        1
#define STD_PASTE       2
#define STD_FILENEW        6
#define STD_FILEOPEN    7
#define STD_FILESAVE    8

#define TB_ADDBITMAP        1043
#define TB_ADDBUTTONS       1044
#define TB_ADDSTRING        1052
#define TB_BUTTONSTRUCTSIZE 1054

const TB_STYLES = ( TBSTYLE_FLAT or CCS_ADJUSTABLE or CCS_NODIVIDER )

declare sub InitCommonControlsEx _
        lib "comctl32" _
        alias "InitCommonControlsEx" _
        (byval lpUdt as long)

'' --------------------------------------------
'' Comctrl32 Addition :: End here
'' --------------------------------------------


''
'' Window Procedure Handler
''
function WndProc ( byval hWnd as long, _
                   byval uMsg as long, _
                   byval wParam as long, _
                   byval lParam as long ) as integer

    WndProc = 0
    select case ( uMsg )
        case WM_CREATE
             dim i as LONG
             dim hEAX as LONG
            
             '' Toolbar object handle    
             dim hTools as LONG
            
             '' Toolbar class string
             dim szTBClass as STRING
                 szTBClass = "ToolbarWindow32"

             '' Toolbar button constructors
             dim tbAddBmp as TBADDBITMAP
             dim tbb as TBBUTTON

             '' setting common control mode
             dim iccx as INITCOMMONCONTROLSEX
                 iccx.dwSize = len( iccx )
                 iccx.dwICC  = ICC_BAR_CLASSES

             '' bitmap for each button
             dim tbBmp(7) as BYTE
                 tbBmp(0) = STD_FILENEW
                 tbBmp(1) = STD_FILEOPEN
                 tbBmp(2) = STD_FILESAVE
                 tbBmp(4) = STD_CUT
                 tbBmp(5) = STD_COPY
                 tbBmp(6) = STD_PASTE

             '' initialize common controls 32
             InitCommonControlsEx @iccx

             '' Lets build a new toolbar
             hTools = CreateWindowEx( WS_EX_DLGMODALFRAME, _
                       szTBClass, "", _
                       WS_CHILD or WS_VISIBLE or TB_STYLES, _
                       CW_DEFAULT, CW_DEFAULT, CW_DEFAULT, CW_DEFAULT, _
                       hWnd, null, _
                       hInstance, null )
            
             '' paint toolbar buttons now
            if ( hTools <> false ) then
              
               '' draw toolbar panel
               hEAX = SendMessage( hTools,TB_BUTTONSTRUCTSIZE,len( tbb ),0 )
               tbAddBmp.handle = HINST_COMMCTRL
               tbAddBmp.nID    = IDB_STD_SMALL_COLOR
               hEAX = SendMessage( hTools,TB_ADDBITMAP,0,@tbAddBmp )

               '' apply bitmap to toolbar buttons
               for i = 0 to 6
                   tbb.iBitmap   = tbBmp(i)
                   tbb.fsState   = TBSTATE_ENABLED
                   if ( i = 3 ) then
                      tbb.fsStyle   = TBSTYLE_SEP
                   else
                      tbb.fsStyle   = TBSTYLE_BUTTON
                   end if
                   tbb.idCommand = -1
                   tbb.dwData    = 0
                   hEAX = SendMessage( hTools,TB_ADDBUTTONS,1,@tbb )
               next
            end if
        case WM_KEYDOWN
            if( (wParam and &hff) = 27 ) then
                PostMessage hWnd, WM_CLOSE, 0, 0
            end if
        case WM_DESTROY
            PostQuitMessage 0            
            exit function
    end select
    WndProc = DefWindowProc( hWnd, uMsg, wParam, lParam )    
end function


''
'' Program entry
''
dim wMsg as MSG
dim wcls as WNDCLASS    
dim hWnd as unsigned long
dim hInstance as long

dim szAppName as string
    szAppName = "WinToolBar"
    
wcls.style         = CS_HREDRAW or CS_VREDRAW
wcls.lpfnWndProc   = @WndProc()
wcls.cbClsExtra    = 0
wcls.cbWndExtra    = 0
wcls.hInstance     = hInstance
wcls.hIcon         = LoadIcon( null, IDI_APPLICATION )
wcls.hCursor       = LoadCursor( null, IDC_ARROW )
wcls.hbrBackground = 16  ' btnface color
wcls.lpszMenuName  = null
wcls.lpszClassName = sadd( szAppName )
    
if ( RegisterClass( wcls ) = false ) then
   MessageBox null, "Failed to register wcls!", _
              szAppName, MB_ICONERROR
   Goto Done
end if
    
hWnd = CreateWindowEx( 0, _
         szAppName, "ToolBar Demo", _
         WS_OVERLAPPEDWINDOW or WS_VISIBLE, _
         100, 100, 300, 200, _
         null, null, hInstance, null )
                          
''
'' messages loop
''
Again:
   if ( GetMessage( wMsg, null, 0, 0 ) = false ) _
      then goto Done

   TranslateMessage wMsg
   DispatchMessage  wMsg
   goto Again


Done:    
    ExitProcess 0

ps - Jofers, thanks about the sadd info link. I presumme it's a same as VARPTR$()?

a newbie coder,

zydon.

carpiza

12-18-2004, 05:19 AM
Hi Zidon

I don't know if there is a switch to let fbc compiles #defines :

#define HINST_COMMCTRL -1

I need to change those to :

const HINST_COMMCTRL = 1

To compile them Ok

BTW Really nice Win32 API examples!
Carlos
Pages: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
Qbasicnews.com > General > General/Misc > FreeBasic forum and examples/previews quicklist