 |
Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
|
| Vorheriges Thema anzeigen :: Nächstes Thema anzeigen |
| Autor |
Nachricht |
csde_rats
Anmeldungsdatum: 07.01.2007
Beiträge: 2292
Wohnort: Zwischen Sessel und Tastatur
|
 Verfasst am: 12.08.2007, 23:30 Titel: [GELÖST]geSubClasste ProgressBar will nicht.... |
 |
|
Hallo.
Ich habe mal versucht das Tutorial von hier nach FB zu übersetzten.
Leider passiert bei Tastendruck nichts...
| Code: | #include "windows.bi"
#include once "win/commctrl.bi"
dim shared as integer progress
dim shared PrevWndProcProzess as integer
Declare Function WndProc ( Byval hWnd As HWND, Byval uMsg As UINT, _
Byval wParam As WPARAM, Byval lParam As LPARAM ) As Integer
declare function ProgressWndProc (hwnd as HWND, message as UINT, wParam as WPARAM, lParam as LPARAM) as LRESULT
Dim Shared hInstance As HINSTANCE
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, @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
print "1 " & progress
If ipos=0 Or ipos=99 Then a=-a
End If
Return 0
Case WM_DESTROY
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 (hwnd as HWND, message as UINT, wParam as WPARAM, lParam as LPARAM) as LRESULT
static RECT as Rect
dim as HDC hdc
dim as PAINTSTRUCT ps
static szStr as ZString * 50
dim as HRGN hRgn
dim as COLORREF BarFore = RGB(0,128,0) ' Farbe Fortschritts Anzeige
dim as COLORREF BarBk = RGB(255,0,0) ' Hintergrund Farbe
dim as COLORREF TextFore = RGB(0,0,0) ' Text Farbe Auf Hintergrund
dim as COLORREF TextBk = RGB(255,255,255) ' Text Farbe Auf Fortschritts Anzeige
dim as HBRUSH hBrush1,hBrush2
select case message
case WM_LBUTTONDOWN
case WM_PAINT
print "2 " & progress
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,cast(HBRUSH,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,cast(HBRUSH,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)
end function
|
_________________
If hilfreicher_Beitrag then klick(location.here)
Klick
Zuletzt bearbeitet von csde_rats am 14.08.2007, 14:38, insgesamt einmal bearbeitet |
|
| Nach oben |
|
 |
Jojo
alter Rang
Anmeldungsdatum: 12.02.2005
Beiträge: 9736
Wohnort: Neben der Festplatte
|
| Verfasst am: 12.08.2007, 23:32 Titel: |
|
|
Ich weiß ja nicht, aber könnte es sein, dass in FB irgendwie Funktionen anders im Speicher gehalten werden und daher das Subclassing nicht greift?
_________________
» Die Mathematik wurde geschaffen, um Probleme zu lösen, die es nicht gäbe, wenn die Mathematik nicht erschaffen worden wäre.
 |
|
| Nach oben |
|
|
csde_rats
Anmeldungsdatum: 07.01.2007
Beiträge: 2292
Wohnort: Zwischen Sessel und Tastatur
|
| Verfasst am: 12.08.2007, 23:47 Titel: |
|
|
Hmm
Die Konsolenausgabe zeigt, dass die Sub schon aufgerufen wird... werte stimmen alle... es wird nur net rumgepinselt => die progbar bleibt einfach schwarz...
_________________
If hilfreicher_Beitrag then klick(location.here)
Klick |
|
| Nach oben |
|
|
volta
Anmeldungsdatum: 04.05.2005
Beiträge: 1876
Wohnort: D59192
|
| Verfasst am: 13.08.2007, 20:21 Titel: |
|
|
hmm, das läuft unter ME 
Ich hab ein paar Zeilen geändert (es lief auch ohne die Änderungen).
| Code: | #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
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
Dim As COLORREF BarFore = Rgb(0,128,0) ' Farbe Fortschritts Anzeige
Dim As COLORREF BarBk = Rgb(0,0,255) ' Hintergrund Farbe (in Win = BGR)
Dim As COLORREF TextFore = Rgb(0,0,0) ' Text Farbe Auf Hintergrund
Dim As COLORREF TextBk = Rgb(255,255,255) ' 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)
'return DefWindowProc(hwnd, message, wParam, lParam)'nur das erste Return wird ausgeführt!
End Function
|
Warum das (unter XP?) bei dir Fehler macht ist mir nicht klar.
_________________
Warnung an Choleriker:
Dieser Beitrag kann Spuren von Ironie & Sarkasmus enthalten.
Zu Risiken & Nebenwirkungen fragen Sie Ihren Therapeuten oder Psychiater. |
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 13.08.2007, 21:00 Titel: |
|
|
Bei mir bleibt es leider auch schwarz... da tut sich nichts
(WinXP Pro SP2)
_________________
 |
|
| Nach oben |
|
|
csde_rats
Anmeldungsdatum: 07.01.2007
Beiträge: 2292
Wohnort: Zwischen Sessel und Tastatur
|
|
| Nach oben |
|
|
volta
Anmeldungsdatum: 04.05.2005
Beiträge: 1876
Wohnort: D59192
|
| Verfasst am: 13.08.2007, 22:47 Titel: |
|
|
nehm mal die
| Code: | | InitCommonControls() 'initialisiere common controls |
aus der WndProc heraus und setze sie in die Main
| Code: | ...
Dim appName As String
appName = "ProgressBarDemo"
InitCommonControls() 'initialisiere common controls
With wcls
.style = CS_HREDRAW Or CS_VREDRAW
... |
mangels XP kann ich es jetzt nicht testen.
_________________
Warnung an Choleriker:
Dieser Beitrag kann Spuren von Ironie & Sarkasmus enthalten.
Zu Risiken & Nebenwirkungen fragen Sie Ihren Therapeuten oder Psychiater. |
|
| Nach oben |
|
|
ytwinky
Anmeldungsdatum: 28.05.2005
Beiträge: 2624
Wohnort: Machteburch
|
| Verfasst am: 13.08.2007, 23:14 Titel: |
|
|
WinXP Pro, SP2: Vorher nüscht..
nach Umbau der Zeile: nüscht..
Ich habe dann mal diverse Tasten betätigt und siehe da:
Wenn ich die Bild rauf/Bild runter-Taste lange gedrückt halte, blitzt es kurz auf)
Soweit meine 'Erfolgsmeldung' 
Gruß
ytwinky
_________________
| v1ctor hat Folgendes geschrieben: | | Yeah, i like INPUT$(n) as much as PRINT USING.. |
..also ungefähr so, wie ich GOTO.. |
|
| Nach oben |
|
|
csde_rats
Anmeldungsdatum: 07.01.2007
Beiträge: 2292
Wohnort: Zwischen Sessel und Tastatur
|
|
| Nach oben |
|
|
The_Muh
aka Mark Aroni
Anmeldungsdatum: 11.09.2006
Beiträge: 718
|
| Verfasst am: 14.08.2007, 02:22 Titel: |
|
|
Bei mir tut sich ebenfalls nicht viel... ich hab nur ein fenster da bis auf einen schwarzen balken komplett leer ist... nur oben in der titelleiste steht was
_________________
// nicht mehr aktiv // |
|
| Nach oben |
|
|
csde_rats
Anmeldungsdatum: 07.01.2007
Beiträge: 2292
Wohnort: Zwischen Sessel und Tastatur
|
|
| Nach oben |
|
|
Elektronix
Anmeldungsdatum: 29.06.2006
Beiträge: 742
|
| Verfasst am: 14.08.2007, 14:20 Titel: |
|
|
Habs mal getestet und lief nicht. Die ProgressBar erscheint zwar, aber beim Drücken der <- oder ->-Taste passierte gar nichts.
Ich weiß jetzt nicht, wie es bei FB ist, aber in C darf man nicht zwei WM_-Nachrichten in einem Case-Zweig auswerten. Man schreibt dann
| Code: |
Case WM_PAINT
Case WM_LBUTTONDOWN
Funktion
|
Eigentlich macht es auch keinen Sinn, daß Du WM_PAINT und WM_LBUTTONDOWN gleichzeitig auswertest, weil Du vermutlich unter WM_LBUTTONDOWN gar nicht zeichnen, sondern nur den Status berechnen willst.
Zuletzt bearbeitet von Elektronix am 14.08.2007, 14:29, insgesamt einmal bearbeitet |
|
| Nach oben |
|
|
csde_rats
Anmeldungsdatum: 07.01.2007
Beiträge: 2292
Wohnort: Zwischen Sessel und Tastatur
|
| Verfasst am: 14.08.2007, 14:26 Titel: |
|
|
Ist doch drin?
| Code: | 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 |
| Code: | | Return CallWindowProc (cast(WNDPROC,PrevWndProcProzess), hwnd, message, wParam, lParam) |
???
_________________
If hilfreicher_Beitrag then klick(location.here)
Klick |
|
| Nach oben |
|
|
Elektronix
Anmeldungsdatum: 29.06.2006
Beiträge: 742
|
| Verfasst am: 14.08.2007, 14:30 Titel: |
|
|
| Posting hat sich wiedermal überkreuzt. Du bist zu schnell! |
|
| Nach oben |
|
|
csde_rats
Anmeldungsdatum: 07.01.2007
Beiträge: 2292
Wohnort: Zwischen Sessel und Tastatur
|
| Verfasst am: 14.08.2007, 14:38 Titel: |
|
|
Bin ich dämlich  !!!
FreeBasic's RGB != WinAPI's RGB!!!!
Man muss statt | Code: | Dim As COLORREF BarFore = RGB(0,128,0) ' Farbe Fortschritts Anzeige
Dim As COLORREF BarBk = RGB(0,0,255) ' Hintergrund Farbe (in Win = BGR)
Dim As COLORREF TextFore = RGB(0,0,0) ' Text Farbe Auf Hintergrund
Dim As COLORREF TextBk = RGB(255,255,255) ' Text Farbe Auf Fortschritts Anzeige |
das hier schreiben | Code: | 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 |
http://www.freebasic-portal.de/index.php?s=fbporticula&mode=show&id=101
Editiert durch Moderator: Fehlerhaften Code-Tag korrigiert. (Sebastian)
_________________
If hilfreicher_Beitrag then klick(location.here)
Klick |
|
| Nach oben |
|
|
Elektronix
Anmeldungsdatum: 29.06.2006
Beiträge: 742
|
| Verfasst am: 14.08.2007, 14:50 Titel: |
|
|
Jau, jetzt stimmts!  |
|
| Nach oben |
|
|
volta
Anmeldungsdatum: 04.05.2005
Beiträge: 1876
Wohnort: D59192
|
|
| Nach oben |
|
|
|
|
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
|
|
FAQ
Suchen
Mitgliederliste
Benutzergruppen
Registrieren
Profil
Einloggen, um private Nachrichten zu lesen
Login
