开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Delphi控件源码 > 查看源码
MMHTimer.pas
资源名称：qqdelphiprog.rar　[点击查看]
上传用户：hylc_2004
上传日期：2014-01-23
资源大小：46800k
文件大小：14k
源码类别：

Delphi控件源码

开发平台：

Delphi

MMHTimer.pas：源码内容
  1. {========================================================================}
  2. {=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
  3. {========================================================================}
  4. {=                          All Rights Reserved                         =}
  5. {========================================================================}
  6. {=  D 01099 Dresden             = Fax.: +49(0)351-8037944               =}
  7. {=  Loewenstr.7a                = info@swiftsoft.de                     =}
  8. {========================================================================}
  9. {=  Actual versions on http://www.swiftsoft.de/index.html               =}
  10. {========================================================================}
  11. {=  This code is for reference purposes only and may not be copied or   =}
  12. {=  distributed in any format electronic or otherwise except one copy   =}
  13. {=  for backup purposes.                                                =}
  14. {=                                                                      =}
  15. {=  No Delphi Component Kit or Component individually or in a collection=}
  16. {=  subclassed or otherwise from the code in this unit, or associated   =}
  17. {=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
  18. {=  without express permission from SwiftSoft.                          =}
  19. {=                                                                      =}
  20. {=  For more licence informations please refer to the associated        =}
  21. {=  HelpFile.                                                           =}
  22. {========================================================================}
  23. {=  $Date: 07.10.98 - 21:01:39 $                                        =}
  24. {========================================================================}
  25. unit MMHTimer;
  27. {$I COMPILER.INC}
  29. {$C FIXED PRELOAD PERMANENT}
  31. {.$DEFINE _MMDEBUG}
  33. interface
  35. uses
  36. {$IFDEF WIN32}
  37.   Windows,
  38. {$ELSE}
  39.   WinTypes,
  40.   WinProcs,
  41. {$ENDIF}
  42.   SysUtils,
  43.   Messages,
  44.   Classes,
  45.   Graphics,
  46.   Controls,
  47.   Forms,
  48.   Dialogs,
  49.   MMSystem,
  50.   MMUtils,
  51.   MMString,
  52.   MMObj;
  54. type
  55.   EMMHiTimerError = class(Exception);
  57.   {$IFDEF WIN32}
  58.   TMMHiTimer      = class;
  60.   {-- TMMTimerThread ---------------------------------------------------}
  61.   TMMTimerThread  = class(TMMThreadEx)
  62.   private
  63.      HiTimer    : TMMHiTimer;
  64.      Terminating: Boolean;
  65.      procedure Execute; override;
  66.   end;
  67.   {$ENDIF}
  69.   {-- TMMHiTimer -------------------------------------------------------}
  70.   TMMHiTimer = class(TMMNonVisualComponent)
  71.   private
  72.   {$IFDEF WIN32}
  73.     FPriority         : TThreadPriority;
  74.     FTimerThread      : TMMTimerThread;
  75.     FTimerEvent       : THandle;
  76.     FGeneralEvent     : THandle;
  77.     FSynchronize      : Boolean;
  78.     FThreadCreated    : Boolean;
  79.     FWaitForTerminate : Boolean;
  80.     FMainThreadWaiting: Boolean;
  81.   {$ENDIF}
  82.     FEnabled          : Boolean;
  83.     FInterval         : integer;
  84.     FMessageCount     : integer;
  85.     FHandle           : THandle;
  86.     FTimerID          : integer;
  87.     FCallbackMode     : TMMCBMode;
  89.     FOnTimer          : TNotifyEvent;
  91.     procedure SetCallBackMode(aValue: TMMCBMode);
  92.     procedure SetEnabled(aValue: Boolean);
  93.     procedure SetInterval(aValue: integer);
  94.     procedure SetOnTimer(aValue: TNotifyEvent);
  95.     function  GetTimerCaps: TTimeCaps;
  96.     procedure UpdateTimer;
  97.     procedure WndProc(var Msg: TMessage);
  98.     {$IFDEF WIN32}
  99.     procedure SetPriority(aValue: TThreadPriority);
  100.     {$ENDIF}
  101.     procedure DoTimer;
  103.   protected
  104.     procedure Timer; dynamic;
  106.   public
  107.     constructor Create(AOwner:TComponent); override;
  108.     destructor  Destroy; override;
  109.     {$IFDEF WIN32}
  110.     procedure SynchronizeVCL(VCLProc: TThreadMethod);
  111.     {$ENDIF}
  113.     procedure ChangeDesigning(aValue: Boolean); override;
  115.   published
  116.     property CallBackMode: TMMCBMode read FCallBackMode write SetCallBackMode default cmWindow;
  117.     property Enabled: Boolean read FEnabled write SetEnabled default True;
  118.     property Interval: integer read FInterval write SetInterval default 1000;
  119.     property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
  120.     {$IFDEF WIN32}
  121.     property Priority: TThreadPriority read FPriority write SetPriority default tpNormal;
  122.     property Synchronize: Boolean read FSynchronize write FSynchronize default True;
  123.     property WaitForTerminate: Boolean read FWaitForTerminate write FWaitForTerminate default False;
  124.     {$ENDIF}
  125.   end;
  127. implementation
  129. Uses
  130.     Consts
  131.     {$IFDEF _MMDEBUG}
  132.     ,MMDebug
  133.     {$ENDIF};
  135. {$IFDEF _MMDEBUG}
  136. {-------------------------------------------------------------------------}
  137. procedure Debug(Level: integer; s: String);
  138. begin
  139.    if (s <> ' ') then s := 'HiTimer: '+s;
  140.    DB_WriteStrLn(Level,s);
  141. end;
  142. {$ENDIF}
  144. {-- TimeCallBack -------------------------------------------------------}
  145. procedure TimeCallBack(uTimerID, uMessage: UINT; dwUser, dw1, dw2: Longint);
  146. export;{$IFDEF WIN32}stdcall;{$ENDIF}
  147. begin
  148.    if (dwUser <> 0) then
  149.    with TMMHiTimer(dwUser) do
  150.    {$IFDEF WIN32}
  151.    try
  152.    {$ELSE}
  153.    begin
  154.    {$ENDIF}
  155.       case FCallBackMode of
  156.          cmWindow  : if (FMessageCount < 10) then
  157.                      begin
  158.                         inc(FMessageCount);
  159.                         PostMessage(FHandle,MM_TIMER,uTimerID,0);
  160.                      end;
  161.          cmCallBack: DoTimer;
  162.          {$IFDEF WIN32}
  163.          cmThread  : SetEvent(FTimerEvent);
  164.          {$ENDIF}
  165.       end;
  167.    {$IFDEF WIN32}
  168.    except
  169.       Application.HandleException(nil);
  170.    {$ENDIF}
  171.    end;
  172. end;
  174. {$IFDEF WIN32}
  175. {== TMMTimerThread =====================================================}
  176. procedure TMMTimerThread.Execute;
  177. var
  178.    h: THandle;
  179. begin
  180.    if (HiTimer <> nil) then
  181.    try
  182.       Priority := HiTimer.FPriority;
  184.       { Ready to go, set the general event }
  185.       SetEvent(HiTimer.FGeneralEvent);
  187.       {$IFDEF _MMDEBUG}
  188.       Debug(0,'Timer ThreadProc started...');
  189.       {$ENDIF}
  191.       while not Terminated and not Terminating and (HiTimer <> nil) do
  192.       begin
  193.          WaitForSingleObject(HiTimer.FTimerEvent,INFINITE);
  194.          if not Terminated and not Terminating and (HiTimer <> nil) then
  195.             HiTimer.DoTimer;
  196.       end;
  198.       if (HiTimer <> nil) then
  199.       begin
  200.          h := HiTimer.FGeneralEvent;
  201.          HiTimer.FTimerThread := nil;
  202.          HiTimer := nil;
  203.          SetEvent(h);
  204.       end;
  206.    except
  207.       Application.HandleException(Self);
  208.    end;
  210.    {$IFDEF _MMDEBUG}
  211.    Debug(0,'Timer ThreadProc terminated...');
  212.    {$ENDIF}
  213. end;
  214. {$ENDIF}
  216. {== TMMHiTimer =========================================================}
  217. procedure TMMHiTimer.WndProc(var Msg: TMessage);
  218. begin
  219.    with Msg do
  220.    if (Msg = MM_TIMER) and (wParam = FTimerID) then
  221.    try
  222.       try
  223.          Timer;
  224.       finally
  225.          dec(FMessageCount);
  226.       end;
  227.    except
  228.       Application.HandleException(Self);
  229.    end
  230.    else Result := DefWindowProc(FHandle, Msg, wParam, lParam);
  231. end;
  233. {-- TMMHiTimer -----------------------------------------------------------}
  234. constructor TMMHiTimer.Create(aOwner: TComponent);
  235. begin
  236.    inherited Create(aOwner);
  238.    FEnabled := True;
  239.    FInterval := 1000;
  240.    FTimerID  := 0;
  241.    FHandle := 0;
  242.    FMessageCount := 0;
  243.    FCallBackMode := cmWindow;
  244. {$IFDEF WIN32}
  245.    FPriority := tpNormal;
  246.    FSynchronize := True;
  247.    FThreadCreated := False;
  248.    FWaitForTerminate := False;
  249.    FMainThreadWaiting := False;
  250. {$ENDIF}
  251.    ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
  252.    if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
  253. end;
  255. {-- TMMHiTimer -----------------------------------------------------------}
  256. destructor TMMHiTimer.Destroy;
  257. begin
  258.    FOnTimer := nil;
  259.    FEnabled := False;
  260.    UpdateTimer;
  262.    inherited destroy;
  263. end;
  265. {-- TMMHiTimer -----------------------------------------------------------}
  266. procedure TMMHiTimer.ChangeDesigning(aValue: Boolean);
  267. begin
  268.    inherited;
  270.    UpdateTimer;
  271. end;
  273. {-- TMMHiTimer -----------------------------------------------------------}
  274. Procedure TMMHiTimer.SetCallBackMode(aValue: TMMCBMode);
  275. begin
  276.    if (aValue <> FCallBackMode) then
  277.    begin
  278.       if (aValue = cmCallBack) then
  279.       begin
  280.          {$IFDEF WIN32}
  281.          if not _WIN95_ then
  282.          {$ENDIF}
  283.          begin
  284.             Application.MessageBox('"CallBacks" are called at interrupt time !'#10#13+
  285.                                    'This is currently only supported under Windows 95',
  286.                                    'TMMHiTimer', MB_OK);
  287.             exit;
  288.          end;
  289.       end;
  290.       FCallBackMode := aValue;
  291.       UpdateTimer;
  292.    end;
  293. end;
  295. {-- TMMHiTimer -----------------------------------------------------------}
  296. procedure TMMHiTimer.SetEnabled(aValue: Boolean);
  297. begin
  298.    if (aValue <> FEnabled) then
  299.    begin
  300.      FEnabled := aValue;
  301.      UpdateTimer;
  302.    end;
  303.    {$IFDEF WIN32}
  304.    {$IFDEF TRIAL}
  305.    {$DEFINE _HACK2}
  306.    {$I MMHACK.INC}
  307.    {$ENDIF}
  308.    {$ENDIF}
  309. end;
  311. {-- TMMHiTimer -----------------------------------------------------------}
  312. procedure TMMHiTimer.SetInterval(aValue: integer);
  313. begin
  314.    if (aValue <> FInterval) then
  315.    begin
  316.       FInterval := aValue;
  317.       UpdateTimer;
  318.    end;
  319. end;
  321. {-- TMMHiTimer -----------------------------------------------------------}
  322. procedure TMMHiTimer.SetOnTimer(aValue: TNotifyEvent);
  323. begin
  324.    FOnTimer := aValue;
  325.    UpdateTimer;
  326. end;
  328. {-- TMMHiTimer -----------------------------------------------------------}
  329. function TMMHiTimer.GetTimerCaps: TTimeCaps;
  330. var
  331.    Temp:TTimeCaps;
  333. begin
  334.    TimeGetDevCaps(@Temp, sizeof(Temp));
  335.    Result := Temp;
  336.    {$IFDEF WIN32}
  337.    {$IFDEF TRIAL}
  338.    {$DEFINE _HACK2}
  339.    {$I MMHACK.INC}
  340.    {$ENDIF}
  341.    {$ENDIF}
  342. end;
  344. {-- TMMHiTimer -----------------------------------------------------------}
  345. procedure TMMHiTimer.UpdateTimer;
  346. var
  347. {$IFNDEF WIN32}
  348.    TimeCB: TTimeCallBack;
  349. {$ENDIF}
  350.    Msg: TMsg;
  351. begin
  352.    if (csDesigning in ComponentState) then exit;
  354.    {$IFDEF WIN32}
  355.    if FThreadCreated then
  356.    begin
  357.       {$IFDEF _MMDEBUG}
  358.       Debug(0,'Shot down Thread...');
  359.       {$ENDIF}
  361.       FTimerThread.Terminating := True;
  363.       { in case it is suspended remove all before terminate }
  364.       while FTimerThread.Suspended do FTimerThread.Resume;
  366.       FTimerThread.Terminate;
  368.       { force the thread to wake }
  369.       SetEvent(FTimerEvent);
  371.       { ...and wait for it to die }
  372.       if FWaitForTerminate and not FMainThreadWaiting then
  373.          WaitForSingleObject(FGeneralEvent, 5000);
  375.       if (FTimerThread <> nil) then
  376.           FTimerThread.HiTimer := nil;
  378.       { free the events }
  379.       CloseHandle(FGeneralEvent);
  380.       CloseHandle(FTimerEvent);
  382.       FThreadCreated := False;
  384.       {$IFDEF _MMDEBUG}
  385.       Debug(0,'Thread now stopped...');
  386.       {$ENDIF}
  387.    end;
  388.    {$ENDIF}
  390.    {$IFDEF WIN32}
  391.    {$IFDEF TRIAL}
  392.    {$DEFINE _HACK3}
  393.    {$I MMHACK.INC}
  394.    {$ENDIF}
  395.    {$ENDIF}
  397.    if (FTimerID <> 0) then
  398.    begin
  399.       TimeKillEvent(FTimerID);
  400.       FTimerID := 0;
  401.       if (FHandle <> 0) then
  402.       begin
  403.          { remove pending messages }
  404.          while PeekMessage(Msg, FHandle, MM_TIMER, MM_TIMER, PM_REMOVE) do;
  405.          DeallocateHWnd(FHandle);
  406.          FHandle := 0;
  407.          FMessageCount := 0;
  408.       end;
  409.       TimeEndPeriod(GetTimerCaps.wPeriodMin);
  410.    end;
  412.    if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then
  413.    begin
  414.       case FCallBackMode of
  415.          cmWindow: FHandle := AllocateHWnd(WndProc);
  416.          {$IFDEF WIN32}
  417.          cmThread:
  418.          begin
  419.             {$IFDEF _MMDEBUG}
  420.             Debug(0,'Try to start Thread...');
  421.             {$ENDIF}
  423.             FGeneralEvent := CreateEvent(nil, False, False, nil);
  424.             FTimerEvent := CreateEvent(nil,False,False,nil);
  426.             FTimerThread := TMMTimerThread.Create(True);
  427.             if (FTimerThread = nil) then
  428.                raise EMMHiTimerError.Create('HiTimer:'#10#13+LoadResStr(IDS_THREADERROR));
  430.             FTimerThread.HiTimer := Self;
  431.             FTimerThread.FreeOnTerminate := True;
  432.             FTimerThread.Terminating := False;
  433.             FThreadCreated := True;
  434.             FTimerThread.Resume;
  436.             { Wait for it to start... }
  437.             if WaitForSingleObject(FGeneralEvent, 5000) <> WAIT_OBJECT_0 then
  439.                raise EMMHiTimerError.Create('HiTimer:'#10#13+LoadResStr(IDS_THREADERROR));
  441.             {$IFDEF _MMDEBUG}
  442.             Debug(0,'Thread started...');
  443.             {$ENDIF}
  444.          end
  445.          {$ENDIF}
  446.       end;
  448.       {$IFDEF WIN32}
  449.       TimeBeginPeriod(GetTimerCaps.wPeriodMin);
  450.       FTimerID := TimeSetEvent(FInterval, 0, @TimeCallBack, Longint(Self), TIME_PERIODIC);
  451.       {$ELSE}
  452.       TimeCB := TimeCallBack;
  453.       TimeBeginPeriod(GetTimerCaps.wPeriodMin);
  454.       FTimerID := TimeSetEvent(FInterval, 0, TimeCB, Longint(Self), TIME_PERIODIC);
  455.       {$ENDIF}
  456.       if (FTimerID = 0) then
  457.          raise EOutOfResources.Create({$IFDEF DELPHI3}SNoTimers{$ELSE}LoadStr(SNoTimers){$ENDIF});
  458.    end;
  459. end;
  461. {$IFDEF WIN32}
  462. {-- TMMHiTimer -----------------------------------------------------------}
  463. procedure TMMHiTimer.SetPriority(aValue: TThreadPriority);
  464. begin
  465.    if aValue <> FPriority then
  466.    begin
  467.       FPriority := aValue;
  468.       if FThreadCreated then
  469.       begin
  470.          FTimerThread.Priority := FPriority;
  471.       end;
  472.    end;
  473. end;
  475. {-- TMMHiTimer -----------------------------------------------------------}
  476. procedure TMMHiTimer.SynchronizeVCL(VCLProc: TThreadMethod);
  477. begin
  478.    if (FCallBackMode = cmThread) and FThreadCreated then
  479.    begin
  480.       FMainThreadWaiting := True;
  481.       FTimerThread.Synchronize(VCLProc);
  482.       FMainThreadWaiting := False;
  483.    end;
  484. end;
  485. {$ENDIF}
  487. {-- TMMHiTimer -----------------------------------------------------------}
  488. procedure TMMHiTimer.DoTimer;
  489. begin
  490.    {$IFDEF WIN32}
  491.    if (FCallBackMode = cmThread) and FSynchronize then
  492.       SynchronizeVCL(Timer)
  493.    else
  494.    {$ENDIF}
  495.       Timer;
  496. end;
  498. {-- TMMHiTimer -----------------------------------------------------------}
  499. procedure TMMHiTimer.Timer;
  500. begin
  501.    if Assigned(FOnTimer) and FEnabled then FOnTimer(Self);
  502. end;
  504. end.