上へ

Delphi Tips

StringGrid の幅と高さの調整方法
カーソル移動サンプル
指定ウィンドウ以下の全てのコントロールの Enabled を設定する
TThread バグについて

StringGrid の幅と高さの調整方法

セル区切り丁度になるように StringGrid の幅と高さを調整するサンプル tip1.lzh

デザイン

表示したい大きさに ColCount, RowCount を設定(この場合は ColCount=3, RowCount=6)し、グリッド領域より大きめにレイアウトする。

スクロールバーの設定

ScrollBars プロパティを編集し、スクロールが起こる方向だけ有効にする。ここでは　ssVertical を指定する。

幅、高さ調整コード

FormCreate イベントに以下の調整コードを記入する

procedure TForm1.FormCreate(Sender: TObject);
begin
  // 調整
  StringGrid1.ClientWidth := StringGrid1.GridWidth;
  StringGrid1.ClientHeight := StringGrid1.GridHeight;
  // 実際に使用する行/列数に設定する
  StringGrid1.RowCount := 20;
end;

実行画面

スクロールが起こる方向にはスクロールバー分の領域垂直スクロールバー幅：GetSystemMetrics(SM_CXHSCROLL) 水平スクロールバー高さ：GetSystemMetrics(SM_CYHSCROLL) が追加されて表示される。ここでは垂直スクロールバーが追加されて表示される。

カーソル移動サンプル

キーリピートのように移動させる、タイマーを使っていないのでリピート間隔が安定している、 OnMouseDown/Up のセットではなく、マウス、キーボード、方向全て１つのイベントで処理するので、可読性とメンテナンスが良い。・・・と思う。ただしリターンキーを押した場合のように OnClick イベントだけが発生する場合は対応できない。サンプル tip2.lzh

デザイン

移動させるラベル(lblPos)と移動用のボタン(btnUp, btnDown, btnLeft, btnRight)を配置する。

OnKeyPress イベントハンドラ設定

btnUp に OnKeyPress イベントハンドラを追加し以下のコードを記入する

procedure TForm1.btnUpKeyPress(Sender: TObject; var Key: Char);
begin
  if (Key <> ' ') then
    Exit;

  // カーソル移動コード
  if (Sender = btnUp) then
    lblPos.Top := lblPos.Top - 1
  else if (Sender = btnDown) then
    lblPos.Top := lblPos.Top + 1
  else if (Sender = btnLeft) then
    lblPos.Left := lblPos.Left - 1
  else if (Sender = btnRight) then
    lblPos.Left := lblPos.Left + 1
    ;
  // 移動範囲制限
  lblPos.Top := Min(Max(lblPos.Top, 0), 200);
  lblPos.Left := Min(Max(lblPos.Left, 0), 200);
  lblPos.Caption := Format('[%3d,%3d]', [lblPos.Top, lblPos.Left]);
end;

OnMouseDown イベントハンドラ設定

btnUp に OnMouseDown イベントハンドラを追加し以下のコードを記入する

procedure TForm1.btnUpMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
  function WaitForButtonUp(Timeout: DWORD): Boolean;
  // Timeout[ms] ボタンが離されるのを待つ
  begin
    Timeout := GetTickCount + Timeout;
    repeat
      Application.ProcessMessages;
      Result := not (csLButtonDown in TControl(Sender).ControlState);
    until ((GetTickCount > Timeout) or (Result));
  end;
var
  Key: Char;
begin
  Key := ' ';
  btnUpKeyPress(Sender, Key);
  if (WaitForButtonUp(500)) then
    Exit;
  // 押し続けられている
  repeat
    btnUpKeyPress(Sender, Key);
  until (WaitForButtonUp(10));
end;

btnDown, btnLeft, btnRight イベントハンドラの設定

btnDown, btnLeft, btnRight それぞれの OnKeyPress と OnMouseDown イベントを btnUp のイベントに結びつける。

実行画面

マウスのクリック、またはスペースキーでボタンを押すとラベルが移動する。スペースキーの場合の移動速度はキーリピートの間隔。

指定ウィンドウ以下の全てのコントロールの Enabled を設定する

イベントハンドラ中で Application.ProcessMessage 系の関数を呼んでいて、再入排除などのために処理が終わるまで中止ボタン以外の全てのコントロールを無効にしたいときに使います。サンプル tip3.lzh

コード

procedure SetEnabledAll(AOwner: TWinControl; Enabled: Boolean;
  const IgnoreControls: array of TControl;
  const IgnoreClasses: array of TClass);
