转：简单窗体振动-WaitForSingleObject，消息，winapi

http://www.cnblogs.com/Jekhn/archive/2012/08/25/2656656.html

线程，消息函数，SetWindowPos设置窗体位置

if WaitForSingleObject(FEvent,FInterval)=WAIT_OBJECT_0 then用法

 

//Main Form   http://www.cnblogs.com/Jekhn/archive/2012/08/25/2656656.html

unit unitMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, unitWorkThread{Thread};

type
  TfrmMain = class(TForm)
    btnStart: TButton;
    mmo1: TMemo;
    btn1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnStartClick(Sender: TObject);
    procedure btn1Click(Sender: TObject);
  private
    { Private declarations }
    FDestWindow: HWND;
    FOriginalRect: TRect;
    procedure DefaultPostion;
    procedure GoLeft;
    procedure GoRight;
    procedure GoTop;
    procedure GoBottom;
  protected
    procedure OnLeft(var aMag: TMessage); message WM_LEFT;
    procedure OnRight(var aMag: TMessage); message WM_RIGHT;
    procedure OnTop(var aMag: TMessage); message WM_TOP;
    procedure OnBottom(var aMag: TMessage); message WM_BOTTOM;
    procedure OnDefault(var aMag: TMessage); message WM_DEFAULT;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;
const
  K_OFFSET = 2;

implementation

{$R *.dfm}

{ TfrmMain }

procedure TfrmMain.defaultPostion;
begin
  SetWindowPos(FDestWindow,HWND_TOP,FOriginalRect.Left,FOriginalRect.Top,0,0,SWP_NOSIZE);
end;

procedure TfrmMain.OnDefault(var aMag: TMessage);
begin
  defaultPostion;
end;

procedure TfrmMain.GoBottom;
begin
  SetWindowPos(FDestWindow,HWND_TOP,FOriginalRect.Left,FOriginalRect.Top - K_OFFSET,0,0,SWP_NOSIZE);
end;

procedure TfrmMain.GoLeft;
begin
  SetWindowPos(FDestWindow,HWND_TOP,FOriginalRect.Left + K_OFFSET,FOriginalRect.Top,0,0,SWP_NOSIZE);
end;

procedure TfrmMain.GoRight;
begin
  SetWindowPos(FDestWindow,HWND_TOP,FOriginalRect.Left - K_OFFSET,FOriginalRect.Top,0,0,SWP_NOSIZE);
end;

procedure TfrmMain.GoTop;
begin
  SetWindowPos(FDestWindow,HWND_TOP,FOriginalRect.Left,FOriginalRect.Top + K_OFFSET,0,0,SWP_NOSIZE);
end;

procedure TfrmMain.OnBottom(var aMag: TMessage);
begin
  GoBottom;
end;

procedure TfrmMain.OnLeft(var aMag: TMessage);
begin
  GoLeft;
end;

procedure TfrmMain.OnRight(var aMag: TMessage);
begin
  GoRight;
end;

procedure TfrmMain.OnTop(var aMag: TMessage);
begin
  GoTop;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  Self.DoubleBuffered := True;
  FDestWindow := Handle;
  GetWindowRect(FDestWindow,FOriginalRect);
  WorkThread := TWorkThread.Create(TRUE,mmo1);
  WorkThread.Interval := 10;
  WorkThread.MainFormHWND := Self.Handle;
  WorkThread.DoTimes := 5;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  if Assigned(WorkThread) then
    WorkThread.exitThread;
end;

procedure TfrmMain.btnStartClick(Sender: TObject);
begin
  if Assigned(WorkThread) then
  begin
    if WorkThread.Suspended then
      WorkThread.Resume;
  end;
end;

procedure TfrmMain.btn1Click(Sender: TObject);
begin
  if Assigned(WorkThread) then
  begin
    WorkThread.exitThread;
  end
  else
  begin
    //
  end;

end;

end.

unitMain

object frmMain: TfrmMain
  Left = 339
  Top = 203
  Width = 430
  Height = 307
  Caption = 'frmMain'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object btnStart: TButton
    Left = 48
    Top = 32
    Width = 75
    Height = 25
    Caption = 'btnStart'
    TabOrder = 0
    OnClick = btnStartClick
  end
  object mmo1: TMemo
    Left = 229
    Top = 0
    Width = 185
    Height = 269
    Align = alRight
    ImeName = '中文 (简体) - 搜狗拼音输入法'
    Lines.Strings = (
      'mmo1')
    ScrollBars = ssBoth
    TabOrder = 1
  end
  object btn1: TButton
    Left = 64
    Top = 160
    Width = 75
    Height = 25
    Caption = '退出线程'
    TabOrder = 2
    OnClick = btn1Click
  end
end

TfrmMain窗体文件

//Thread

{*******************************************************}
{                                                       }
{       Delphi Thread Sample                            }                            
{       Creation Date 2012.08.25                        }
{       Created By: ming                                }
{                                                       }
{*******************************************************}
unit unitWorkThread;

interface

