Win32: Calendar Demo - zydon - 12-16-2004
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.
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.
FreeBasic forum and examples/previews quicklist - VonGodric - 12-16-2004
Hey that's cool. like the calander demo-only could it be a bit bigger?
FreeBasic forum and examples/previews quicklist - adosorken - 12-16-2004
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.
re: comctl32.bi - zydon - 12-16-2004
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.
FreeBasic forum and examples/previews quicklist - Jofers - 12-16-2004
String ADDress.
http://qbasicnews.com/qboho/qcksadd.shtml
Re: Win32: Calendar Demo - Antoni Gual - 12-17-2004
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..
FreeBasic forum and examples/previews quicklist - adosorken - 12-17-2004
The calendar control (called MonthView) is part of Microsoft Windows Common Controls 2.
FreeBasic forum and examples/previews quicklist - carpiza - 12-17-2004
The code must be : :wink:
Code: ''
'' messages loop
''
do while ( GetMessage( wMsg, null, 0, 0 ) <> false )
TranslateMessage wMsg
DispatchMessage wMsg
loop
Done:
ExitProcess 0
re: loop and toolbar demo - zydon - 12-18-2004
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...
;--------------------------
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.
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.
FreeBasic forum and examples/previews quicklist - carpiza - 12-18-2004
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
|