// IgnoreControls に指定したコントロールと
// IgnoreClasses に指定したクラス以外の
// AOwner 以下のコントロールを全て Enabled に設定する。

  function IsIgnored(Control: TControl): Boolean;
  // Control が IgnoreControls か IgnoreClasses に指定されているか
  // True : 指定されている
  // False: 指定されていない
  var
    I: Integer;
  begin
    Result := True;
    for I := 0 to Length(IgnoreControls) - 1 do
      if (Control = IgnoreControls[I])then
        Exit;
    for I := 0 to Length(IgnoreClasses) - 1 do
      if (Control is IgnoreClasses[I]) then
        Exit;
    Result := False;
  end;
var
  I: Integer;
  Control: TControl;
begin
  for I := 0 to AOwner.ControlCount - 1 do
  begin
    Control := AOwner.Controls[I];
    // Ignore に指定されていなければ Enabled 設定
    if (not IsIgnored(Control)) then
      Control.Enabled := Enabled;
    // TWinControl は子コントロールも設定
    if (Control is TWinControl) then
      SetEnabledAll(TWinControl(Control), Enabled, IgnoreControls, IgnoreClasses);
  end;
end;

呼び出し例

中止ボタン(btnStop), クリアボタン(btnClear) とラベル(TLabel, TStaticText) 以外のコントロールを全て無効にする。処理が終わったら、有効に戻す。

procedure TForm1.btnStartClick(Sender: TObject);
begin
  // 中止ボタン、クリアボタン、ログ、と ラベル系一般 以外を無効にする。
  btnStop.Enabled := True;
  SetEnabledAll(Self, False, [btnStop, btnClear, memLog], [TLabel, TStaticText]);
  try
    ...(中略)Application.ProcessMessage 系の呼び出しがある処理...
  finally
    // 中止ボタン以外を有効にする
    btnStop.Enabled := False;
    SetEnabledAll(Self, True, [btnStop], []);
  end;
end;

実行前	処理中:中止ボタン、クリアボタン以外は無効

TThread バグについて

TThread のバグについて検討する。結論として、有名なバグについては既に fix されている。(Delphi 5)
移植性(Kylix)や、開発環境依存の細かい点(IsMultiThread フラグなど)が実装されていることなどを考慮すると、自作するより TThread を継承して使ったほうが開発効率は良いと思います。

FreeOnTerminate メモリリークバグ
概要
FreeOnTerminate = True でメモリリークが起こる
ソースレベル
特に問題無いように見える。
テスト方法
以下のコード(中村拓男さんのコードそのままです)を実行し、メモリを Memory View Ver 1.04 Copyright(c) Sota 氏で監視する。
```
type
  MyThread = class(TThread)
  protected
    procedure Execute; override;
  end;

procedure MyThread.Execute;
begin
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  th: TThread;
begin
  th := MyThread.Create(True);
  th.FreeOnTerminate := True;
  th.Resume;
end;
```
結果
Delphi デバッグ環境下ではメモリが減りつづける、実行形式(exeファイル)を実行する場合はメモリは減らない。Delphi デバッグ環境の問題？
WaitFor, Synchronize デッドロックバグ
概要
スレッド中で Synchronize 呼び出し中にメインスレッドから WaitFor を呼ぶとスレッドはメッセージループがとまるため、SendMessage が完了しない、メインスレッドでは WaitFor が完了しないので、メッセージループが停止したままになり、デッドロックを起こす。
ソースレベル
WaitFor の呼び出しスレッドを判別して制御を分けている。多分、対応済み。
テスト方法
右のコードを実行し、ボタンを連打する。
```
type
  MyThread = class(TThread)
  protected
    procedure Execute; override;
    procedure SyncFunc;
  end;

procedure MyThread.Execute;
begin
  while (not Terminated) do
    Synchronize(SyncFunc);
end;

procedure MyThread.SyncFunc;
begin
  Form1.Label1.Tag := Form1.Label1.Tag + 1;
  Form1.Label1.Caption := IntToStr(Form1.Label1.Tag);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  th := MyThread.Create(False);  
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  th.Terminate;
  th.WaitFor;
  th.Free;
  FormCreate(Self);
end;
```
結果
デッドロックは起こらなかった。追試で Suspended, Suspend, Resume もテストしてみたが、サスペンド状態で WaitFor を呼ぶと固まる（当然かも）以外の問題は起こらなかった。
保護されていない共用変数を使用している

概要
TThread 内部で保護されていない変数 ThreadWindow, ThreadCount を使っている。
ソースレベル
考慮されている。多分対応済み。(Delphi 5)
テスト方法
なし
結果
必要十分な保護がされているかは読み取れなかったが、公開されていてメンテされているソースがバグ付きのまま何年も放置されているとは考えづらいので、自分で書くよりは信頼できそう。