mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-11-03 12:59:40 +01:00
added Timer patch from Vincent Snijders
git-svn-id: trunk@3660 -
This commit is contained in:
mattias
parent
1f332a6853
commit
0ea27644ac
@ -26,7 +26,7 @@ unit CustomTimer;
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LCLLinux, LCLType, LMessages, VCLGlobals;
|
||||
Classes, SysUtils, LCLType, LMessages, VCLGlobals;
|
||||
|
||||
|
||||
type
|
||||
@ -39,7 +39,7 @@ type
|
||||
FTimerHandle : integer;
|
||||
FOnTimer : TNotifyEvent;
|
||||
FEnabled : Boolean;
|
||||
procedure Timer (var msg); message LM_Timer;
|
||||
procedure Timer;
|
||||
protected
|
||||
procedure SetEnabled(Value: Boolean); virtual;
|
||||
procedure SetInterval(Value: Cardinal); virtual;
|
||||
@ -62,30 +62,13 @@ type
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
InterfaceBase;
|
||||
|
||||
const
|
||||
cIdNoTimer = -1; { timer ID for an invalid timer }
|
||||
SNoTimers = 'No timers available';
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
Method: TimerCBProc
|
||||
Params: handle - handle (self) of the TCustomTimer instance
|
||||
message - should be LM_Timer, currently unused (s. Win32 API)
|
||||
IDEvent - currently unused (s. Win32 API)
|
||||
Time - currently unused (s. Win32 API)
|
||||
Returns: Nothing
|
||||
|
||||
Callback for a timer which will call TCustomTimer.Timer. This proc will be used
|
||||
if the InterfaceObject uses a callback instead of delivering a LM_Timer
|
||||
message.
|
||||
------------------------------------------------------------------------------}
|
||||
procedure TimerCBProc(Handle: HWND; message : cardinal; IDEvent: Integer;
|
||||
Time: Cardinal);
|
||||
begin
|
||||
if (Handle<>0) then
|
||||
TCustomTimer(Handle).Timer (message);
|
||||
end;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
Method: TCustomTimer.Create
|
||||
Params: AOwner: the owner of the class
|
||||
@ -126,7 +109,7 @@ end;
|
||||
procedure TCustomTimer.KillTimer;
|
||||
begin
|
||||
if FTimerHandle <> cIdNoTimer then begin
|
||||
LCLLinux.KillTimer (integer(Self), 1);
|
||||
InterfaceObject.DestroyTimer(FTimerHandle);
|
||||
FTimerHandle := cIdNoTimer;
|
||||
if Assigned(OnStopTimer) then OnStopTimer(Self);
|
||||
end;
|
||||
@ -151,8 +134,7 @@ begin
|
||||
if (FEnabled) and (FInterval > 0)
|
||||
and (([csDesigning,csLoading]*ComponentState=[]))
|
||||
and Assigned (FOnTimer) then begin
|
||||
FTimerHandle := LCLLinux.SetTimer(Integer(Self), 1,
|
||||
FInterval, @TimerCBProc);
|
||||
FTimerHandle := InterfaceObject.CreateTimer(FInterval, @Timer);
|
||||
if FTimerHandle=0 then begin
|
||||
FTimerHandle:=cIdNoTimer;
|
||||
raise EOutOfResources.Create(SNoTimers);
|
||||
@ -163,12 +145,11 @@ end;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
Method: TCustomTimer.Timer
|
||||
Params: msg - message to be dispatched
|
||||
Returns: Nothing
|
||||
|
||||
Is called when the timer has expired and calls users OnTimer function.
|
||||
------------------------------------------------------------------------------}
|
||||
procedure TCustomTimer.Timer (var msg);
|
||||
procedure TCustomTimer.Timer;
|
||||
begin
|
||||
if (FEnabled) and (FInterval > 0) then
|
||||
DoOnTimer;
|
||||
|
||||
@ -51,7 +51,7 @@ End;
|
||||
Handles the messages sent to the current window by Windows or other
|
||||
applications
|
||||
------------------------------------------------------------------------------}
|
||||
Function WindowProc(Window: HWnd; Msg: UInt; WParam: WParam; LParam: LParam): LResult;
|
||||
Function WindowProc(Window: HWnd; Msg: UInt; WParam: WParam; LParam: LParam): LResult; stdcall;
|
||||
Var
|
||||
C: Cardinal;
|
||||
List: TMsgArray;
|
||||
@ -71,7 +71,7 @@ Begin
|
||||
Assert(False, 'Trace:WindowProc - Getting Callback Object');
|
||||
|
||||
Assert(False, 'Trace:WindowProc - Checking Proc');
|
||||
Assert(False, Format('Trace:WindowProc - Window Value: $%S; Msg Value: %S; WParam: $%S; LParam: $%S', [IntToHex(Window, 4), WM_To_String(Msg), IntToHex(WParam, 4), IntToHex(LParam, 4)]));
|
||||
Assert(False, Format('Trace:WindowProc - Window Value: $%S-%d; Msg Value: %S; WParam: $%S; LParam: $%S', [IntToHex(Window, 4), Window, WM_To_String(Msg), IntToHex(WParam, 4), IntToHex(LParam, 4)]));
|
||||
|
||||
Case Msg Of
|
||||
LM_MONTHCHANGED..LM_DAYCHANGED:
|
||||
@ -453,14 +453,33 @@ Begin
|
||||
DeliverMessage(OwnerObject, LMessage);
|
||||
{$ENDIF VER1_1}
|
||||
|
||||
Writeln();
|
||||
|
||||
If WinProcess Then
|
||||
Result := DefWindowProc(Window, Msg, WParam, LParam);
|
||||
|
||||
Assert(False, 'Trace:WindowProc - Exit');
|
||||
End;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
Function: TimerWindowProc
|
||||
Params: Window - The window that receives a message for the timer window
|
||||
Msg - The message received
|
||||
WParam - Word parameter
|
||||
LParam - Long-integer parameter
|
||||
Returns: 0 if Msg is handled; non-zero long-integer result otherwise
|
||||
|
||||
Handles the messages sent to the timer window by Windows
|
||||
------------------------------------------------------------------------------}
|
||||
FUNCTION TimerWindowProc(window_hwnd : hwnd; msg : DWORD; wParam : WPARAM; lParam : LPARAM) : LRESULT;
|
||||
Var
|
||||
TimerInfo: PWin32TimerInfo;
|
||||
begin
|
||||
if (msg = WM_TIMER) and (WParam<>0) then begin
|
||||
TimerInfo := PWin32TimerInfo(WParam);
|
||||
TimerInfo^.TimerFunc;
|
||||
Result := 0;
|
||||
end else Result := DefWindowProc(window_hwnd, Msg, WParam, LParam);
|
||||
end;
|
||||
|
||||
{$IFDEF ASSERT_IS_ON}
|
||||
{$UNDEF ASSERT_IS_ON}
|
||||
{$C-}
|
||||
@ -468,6 +487,9 @@ End;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.17 2002/11/23 13:48:48 mattias
|
||||
added Timer patch from Vincent Snijders
|
||||
|
||||
Revision 1.16 2002/11/15 23:43:54 mattias
|
||||
applied patch from Karl Brandt
|
||||
|
||||
|
||||
@ -31,7 +31,7 @@ Unit Win32Def;
|
||||
Interface
|
||||
|
||||
Uses
|
||||
Windows, VCLGlobals, Classes;
|
||||
Windows, VCLGlobals, Classes, LCLType;
|
||||
|
||||
Type
|
||||
TGDIType = (gdiBitmap, gdiBrush, gdiFont, gdiPen, gdiRegion);
|
||||
@ -113,13 +113,28 @@ Type
|
||||
UserData: Integer;
|
||||
End;
|
||||
|
||||
Implementation
|
||||
type
|
||||
{ lazarus win32 Interface definition for additional timer data needed to find the callback}
|
||||
PWin32TimerInfo = ^TWin32Timerinfo;
|
||||
TWin32TimerInfo = record
|
||||
TimerHandle: uint; // the windows timer ID for this timer
|
||||
TimerFunc : TFNTimerProc; // owner function to handle timer
|
||||
end;
|
||||
|
||||
var
|
||||
// FTimerData contains the currently running timers
|
||||
FTimerData : TList; // list of PWin32Timerinfo
|
||||
|
||||
Implementation
|
||||
|
||||
End.
|
||||
|
||||
{ =============================================================================
|
||||
|
||||
$Log$
|
||||
Revision 1.5 2002/11/23 13:48:48 mattias
|
||||
added Timer patch from Vincent Snijders
|
||||
|
||||
Revision 1.4 2002/05/10 07:43:48 lazarus
|
||||
MG: updated licenses
|
||||
|
||||
|
||||
@ -1361,20 +1361,6 @@ begin
|
||||
Result := Windows.IntersectClipRect(DC, Left, Top, Right, Bottom);
|
||||
end;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
Method: KillTimer
|
||||
Params: HWnd - handle of window that installed timer
|
||||
UIDEvent - timer identifier
|
||||
Returns: if the function succeeds
|
||||
|
||||
Destroys the specified timer.
|
||||
------------------------------------------------------------------------------}
|
||||
Function TWin32Object.KillTimer (HWnd: HWND; UIDEvent: cardinal): Boolean;
|
||||
Begin
|
||||
Assert(False, 'Trace:removing timer!!!');
|
||||
Result := Windows.KillTimer(HWnd, UIDEvent);
|
||||
End;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
Method: LineTo
|
||||
Params: DC - device context handle
|
||||
@ -2029,23 +2015,6 @@ Begin
|
||||
Assert(False, Format('Trace:< [TWin32Object.SetTextColor] DC: 0x%x Color: %8x --> %8x', [Integer(DC), Color, Result]));
|
||||
End;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
Method: SetTimer
|
||||
Params: HWnd - handle of window for timer messages
|
||||
NIDEvent - timer identifier
|
||||
UElapse - time-out value
|
||||
LPTimerFunc - address of timer procedure
|
||||
Returns: identify of the new timer
|
||||
|
||||
Creates a timer with the specified time-out value.
|
||||
|
||||
Design: Currently only a callback to the TTimer class is implemented.
|
||||
------------------------------------------------------------------------------}
|
||||
Function TWin32Object.SetTimer(HWnd: HWND; NIDEvent, UElapse: Integer; LPTimerFunc: TFNTimerProc): Integer;
|
||||
Begin
|
||||
Result := Windows.SetTimer(HWnd, NIDEvent, UElapse, TIMERPROC(LPTimerFunc));
|
||||
End;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
Procedure: SetWindowLong
|
||||
Params: Handle - handle of window
|
||||
@ -2306,6 +2275,9 @@ end;
|
||||
{ =============================================================================
|
||||
|
||||
$Log$
|
||||
Revision 1.22 2002/11/23 13:48:49 mattias
|
||||
added Timer patch from Vincent Snijders
|
||||
|
||||
Revision 1.21 2002/10/27 20:05:08 lazarus
|
||||
AJ : Patch from Martin Smat fixing Pixmap loading on all Color Depths
|
||||
|
||||
|
||||
@ -100,15 +100,13 @@ Function GetTextMetrics(DC: HDC; Var TM: TTextMetric): Boolean; Override;
|
||||
Function GetWindowLong(Handle: HWND; Int: Integer): LongInt; Override;
|
||||
Function GetWindowOrgEx(DC: HDC; Var P: TPoint): Integer; Override;
|
||||
Function GetWindowRect(Handle: HWND; Var Rect: TRect): Integer; Override;
|
||||
Function GetWindowSize(Handle : hwnd; var Width, Height: integer): boolean;
|
||||
Function GetWindowSize(Handle : hwnd; var Width, Height: integer): boolean; override;
|
||||
|
||||
Function HideCaret(HWnd: HWND): Boolean; Override;
|
||||
|
||||
function IntersectClipRect(dc: hdc; Left, Top, Right, Bottom: Integer): Integer; override;
|
||||
Function InvalidateRect(AHandle: HWND; Rect: PRect; BErase: Boolean): Boolean; Override;
|
||||
|
||||
Function KillTimer (HWnd: HWND; UIDEvent: Cardinal): Boolean; Override;
|
||||
|
||||
Function LineTo(DC: HDC; X, Y: Integer): Boolean; Override;
|
||||
|
||||
Function MaskBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP; XMask, YMask: Integer; Rop: DWORD): Boolean; Override;
|
||||
@ -150,7 +148,6 @@ Function SetScrollInfo(Handle: HWND; SBStyle: Integer; ScrollInfo: TScrollInfo;
|
||||
Function SetSysColors(CElements: Integer; Const LPAElements; Const LPARgbValues): Boolean; Override;
|
||||
Function SetTextCharacterExtra(_HDC: HDC; NCharExtra: Integer): Integer; Override;
|
||||
Function SetTextColor(DC: HDC; Color: TColorRef): TColorRef; Override;
|
||||
Function SetTimer(HWnd: HWND; NIDEvent, uElapse: Integer; LPTimerFunc: TFNTimerProc): Integer; Override;
|
||||
Function SetWindowLong(Handle: HWND; Idx: Integer; NewLong: LongInt): LongInt; Override;
|
||||
Function SetWindowOrgEx(DC: HDC; NewX, NewY: Integer; Var OldPoint: TPoint): Boolean; Override;
|
||||
Function SetWindowPos(HWnd: HWND; HWndInsertAfter: HWND; X, Y, CX, CY: Integer; UFlags: UINT): Boolean; Override;
|
||||
@ -173,6 +170,9 @@ Procedure DeleteCriticalSection(var CritSection: TCriticalSection); Override;
|
||||
{ =============================================================================
|
||||
|
||||
$Log$
|
||||
Revision 1.16 2002/11/23 13:48:49 mattias
|
||||
added Timer patch from Vincent Snijders
|
||||
|
||||
Revision 1.15 2002/10/01 10:16:34 lazarus
|
||||
MG: removed last clientrectbugfix switches
|
||||
|
||||
|
||||
@ -1562,8 +1562,7 @@ type
|
||||
//------------------------------------------------------------------------------
|
||||
// prototype for timer callback
|
||||
type
|
||||
TFNTimerProc = procedure(Handle: HWND; Message : cardinal; IDEvent: Integer;
|
||||
Time: Cardinal);
|
||||
TFNTimerProc = procedure of object;
|
||||
|
||||
|
||||
//------------------------------------------------------------------------------
|
||||
@ -1682,6 +1681,9 @@ end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.26 2002/11/23 13:48:43 mattias
|
||||
added Timer patch from Vincent Snijders
|
||||
|
||||
Revision 1.25 2002/11/22 09:59:29 mattias
|
||||
removed duplicate PPoint
|
||||
|
||||
|
||||
@ -869,7 +869,8 @@ begin
|
||||
LM_BRINGTOFRONT : Result :='LM_BRINGTOFRONT ';
|
||||
LM_CB_GETCOUNT : Result :='LM_CB_GETCOUNT ';
|
||||
LM_SETSHORTCUT : Result :='LM_SETSHORTCUT ';
|
||||
|
||||
LM_SETGEOMETRY : Result :='LM_SETGEOMETRY ';
|
||||
|
||||
// additional for TNoteBook
|
||||
LM_NB_UpdateTab : Result := 'LM_NB_UpdateTab';
|
||||
else
|
||||
@ -884,6 +885,9 @@ end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.40 2002/11/23 13:48:43 mattias
|
||||
added Timer patch from Vincent Snijders
|
||||
|
||||
Revision 1.39 2002/11/21 18:49:52 mattias
|
||||
started OnMouseEnter and OnMouseLeave
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user