十兵衛のホームページ-ちょっとしたテクニック

Delphi Programming Technique

実行時型情報を使ったCpationプロパティのイニシャライズ
DCUファイルからコンパイルされたDelphiのバージョンを知る
ディレクトリのサイズを再帰をつかった関数で求める
CapsLockが押されているかどうか/NumLockキーをアプリケーションで操作したい
動的配列あれこれ

実行時型情報を使ったCpationプロパティのイニシャライズ
アプリケーションを作成し、フォームの生成時に
Edit1.Text := '';
Label1.Caption := '';
等と書かれている方が多いと思います。
最初のうちはいいのですが、TEditやTLabelの数が増えてくるとコーディングがかなり面倒くさくなりますね。
そこで、Delphiの実行時型情報を使ったTCaptionプロパティのイニシャライズクラスを紹介します。
これを使えばいくつTEditやTLabelをフォームに貼付けてももう面倒くさくはありません。

unit CaptionInit;

interface

uses
  SysUtils, Classes, Forms, TypInfo;

type
  TCapInit = class
  private
    FInitStr: string;
    FForm:TCustomForm;
    FTargetTag: Integer;
    procedure SetTargetTag(const Value: Integer);
  protected
    procedure SetInitStr(Value:string);
    procedure InitializeCaption(AComponent:TComponent);virtual;
  public
    constructor Create(AForm:TCustomForm);virtual;
    procedure Execute;
    property InitStr:string read FInitStr write SetInitStr;
    property TargetTag:Integer read FTargetTag write SetTargetTag;
  end;


implementation

{ TCapInit }

constructor TCapInit.Create(AForm: TCustomForm);
begin
  if not Assigned(AForm) then
     raise Exception.Create('TCapInitクラスを生成出来ません');
  FForm := AForm;
  FTargetTag := 1;
  FInitStr := '';
end;

procedure TCapInit.Execute;
var
 IDX,Cnt:Integer;
begin
  if Assigned(FForm) then begin
     Cnt := FForm.ComponentCount;
     for IDX := 0 to Cnt -1 do begin
         if FForm.Components[IDX].Tag = FTargetTag then
            InitializeCaption(FForm.Components[IDX]);
     end;
     InitializeCaption(FForm);
  end;
end;

procedure TCapInit.InitializeCaption(AComponent:TComponent);
var
  PList:PPropList;
  IDX,Cnt:Integer;
begin
  Cnt := GetTypeData(AComponent.ClassInfo)^.PropCount;
  PList := AllocMem(Cnt * SizeOf(Pointer));
  try
    GetPropInfos(AComponent.ClassInfo,PList);
    for IDX := 0 to Cnt-1 do begin
      if (AnsiCompareStr(PList^[IDX].PropType^.Name,'TCaption')=0) then
          SetStrProp(AComponent,PList[IDX],FInitStr);
    end;
  finally
    FreeMem(PList,Cnt * SizeOf(Pointer));
  end;
end;

procedure TCapInit.SetInitStr(Value: string);
begin
  if FInitStr <> Value then FInitStr := Value;
end;

procedure TCapInit.SetTargetTag(const Value: Integer);
begin
  if FtargetTag <> Value then FTargetTag := Value;
end;


end.

【使い方例】
初期化を行いたいコンポーネントの「Tagプロパティ」を設計時に“1”に設定しておきます。

procedure TForm1.FormCreate(Sender: TObject);
var
 ACapInit:TCapInit;
begin
 ACapInit := TCapInit.Create(Self);
 try
   ACapInit.InitStr := 'Init';
   ACapInit.TargetTag := 1;
   ACapInit.Execute;
 finally
   ACapInit.Free;
 end;
end;
フォーム生成時にキャプションプロパティを持つコンポーネントで
Tagプロパティに“1”が設定されているコンポに「Init」という文字が設定されます。

DCUファイルからコンパイルされたDelphiのバージョンを知る。
FDELPHIで一時話題になった「コンパイルしたのはどのバージョンのDelphiか」を調べるクラスです。

unit DelphiSelect;

interface

uses
  SysUtils, Classes;

type
  TProjectType = (ptDel3,ptDel4,ptUnKnown);

  TDelphiSelector = class(TObject)
  private
    FFileName,FPasFile:TFileName;
    FProType:TProjectType;
  protected
    procedure SetFileName(Value:TFileName);
    procedure FileCheck;
    procedure ProjectRead;
    procedure PasRead;
  public
    property FileName:TFileName read FFileName write SetFileName;
    property ProjectType:TProjectType read FProType;
  end;

implementation

type
 TMyFileStyle = (fsDpr,fsPas,fsUnKnown);

procedure TDelphiSelector.SetFileName(Value:TFileName);
begin
 if Value <> FFileName then begin
    FFileName := Value;
    FileCheck;
 end;
end;