uses
  Classes,Windows, Messages, SysUtils, Graphics, StdCtrls, Controls, DateUtils;

const
  WM_UPDATE  = WM_USER + $100;
  WM_LEFT    = WM_USER + $101;
  WM_RIGHT   = WM_USER + $102;
  WM_TOP     = WM_USER + $103;
  WM_BOTTOM  = WM_USER + $104;
  WM_DEFAULT = WM_USER + $105;

type
  TWorkThread = class(TThread)
  private
    { Private declarations }
    FEvent,FMainFormHWND: HWND;
    FDoTimes,FTickTimes: Integer;
    FMsg: string;
    FMemo:  TMemo;
    FInterval: Cardinal;
    procedure doSyncProc1;
    procedure doSomething;
    procedure syncOutputMsg;
    procedure doOutputMsg(const msg: string);
    procedure _sleep(millisecond:Cardinal);
  protected
    procedure Execute; override;
  public
    constructor Create(Suspend: boolean); overload;
    constructor Create(Suspend: boolean; mmoOutput: TMemo); overload;
    destructor Destroy; override;
  public
    procedure exitThread;
  public
    property Interval:Cardinal read FInterval write FInterval;
    property MainFormHWND: HWND read FMainFormHWND write FMainFormHWND;
    property DoTimes:Integer read FDoTimes write FDoTimes;
  end;

var
  WorkThread: TWorkThread;

implementation

{ TWorkThread }

constructor TWorkThread.Create(Suspend: boolean);
begin
  inherited Create(Suspend);
  FEvent := CreateEvent(nil,False,False,nil);
  FreeOnTerminate := True;
  FInterval := 100;
end;

constructor TWorkThread.Create(Suspend: boolean; mmoOutput: TMemo);
begin
  inherited Create(Suspend);
  FEvent := CreateEvent(nil,False,False,nil);
  FreeOnTerminate := True;
  FInterval := 100;  
  FMemo := mmoOutput;
  doOutputMsg('Thread Create');
end;

destructor TWorkThread.Destroy;
begin
  CloseHandle(FEvent);
  doOutputMsg('Thread Destroy');
  inherited;
end;

procedure TWorkThread.doSyncProc1;
begin

end;

procedure TWorkThread.doOutputMsg(const msg: string);
begin
  FMsg := msg;
  Synchronize(syncOutputMsg);
end;

procedure TWorkThread.syncOutputMsg;
begin
  if Assigned(FMemo) then
    FMemo.Lines.Add(FMsg);
end;

procedure TWorkThread.doSomething;
const
  K_SLEEP = 20;
begin
  SendMessage(FMainFormHWND,WM_LEFT,0,0); _Sleep(K_SLEEP);
  SendMessage(FMainFormHWND,WM_DEFAULT,0,0);
  doOutputMsg('Thread WM_LEFT 第'+inttostr(FTickTimes));
  SendMessage(FMainFormHWND,WM_RIGHT,0,0); _Sleep(K_SLEEP);
  SendMessage(FMainFormHWND,WM_DEFAULT,0,0);
  doOutputMsg('Thread WM_RIGHT 第'+inttostr(FTickTimes));
  SendMessage(FMainFormHWND,WM_TOP,0,0);   _Sleep(K_SLEEP);
  SendMessage(FMainFormHWND,WM_DEFAULT,0,0);
  doOutputMsg('Thread WM_TOP 第'+inttostr(FTickTimes));
  SendMessage(FMainFormHWND,WM_BOTTOM,0,0); _Sleep(K_SLEEP);
  SendMessage(FMainFormHWND,WM_DEFAULT,0,0);
  doOutputMsg('Thread WM_BOTTOM 第'+inttostr(FTickTimes));
  Inc(FTickTimes);
  if FTickTimes >= FDoTimes then
  begin
    FTickTimes := 0;
    Self.Suspend;
  end;
end;

procedure TWorkThread.Execute;
begin
  inherited;
  while not Terminated do
  begin
    //FInterval表示发信号量过了后等待的时间
    //WAIT_OBJECT_0表示 等待的事件已经激活
    if WaitForSingleObject(FEvent,FInterval)=WAIT_OBJECT_0 then
    begin
      Break;
    end;
    doSomething;
  end;
end;

procedure TWorkThread.exitThread;
begin
  if FEvent>0 then
  begin
    SetEvent(FEvent);
    if Suspended then Resume;
  end;
end;

procedure TWorkThread._sleep(millisecond: Cardinal);
begin
  WaitForSingleObject(Self.Handle,millisecond);
end;

{=============================================================}
{ Use TWorkThread
procedure TForm1.btnCreateThreadClick(Sender: TObject);
begin
  WorkThread := TWorkThread.Create(False,mmoOutput);
  //WorkThread.Interval := 1000;
  if WorkThread.Suspended then
    WorkThread.Resume;
end;

procedure TForm1.btnDestroyThreadClick(Sender: TObject);
begin
  if Assigned(WorkThread) then  
    WorkThread.exitThread;
end;
}

end.unit Unit2;

interface

implementation

end.

unitWorkThread