実行中の関数を中止させて新たに実行する方法 (ID：42021)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

スレッド化するのが適切かなぁと思います。
OnEnterはわかりづらいのでReturnキーでイベントを発生させています。

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TTestThread = class(TThread)
  private
    fProcess: TNotifyEvent;
    procedure ProcessEvent;
  public
    Name:string;
    Work:Cardinal;
    Time:Cardinal;  //Time msかかる処理
    procedure Execute; override;
    property Process:TNotifyEvent read fProcess write fProcess;
  end;

TForm1 = class(TForm)
    Edit1: TEdit;
    Edit2: TEdit;
    procedure FormCreate(Sender: TObject);
    procedure Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
    { Private 宣言 }
    fTest:TTestThread;
    fTextBuffer,fNameBuffer:string;
    procedure BeginThread;
    procedure ThreadProcess(Sender:TObject);
    procedure ThreadTerminate(Sender:TObject);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TTestThread }

procedure TTestThread.Execute;
var
  s,c,p:Cardinal;
begin
  inherited;
  s := GetTickCount;
  c := s;
  p := s;
  repeat
    if c + 200 < p then  //200ms毎に経過報告
    begin
      Synchronize(ProcessEvent);
      c := p;
    end;
    p := GetTickCount;
    Work := p - s
  until (Terminated) or (Work >= Time);
end;

procedure TTestThread.ProcessEvent;
begin
  if Assigned(fProcess) then
    fProcess(Self);
end;

{ TForm1 }

procedure TForm1.BeginThread;
begin
  fTest := TTestThread.Create(True);
  fTest.FreeOnTerminate := True;
  fTest.Time := StrToInt(fTextBuffer);
  fTextBuffer := '';
  fTest.Name := fNameBuffer;
  fTest.Process := ThreadProcess;
  fTest.OnTerminate := ThreadTerminate;
  fTest.Start;
end;

procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key=VK_RETURN then
  begin
    fTextBuffer := TEdit(Sender).Text;
    fNameBuffer := TEdit(Sender).Name;
    if fTest<>nil then
      fTest.Terminate else
      BeginThread;
  end;
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  if fTest<>nil then
    fTest.Terminate;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  //入力した秒数(ms)だけ処理する
  Edit1.Text := IntToStr(10000);
  Edit2.Text := IntToStr(20000);
end;

procedure TForm1.ThreadProcess(Sender: TObject);
begin
  Caption := fTest.Name +' '+ IntToStr(fTest.Work)+'/'+IntToStr(fTest.Time);
end;

procedure TForm1.ThreadTerminate(Sender: TObject);
begin
  fTest := nil;
  Caption := '終了';
  if fTextBuffer<>'' then
    BeginThread;
end;

end.

←解決時は質問者本人がここをチェックしてください。

戻る