procedure TDelphiSelector.FileCheck;
var
 FileStyle:TMyFileStyle;
 FExt:string;
begin
 if FileExists(FFileName) then begin
    FExt := ExtractFileExt(FFileName);
    if AnsiCompareText('.Dpr',FExt) = 0 then FileStyle := fsDpr
    else if AnsiCompareText('.Pas',FExt) = 0 then FileStyle := fsPas
    else FileStyle := fsUnKnown;
 end else FileStyle := fsUnKnown;
 case FileStyle of
  fsDpr:ProjectRead;
  fsPas:
  begin
    FPasFile := FFileName;
    PasRead;
  end;
  fsUnKnown:FProType := ptUnKnown;
 end;
end;

procedure TDelphiSelector.ProjectRead;
var
 FPro:TextFile;
 FStr:string;
 FPos1,FPos2:Integer;
begin
 AssignFile(FPro,FFileName);
 FileMode := 0;
 Reset(FPro);
 try
  while not Eof(FPro) do begin
    Readln(FPro,FStr);
    FPos1 := AnsiPos('.PAS',AnsiUpperCase(FStr));
    if FPos1 > 0 then begin
     FPos2 := Pos('''',FStr)+1;
     FPasFile := Copy(FStr,FPos2,FPos1-FPos2+4);
     FPasFile := ExtractFilePath(FFileName)+FPasFile;
     PasRead;
     Break;
    end;
  end;
 finally
  CloseFile(FPro);
  FileMode := 2;
 end;
end;

procedure TDelphiSelector.PasRead;
var
 FReadFile:TFileStream;
 FDcuFile:string;
 Buf:array[0..7] of Char;
begin
 FDcuFile := ChangeFileExt(FPasFile,'.dcu');
 if FileExists(FDcuFile) then begin
    FReadFile := TFileStream.Create(FDcuFile,fmOpenRead);
    try
      FReadFile.Read(Buf,4);
      if StrLComp(Buf,#$41#$86#$51#$44,4) = 0 then FProType := ptDel3
      else if StrLComp(Buf,#216#166#104#71,4) = 0 then FProType := ptDel4
      else FProType := ptUnKnown;
    finally
      FReadFile.Free;
    end;
 end else FProType := ptUnKnown;
end;


end.

【使い方例】
フォームのprivate部に“DelSel:TDelphiSelector;”と宣言しておきます。

procedure TSelector.FormCreate(Sender: TObject);
begin
 Label1.Caption := '';
 OpenDialog1.Filter := 'DelphiFiles(dpr,pas)|*.dpr;*.pas';
 OpenDialog1.Title := 'Delphiのファイルを指定する';
 DelSel := TDelphiSelector.Create;
end;

procedure TSelector.FormDestroy(Sender: TObject);
begin
 DelSel.Free;
end;

procedure TSelector.Button1Click(Sender: TObject);
begin
 Label1.Caption := '';
 OpenDialog1.FileName := '';
 if OpenDialog1.Execute then begin
    DelSel.FileName := OpenDialog1.FileName;
    case DelSel.ProjectType of
      ptDel3:Label1.Caption := 'Delphi3です';
      ptDel4:Label1.Caption := 'Delphi4です';
      ptUnKnown:Label1.Caption := '不明です';
    end;
 end;
end;

ディレクトリのサイズを再帰をつかった関数で求める。
ディレクトリに含まれているファイルのサイズを再帰を使って取得し、その合計値をディレクトリのサイズとして返します。

function GetDirectorySize(const ADir,AMask:string;
                                 const AAttr:Integer;
                                 const ARet:Boolean):Integer;
var
 FDir:string;
 FAttr,FRes,FSize:Integer;
 FFile:TSearchRec;
begin
 FSize := 0;
 FAttr := AAttr;
 if not IsDelimiter('\',ADir,Length(ADir)) then FDir := ADir + '\';
 FRes := FindFirst(FDir+AMask,FAttr,FFile);
 if FRes = 0 then begin
   try
    repeat
     if (FFile.Attr and faDirectory) > 0 then begin
        if (FFile.Name[1] <> '.') and ARet then
            FSize := FSize + GetDirectorySize(FDir+FFile.Name,AMask,FAttr,ARet);
     end else begin
      FSize := FSize + FFile.Size;
     end;
     FRes := SysUtils.FindNext(FFile);
    until FRes <> 0;
   finally
    FindClose(FFile);
   end;
 end;
 Result := FSize;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
 FDir:string;
 FAttr,FRes,FSize:Integer;
 FFile:TSearchRec;
begin
 FDir := GetCurrentDir;
 if not SelectDirectory(FDir,[],-1) then Exit;
 FAttr := faAnyFile;
 //ここで再帰検索関数を呼び出す。
 FSize := GetDirectorySize(FDir,'*.*',FAttr,False);
 FSize := Trunc(FSize/1024);
 ShowMessage(Format('サイズは%dKBです',[FSize]));
end;

CapsLockが押されているかどうか/NumLockキーをアプリケーションで操作したい。
CapsLockの“On/OＦＦ”状態はGetKeyboardState関数を使って調べることができます。
NumLockキーをアプリケーションから操作する場合、Windows95とWindowsNTとではコーディング方法に違いがあります。

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    function CapsState:Boolean;
    procedure ChangeNumLock;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

//Capsの状態を調べる関数
function TForm1.CapsState:Boolean;
var
  FKeyState:TKeyboardState;
begin
  GetKeyboardState(FKeyState);
  Result := Boolean(FKeyState[VK_NUMLOCK]);
  if Result then Caption := 'NUM-Lock'
  else Caption := 'NUM-UnLock';
end;

//アプリケーションからNumLockを操作する手続き
procedure TForm1.ChangeNumLock;
var
  FKeyState:TKeyboardState;
  FKeyFlg:Boolean;
begin
  SetForegroundWindow(Application.Handle);
  KeyPreview := True;
  GetKeyboardState(FKeyState);
  if Win32Platform = VER_PLATFORM_WIN32_NT then begin
     keybd_event(VK_NUMLOCK, 0, 0, 0);
     keybd_event(VK_NUMLOCK, 0, KEYEVENTF_KEYUP, 0);
  end else begin
     FKeyFlg := not Bool(FKeyState[VK_NUMLOCK]);
     FKeyState[VK_NUMLOCK] := Ord(FKeyFlg);
     SetKeyboardState(FKeyState);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 ChangeNumLock;//起動時に操作
 CapsState;    //状態表示
end;

//キーの押されたことを検知
procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 CapsState;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ChangeNumLock;
  CapsState;
end;

動的配列あれこれ
Delphi3/3.1以前では動的配列を使うにはTListオブジェクトを使ったり、配列型を使ったコーディングが必要でした。
type
　PMyArray = ^TMyArray;
　TMyArray = array of [0..100] of Integer;

var
　IDX : Integer;
　MyArray: PMyArray;
　begin
　 MyArray := AllocMem(SizeOf(Integer) * 10);
　 for IDX := 0 to 9 do MyArray^[IDX] := IDX;
　FreeMem(MyArray, SizeOf(Integer) * 10);
　end;

Delphi4以降では動的配列が簡単に扱えるようになりました。
例えば次のコードでは動的配列を作成しループを使ってデータをセットします。

type
  TMyRec = packed record
    Dat1:SmallInt;
    Dat2:Integer;
  end;

  TMyAry = array of TMyRec;

procedure TForm1.SetData(var Dat: TMyAry; const AFileName: TFileName);
var
 OutFile:file of TMyRec;
 IDX:Integer;
begin
 AssignFile(OutFile,AFileName);
 ReWrite(OutFile);
 try
  for IDX := 0 to High(Dat) do Write(OutFile,Dat[IDX]);
 finally
   CloseFile(outFile);
 end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
 Dat:TMyAry;
 IDX:Integer;
begin
 SaveDialog1.InitialDir := 'I:\Temp';
 if not SaveDialog1.Execute then Exit;
 SetLength(Dat,2000000);
 try
   for IDX := 0 to 100-1 do begin
     Dat[IDX].Dat1 := SmallInt(IDX);
     Dat[IDX].Dat2 := IDX+2;
   end;
   SetData(Dat,SaveDialog1.FileName);
 finally
   Finalize(Dat);
 end;
end;

型付きファイルから動的配列にデータを読み込みます。

procedure TForm1.Button1Click(Sender: TObject);
var
 Dat:TMyAry;
 IDX:Integer;
 FTime:DWORD;
 InFile:file;
begin
 OpenDialog1.InitialDir := 'I:\Temp';
 if not OpenDialog1.Execute then Exit;
 AssignFile(InFile,OpenDialog1.FileName);
 Reset(InFile,SizeOf(TMyRec));
 SetLength(Dat,FileSize(InFile));
 try
   BlockRead(InFile,Dat[0],FileSize(InFile));
 finally
   Finalize(Dat);
   CloseFile(InFile);
 end;
end;

TFileStreamを使って動的配列にデータを読み込みます。

procedure TForm1.Button3Click(Sender: TObject);
var
 IDX:Integer;
 FFile:TFileStream;
 Dat:TMyAry;
begin
 OpenDialog1.InitialDir := 'I:\Temp';
 if not OpenDialog1.Execute then Exit;
 FFile := TFileStream.Create(OpenDialog1.FileName,fmOpenRead);
 IDX := FFile.Size div SizeOf(TMyRec);
 SetLength(Dat,IDX);
 try
   FFile.Read(Dat[0],FFile.Size);
 finally
   FFile.Free;
   Finalize(Dat);
 end;
end;

(戻る)

Contents