Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
ProgressBarDemo (RGBA statt RGB) :))
| Uploader: |  Volta |
| Datum/Zeit: | 14.08.2007 10:12:25 |
#include once "windows.bi"
#include once "win/commctrl.bi"
DIM Shared AS UINTEGER progress, PrevWndProcProzess
Dim Shared As HINSTANCE hInstance
Declare Function WndProc (BYVAL hWnd As HWND, Byval uMsg As UINT, _
Byval wParam As WPARAM, Byval lParam As LPARAM ) As INTEGER
Declare Function ProgressWndProc (Byval hwnd As HWND,Byval message As UINT, _
Byval wParam As WPARAM,Byval lParam As LPARAM) As LRESULT
hInstance = GetModuleHandle( null )
' Main
Dim wMsg As MSG
Dim wcls As WNDCLASS
Dim hWnd As HWND
Dim Shared As HWND hProgressBar
Dim appName As STRING
appName = "ProgressBarDemo"
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 = CPTR( HGDIOBJ, COLOR_BACKGROUND )
.lpszMenuName = null
.lpszClassName = STRPTR( appName )
END With
IF ( RegisterClass( @wcls ) = false ) THEN
MessageBox( null, "Fehler bei der Registrierung der WindowClass!", _
appName, MB_ICONERROR )
End 1
End If
hWnd = CreateWindowEx( 0, appName, "ProgressBar Demo ( <- Taste -> )", _
WS_OVERLAPPEDWINDOW Or WS_VISIBLE, _
CW_USEDEFAULT, CW_USEDEFAULT, 440, 100, _
null, null, hInstance, null )
'messages LOOP
DO UNTIL( GetMessage( @wMsg, null, 0, 0 ) = FALSE )
TranslateMessage( @wMsg )
DispatchMessage ( @wMsg )
Loop
End 0
' WINDOW Procedure Handler
Function WndProc ( Byval hWnd As HWND, Byval uMsg As UINT, _
Byval wParam As WPARAM, Byval lParam As LPARAM ) As Integer
STATIC As Integer ipos, a=1
Select CASE ( uMsg )
Case WM_CREATE
InitCommonControls() 'initialisiere COMMON controls
'erstellt ProgressBar
hProgressBar = CreateWindowEx(0,PROGRESS_CLASS, "ProgressBar", _
WS_CHILD Or WS_VISIBLE Or PBS_SMOOTH,_ '
20, 30, 400, 16, _
hWnd, null, hInstance, null )
PrevWndProcProzess = SetWindowLong(hProgressBar, GWL_WNDPROC, CAST (Uinteger,@ProgressWndProc))
RETURN 0
Case WM_KEYDOWN
If( LOBYTE( wParam ) = 27 ) Then
PostMessage( hWnd, WM_CLOSE, 0, 0 )
ELSE
ipos +=a
SendMessage hProgressBar, PBM_SETPOS, ipos, 0
progress = ipos
If ipos=0 Or ipos=99 Then a=-a
End If
Return 0
Case WM_DESTROY
SetWindowLong (hProgressBar, GWL_WNDPROC, PrevWndProcProzess)
DestroyWindow hProgressBar 'Destroy hProgressBar
PostQuitMessage( 0 )
EXIT Function
End Select
Function = DefWindowProc( hWnd, uMsg, wParam, lParam )
End Function
' Die neue WND-PROC für das ProgressBar
Function ProgressWndProc (Byval hwnd As HWND, Byval message As UINT, _
Byval wParam As WPARAM, Byval lParam As LPARAM) As LRESULT
Dim As RECT Rect
Dim As HDC hdc
Dim As PAINTSTRUCT ps
Dim As String szStr
Dim As HRGN hRgn
Dim As HBRUSH hBrush1,hBrush2
'kleiner Fehler -> große Wirkung :))
Dim As COLORREF BarFore = Rgba(0,128,0,0) ' Farbe Fortschritts Anzeige
Dim As COLORREF BarBk = Rgba(0,0,255,0) ' Hintergrund Farbe (in Win = BGRA)
Dim As COLORREF TextFore = Rgba(0,0,0,0) ' Text Farbe Auf Hintergrund
Dim As COLORREF TextBk = Rgba(255,255,255,0) ' Text Farbe Auf Fortschritts Anzeige
SELECT CASE message
Case WM_PAINT, WM_LBUTTONDOWN 'vermutlich so?
szStr = "Test " & progress
hdc=BeginPaint(hwnd,@ps)
GetClientRect(hwnd,@Rect)
hBrush1=CreateSolidBrush(BarFore)
hBrush2=CreateSolidBrush(BarBk)
'drawing LEFT part of bar
hRgn=CreateRectRgn(0,0,progress*Rect.RIGHT/100,Rect.bottom)
FillRgn(hdc,hRgn,hBrush1)
SetBkMode(hdc,TRANSPARENT)
SelectClipRgn(hdc,hRgn)
SetTextColor(hdc,TextBk)
DrawText (hdc, szStr, lstrlen(szStr), @Rect, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
SelectClipRgn(hdc,NULL)
DeleteObject(hRgn)
'drawing right part of bar
hRgn=CreateRectRgn((progress*Rect.right/100),0,Rect.right,Rect.bottom)
FillRgn(hdc,hRgn,hBrush2)
SelectClipRgn(hdc,hRgn)
SetTextColor(hdc,TextFore)
DrawText (hdc, szStr, lstrlen(szStr), @Rect, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
SelectClipRgn(hdc,NULL)
DeleteObject(hRgn)
DeleteObject(hBrush1)
DeleteObject(hBrush2)
EndPaint(hwnd,@ps)
'Return 0
End Select
Return CallWindowProc (cast(WNDPROC,PrevWndProcProzess), hwnd, message, wParam, lParam)
End Function