Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
ProgBarSubClass funzen tut..
| Uploader: |  csde_rats |
| Datum/Zeit: | 14.08.2007 15:36:42 |
#INCLUDE "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
InitCommonControls() 'initialisiere COMMON controls
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 = "ProgressBarSubclassDemo"
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 = getStockObject(WHITE_BRUSH) '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
'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
InvalidateRect (hWnd,null, true)
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
Dim As COLORREF BarFore = BGR(0,128,0) ' Farbe Fortschritts Anzeige
Dim As COLORREF BarBk = BGR(0,0,255) ' Hintergrund Farbe (in Win = BGR)
Dim As COLORREF TextFore = BGR(0,0,0) ' Text Farbe Auf Hintergrund
Dim As COLORREF TextBk = BGR(255,255,255) ' Text Farbe Auf Fortschritts Anzeige
SELECT CASE message
case PBM_SETPOS
progress+=1
print "huhu^^" & progress
InvalidateRect(hwnd,null,false)
Case WM_PAINT
PRINT "ICH BIN DAAA!!!!einseinself!!"
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, len(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)
'return DefWindowProc(hwnd, message, wParam, lParam)'nur das erste Return wird ausgeführt!
End Function