Delphiッこ倶楽部東京出張所: 11月 2010

2010年11月5日金曜日

StartsStr関数,EndsStr関数

プログラムの作成中にHelpを眺めていてたまたま目についた関数

StartsStrは、ある文字列が指定したサブ文字列で始まるかをチェックする関数
EndsStrは、ある文字列が指定したサブ文字列で終わるるかをチェックする関数
ともに大文字小文字は別物として扱います。

上記のようなチェックを大文字小文字区別しないで行う関数もあり、
それぞれ、StartsText,EndsTexstです。

以下、サンプル

view plain print ?

WriteLn('大文字小文字区別して比較');
if StartsStr('so','So What ?') then
begin
WriteLn('はじまるよ')
end
else
begin
WriteLn('はじまらない')
end;
WriteLn('大文字小文字区別なしに比較');
if StartsText('so','So what ?') then
begin
WriteLn('はじまるよ')
end
else
begin
WriteLn('はじまらない')
end;

WriteLn('大文字小文字区別して比較');
      if StartsStr('so','So What ?') then
      begin
       WriteLn('はじまるよ')
      end
      else
      begin
       WriteLn('はじまらない')
      end;

      WriteLn('大文字小文字区別なしに比較');
      if StartsText('so','So what ?') then
      begin
       WriteLn('はじまるよ')
      end
      else
      begin
       WriteLn('はじまらない')
      end;

でも、これらの関数っていつからあったのだろうか？
手元の環境で調べたところ少なくともDelphi2007には
あったようだけど

2010年11月3日水曜日

Purgeもどき

仕事で使っているアプリケーションがExeName_YYYYMMDDHHNNSS.Logのような
ログファイルを一杯作るので、消してくれという依頼があった。

ただし、このフォルダには、上記のログを作るファイルがいくつかああって
3世代程度は残してくれという依頼があった。

昔、仕事で触ってたOpenVmsのファイルシステムにはバージョンというのが
あって、古いバージョンのファイルを消すPurgeコマンドがあり
これとにたようなものが欲しいなということで、とりあえず作ってみた。
(本家には似ても似つかぬ、あくまでももどきですが。）

使い方は、

PurgeMock "パージファイルマスク" /D:パージファイルがあるフォルダ /G:残す世代数

で、/R: を指定することで、パージファイルマスクに正規表現が使用できます。

また、ファイルの更新日時を基準に/G:で指定した数だけ残るよう古い日付のものを
削除しますが、 /T:を指定することでファイルの作成日時を基準にPurgeすることが
できます。

なお、パージファイルマスクにより、複数の異なるファイル名のファイルが削除対象
となりえますが、このツールでは、このような場合のことを想定しておりません。
（/G:で指定した数になるようにばっさり消します。）

以下、ソース(delphi Xeがあればコンパイル可能です。)を置いておきます。
ライセンスは、MITライセンスとします。
ソース使用は自由ですが、無保証とします。

まずはメイン。

view plain print ?

program PurgeMock;
{$APPTYPE CONSOLE}
uses
SysUtils,
PurgeMockImp in 'PurgeMockImp.pas',
MidasLib
;
function CreatePurgeMockParams : TPurgeMockParams;
var
PurgeMockParams : TPurgeMockParams;
i : Integer;
begin
PurgeMockParams := TPurgeMockParams.Create;
try
try
PurgeMockParams.Init(Paramstr(0));
for i := 1 to ParamCount -1 do
begin
PurgeMockParams.SetPurgeParam(Paramstr(i));
end;
except
PurgeMockParams.Free;
PurgeMockParams := nil;
end;
finally
Result := PurgeMockParams;
end;
end;
var
PurgeMockParams : TPurgeMockParams;
DoPurgeMock : TPuregMock;
Ret : Integer;
begin
try
{ TODO -oUser -cConsole メイン : ここにコードを記述してください }
PurgeMockParams := CreatePurgeMockParams;
if Assigned(PurgeMockParams) then
begin
DoPurgeMock := TPuregMock.Create(PurgeMockParams);
try
Ret := DoPurgeMock.Purge;
finally
DoPurgeMock.Free;
end;
PurgeMockParams.Free;
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.

program PurgeMock;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  PurgeMockImp in 'PurgeMockImp.pas',
  MidasLib
  ;

function CreatePurgeMockParams : TPurgeMockParams;
var
  PurgeMockParams : TPurgeMockParams;
 i : Integer;
begin

  PurgeMockParams := TPurgeMockParams.Create;
  try
    try
   PurgeMockParams.Init(Paramstr(0));
   for i := 1 to ParamCount -1 do
      begin
       PurgeMockParams.SetPurgeParam(Paramstr(i));
      end;
    except
      PurgeMockParams.Free;
      PurgeMockParams := nil;
    end;

  finally
    Result := PurgeMockParams;
  end;

end;

var
  PurgeMockParams : TPurgeMockParams;
  DoPurgeMock     : TPuregMock;
  Ret : Integer;

begin
  try
    { TODO -oUser -cConsole メイン : ここにコードを記述してください }
    PurgeMockParams := CreatePurgeMockParams;
    if Assigned(PurgeMockParams) then
    begin
      DoPurgeMock := TPuregMock.Create(PurgeMockParams);
      try
        Ret := DoPurgeMock.Purge;
      finally
        DoPurgeMock.Free;
      end;
      PurgeMockParams.Free;
    end;


  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.

次に、パージコマンドの本体

view plain print ?

unit PurgeMockImp;
interface
uses
SysUtils
,DB
,DBClient
;
type
TPurgeTimeStamp = (ptCreate, ptUpdate);
TPurgeMockParams = class
private
FTargetDir: String;
FUseRegularExpression: Boolean;
FFileMask: String;
FLeavingGenerations: Integer;
FPurgeTimeStamp: TPurgeTimeStamp;
procedure SetTargetDir(val: String);
procedure SetUseRegularExpression(val: Boolean);
procedure SetFileMask(val: String);
procedure SetLeavingGenerations(val: Integer);
procedure SetPurgeTimeStamp(val: TPurgeTimeStamp);
public
property TargetDir: String read FTargetDir write SetTargetDir;
property UseRegularExpression: Boolean read FUseRegularExpression
write SetUseRegularExpression;
property FileMask: String read FFileMask write SetFileMask;
property LeavingGenerations: Integer read FLeavingGenerations
write SetLeavingGenerations;
property PurgeTimeStamp: TPurgeTimeStamp read FPurgeTimeStamp
write SetPurgeTimeStamp;
procedure Init(ExePath: String);
procedure SetPurgeParam(PurgeParam : String);
end;
TPuregMock = class
public
constructor Create(Params: TPurgeMockParams);
function Purge: Integer;
destructor Destroy; override;
strict private
FPurgeMockParams: TPurgeMockParams;
FPurgeMockDataSet : TClientDataSet;
function MakePurgeFileList: Integer;
function ExecPurge: Integer;
function CreatePurgeDataSet : TClientDataSet;
end;
function TryParseCmdLineSw(ParameterString : String; Sw : Array of String; var ParamValue : String; IgnoreCase: Boolean = true) : boolean;
implementation
Uses
StrUtils
,IOUtils
,Types
,RegularExpressionsCore
;
procedure TPurgeMockParams.SetTargetDir(val: String);
begin
FTargetDir := val;
end;
procedure TPurgeMockParams.SetUseRegularExpression(val: Boolean);
begin
FUseRegularExpression := val;
end;
procedure TPurgeMockParams.Init(ExePath: String);
begin
FTargetDir := ExtractFileDir(ExePath);
FUseRegularExpression := false;
FileMask := '*.*';
FLeavingGenerations := 1;
FPurgeTimeStamp := ptUpdate;
end;
procedure TPurgeMockParams.SetFileMask(val: String);
begin
FFileMask := val
end;
procedure TPurgeMockParams.SetLeavingGenerations(val: Integer);
begin
if Val >= 0 then
begin
FLeavingGenerations := val;
end
else
begin
FLeavingGenerations := 0;
end;
end;
procedure TPurgeMockParams.SetPurgeParam(PurgeParam: String);
var
ValueStr : String;
begin
if TryParseCmdLineSw(PurgeParam,['/D:','-D:'],ValueStr) then
begin
FTargetDir := ValueStr;
Exit;
end;
if TryParseCmdLineSw(PurgeParam,['/U:','-U:'],ValueStr) then
begin
FUseRegularExpression := true;
Exit;
end;
if TryParseCmdLineSw(PurgeParam,['/G:','-G:'],ValueStr) then
begin
LeavingGenerations := StrToIntDef(ValueStr,1);
Exit;
end;
if TryParseCmdLineSw(PurgeParam,['/T:','-T:'],ValueStr) then
begin
FPurgeTimeStamp := ptCreate;
Exit;
end;
if TryParseCmdLineSw(PurgeParam,[],ValueStr) then
begin
FFileMask := ValueStr;
Exit;
end;
end;
procedure TPurgeMockParams.SetPurgeTimeStamp(val: TPurgeTimeStamp);
begin
FPurgeTimeStamp := val;
end;
constructor TPuregMock.Create(Params: TPurgeMockParams);
begin
inherited Create;
FPurgeMockParams := Params;
end;
function TPuregMock.Purge: Integer;
begin
Result := -1;
FPurgeMockDataSet := CreatePurgeDataSet;
if Assigned(FPurgeMockDataSet) then
begin
if MakePurgeFileList > 0 then
begin
Result := ExecPurge;
end;
FPurgeMockDataSet.EmptyDataSet;
FPurgeMockDataSet.Active := false;
FPurgeMockDataSet.Free;
end;
end;
function TPuregMock.CreatePurgeDataSet: TClientDataSet;
var
PurgeDataSet : TClientDataSet;
FD : TFieldDef;
begin
PurgeDataSet := TClientDataSet.Create(nil);
try
try
FD := PurgeDataSet.FieldDefs.AddFieldDef;
FD.Name := 'FileName';
FD.DataType := ftString;
FD.Size := 1024;
FD := PurgeDataSet.FieldDefs.AddFieldDef;
FD.Name := 'TimeStamp';
FD.DataType := ftDatetime;
PurgeDataSet.CreateDataSet;
PurgeDataSet.AddIndex('Purge_Idx','TimeStamp;FileName',[]);
PurgeDataSet.IndexName := 'Purge_Idx';
Except
if Assigned(PurgeDataSet) then PurgeDataSet.Free;
PurgeDataSet := nil;
end;
finally
Result := PurgeDataSet;
end;
end;
destructor TPuregMock.Destroy;
begin
if Assigned(FPurgeMockParams) then
begin
FPurgeMockParams := nil;
end;
inherited Destroy;
end;
function TPuregMock.MakePurgeFileList: Integer;
var
SearchOption: TSearchOption;
SearchDir : TDirectory;
SearchFileMask : String;
LList: TStringDynArray;
FileFullName,FileName : String;
CanAddList : Boolean;
PerlRegEx: TPerlRegEx;
PurgeFile : TFile;
begin
Result := 0;
//使っても使わなくても正規表現用のクラスをオープンしておく。
PerlRegEx:= TPerlRegEx.Create;
try
SearchOption := TSearchOption.soTopDirectoryOnly;
SearchFileMask := FPurgeMockParams.FileMask;
if FPurgeMockParams.UseRegularExpression then
begin
PerlRegEx.RegEx := SearchFileMask;
SearchFileMask := '*.*';
end;
try
LList := SearchDir.GetFiles(FPurgeMockParams.FTargetDir,SearchFileMask, SearchOption);
FPurgeMockDataSet.Active := true;
for FileFullName in LList do
begin
CanAddList := true;
if FPurgeMockParams.UseRegularExpression then
begin
FileName := ExtractFileName(FileFullName);
PerlRegEx.Subject := FileName;
CanAddList := PerlRegEx.Match;
end;
if CanAddList then
begin
//パージ対象リストに追加
FPurgeMockDataSet.Append;
FPurgeMockDataSet.FieldByName('FileName').AsString := FileFullName;
if FPurgeMockParams.FPurgeTimeStamp = ptCreate then
begin
FPurgeMockDataSet.FieldByName('TimeStamp').AsDateTime := PurgeFile.GetCreationTime(FileFullName);
end
else
begin
FPurgeMockDataSet.FieldByName('TimeStamp').AsDateTime := PurgeFile.GetLastAccessTime(FileFullName);
end;
FPurgeMockDataSet.Post;
end;
end;
Result := FPurgeMockDataSet.RecordCount;
except
Result := -1;
end;
finally
if Assigned(PerlRegEx) then PerlRegEx.Free;
end;
end;
function TPuregMock.ExecPurge: Integer;
var
DeleteCount : integer;
DeleteFileName : string;
PurgeFile : TFile;
begin
DeleteCount := 0;
try
FPurgeMockDataSet.Active := true;
FPurgeMockDataSet.First;
while not(FPurgeMockDataSet.Eof) do
begin
DeleteFileName := FPurgeMockDataSet.FieldByName('FileName').AsString;
PurgeFile.Delete(DeleteFileName);
inc(DeleteCount);
//レコードをDeleteした場合は、Next不要なので注意
FPurgeMockDataSet.Delete;
if FPurgeMockDataSet.RecordCount <= FPurgeMockParams.LeavingGenerations then Break;
end;
Result := DeleteCount;
Except
Result := -1;
end;
end;
function TryParseCmdLineSw(ParameterString : String;
Sw : Array of String;
var ParamValue : String;
IgnoreCase: Boolean) : boolean;
var
i : integer;
begin
Result := false;
if Length(Sw) = 0 then
begin
//SW指定がない場合はそのままの文字列を返す
ParamValue := ParameterString;
Result := true;
end
else
begin
for i := low(Sw) to high(Sw) do
begin
if IgnoreCase then
begin
if StartsText(Sw[i],ParameterString) then
begin
Result := true;
ParamValue := ReplaceText(ParameterString,Sw[i],'');
Break;
end;
end
else
begin
if StartsStr(Sw[i],ParameterString) then
begin
Result := true;
ParamValue := ReplaceStr(ParameterString,Sw[i],'');
Break;
end;
end;
end;
end;
end;
end.

unit PurgeMockImp;

interface

uses
  SysUtils
 ,DB
  ,DBClient
  ;

type
  TPurgeTimeStamp = (ptCreate, ptUpdate);

  TPurgeMockParams = class
  private
    FTargetDir: String;
    FUseRegularExpression: Boolean;
    FFileMask: String;
    FLeavingGenerations: Integer;
    FPurgeTimeStamp: TPurgeTimeStamp;
    procedure SetTargetDir(val: String);
    procedure SetUseRegularExpression(val: Boolean);
    procedure SetFileMask(val: String);
    procedure SetLeavingGenerations(val: Integer);
    procedure SetPurgeTimeStamp(val: TPurgeTimeStamp);
  public
    property TargetDir: String read FTargetDir write SetTargetDir;
    property UseRegularExpression: Boolean read FUseRegularExpression
      write SetUseRegularExpression;
    property FileMask: String read FFileMask write SetFileMask;
    property LeavingGenerations: Integer read FLeavingGenerations
      write SetLeavingGenerations;
    property PurgeTimeStamp: TPurgeTimeStamp read FPurgeTimeStamp
      write SetPurgeTimeStamp;
    procedure Init(ExePath: String);
  procedure SetPurgeParam(PurgeParam : String);
  end;

  TPuregMock = class
  public
    constructor Create(Params: TPurgeMockParams);
    function Purge: Integer;
    destructor Destroy; override;
  strict private
    FPurgeMockParams: TPurgeMockParams;
    FPurgeMockDataSet : TClientDataSet;
    function MakePurgeFileList: Integer;
    function ExecPurge: Integer;
    function CreatePurgeDataSet : TClientDataSet;
  end;

  function TryParseCmdLineSw(ParameterString : String; Sw : Array of String; var ParamValue : String; IgnoreCase: Boolean = true) : boolean;

implementation

Uses
   StrUtils
  ,IOUtils
  ,Types
  ,RegularExpressionsCore
  ;

procedure TPurgeMockParams.SetTargetDir(val: String);
begin
  FTargetDir := val;
end;

procedure TPurgeMockParams.SetUseRegularExpression(val: Boolean);
begin
  FUseRegularExpression := val;
end;

procedure TPurgeMockParams.Init(ExePath: String);
begin

 FTargetDir := ExtractFileDir(ExePath);
 FUseRegularExpression := false;
 FileMask := '*.*';
 FLeavingGenerations := 1;
 FPurgeTimeStamp := ptUpdate;

end;

procedure TPurgeMockParams.SetFileMask(val: String);
begin
  FFileMask := val
end;

procedure TPurgeMockParams.SetLeavingGenerations(val: Integer);
begin
 if Val >= 0 then
  begin
   FLeavingGenerations := val;
  end
  else
  begin
   FLeavingGenerations := 0;
  end;
end;

procedure TPurgeMockParams.SetPurgeParam(PurgeParam: String);
var
  ValueStr : String;
begin

 if TryParseCmdLineSw(PurgeParam,['/D:','-D:'],ValueStr) then
  begin
   FTargetDir := ValueStr;
    Exit;
  end;

 if TryParseCmdLineSw(PurgeParam,['/U:','-U:'],ValueStr) then
  begin
   FUseRegularExpression := true;
    Exit;
  end;

 if TryParseCmdLineSw(PurgeParam,['/G:','-G:'],ValueStr) then
  begin
   LeavingGenerations := StrToIntDef(ValueStr,1);
    Exit;
  end;

 if TryParseCmdLineSw(PurgeParam,['/T:','-T:'],ValueStr) then
  begin
   FPurgeTimeStamp := ptCreate;
    Exit;
  end;

 if TryParseCmdLineSw(PurgeParam,[],ValueStr) then
  begin
    FFileMask := ValueStr;
    Exit;
  end;

end;

procedure TPurgeMockParams.SetPurgeTimeStamp(val: TPurgeTimeStamp);
begin
  FPurgeTimeStamp := val;
end;

constructor TPuregMock.Create(Params: TPurgeMockParams);
begin
  inherited Create;
  FPurgeMockParams := Params;
end;

function TPuregMock.Purge: Integer;
begin

  Result := -1;

 FPurgeMockDataSet := CreatePurgeDataSet;
  if Assigned(FPurgeMockDataSet) then
  begin
    if MakePurgeFileList > 0 then
    begin
      Result := ExecPurge;
    end;
    FPurgeMockDataSet.EmptyDataSet;
    FPurgeMockDataSet.Active := false;
    FPurgeMockDataSet.Free;
  end;

end;

function TPuregMock.CreatePurgeDataSet: TClientDataSet;
var
 PurgeDataSet : TClientDataSet;
 FD : TFieldDef;
begin
 PurgeDataSet := TClientDataSet.Create(nil);
  try
    try
   FD := PurgeDataSet.FieldDefs.AddFieldDef;
      FD.Name := 'FileName';
      FD.DataType := ftString;
      FD.Size := 1024;

   FD := PurgeDataSet.FieldDefs.AddFieldDef;
      FD.Name := 'TimeStamp';
      FD.DataType := ftDatetime;

      PurgeDataSet.CreateDataSet;
      PurgeDataSet.AddIndex('Purge_Idx','TimeStamp;FileName',[]);
      PurgeDataSet.IndexName := 'Purge_Idx';

    Except
     if Assigned(PurgeDataSet) then PurgeDataSet.Free;
      PurgeDataSet := nil;
    end;
  finally
   Result := PurgeDataSet;
  end;
end;

destructor TPuregMock.Destroy;
begin
  if Assigned(FPurgeMockParams) then
  begin
    FPurgeMockParams := nil;
  end;

  inherited Destroy;
end;

function TPuregMock.MakePurgeFileList: Integer;
var
 SearchOption: TSearchOption;
 SearchDir : TDirectory;
  SearchFileMask : String;
  LList: TStringDynArray;
  FileFullName,FileName : String;
  CanAddList : Boolean;
  PerlRegEx: TPerlRegEx;
  PurgeFile : TFile;

begin

  Result := 0;

  //使っても使わなくても正規表現用のクラスをオープンしておく。
  PerlRegEx:= TPerlRegEx.Create;
  try
    SearchOption := TSearchOption.soTopDirectoryOnly;
    SearchFileMask := FPurgeMockParams.FileMask;


    if FPurgeMockParams.UseRegularExpression then
    begin
      PerlRegEx.RegEx := SearchFileMask;
      SearchFileMask := '*.*';
    end;

    try
      LList := SearchDir.GetFiles(FPurgeMockParams.FTargetDir,SearchFileMask, SearchOption);
      FPurgeMockDataSet.Active := true;
      for FileFullName in LList do
      begin
        CanAddList := true;
        if FPurgeMockParams.UseRegularExpression then
        begin
          FileName := ExtractFileName(FileFullName);
          PerlRegEx.Subject := FileName;
          CanAddList := PerlRegEx.Match;
        end;

        if CanAddList then
        begin
          //パージ対象リストに追加
          FPurgeMockDataSet.Append;
          FPurgeMockDataSet.FieldByName('FileName').AsString := FileFullName;
          if FPurgeMockParams.FPurgeTimeStamp = ptCreate then
          begin
           FPurgeMockDataSet.FieldByName('TimeStamp').AsDateTime := PurgeFile.GetCreationTime(FileFullName);
          end
          else
          begin
           FPurgeMockDataSet.FieldByName('TimeStamp').AsDateTime := PurgeFile.GetLastAccessTime(FileFullName);
          end;
          FPurgeMockDataSet.Post;
        end;
      end;
      Result := FPurgeMockDataSet.RecordCount;

    except
      Result := -1;
    end;
  finally
  if Assigned(PerlRegEx) then PerlRegEx.Free;

  end;
end;

function TPuregMock.ExecPurge: Integer;
var
 DeleteCount : integer;
  DeleteFileName : string;
  PurgeFile : TFile;
begin
  DeleteCount := 0;

  try
    FPurgeMockDataSet.Active := true;
    FPurgeMockDataSet.First;

    while not(FPurgeMockDataSet.Eof) do
    begin
      DeleteFileName := FPurgeMockDataSet.FieldByName('FileName').AsString;
      PurgeFile.Delete(DeleteFileName);
      inc(DeleteCount);

      //レコードをDeleteした場合は、Next不要なので注意
      FPurgeMockDataSet.Delete;
      if FPurgeMockDataSet.RecordCount <= FPurgeMockParams.LeavingGenerations then Break;
    end;
   Result := DeleteCount;

  Except
   Result := -1;
  end;
end;

function TryParseCmdLineSw(ParameterString : String;
                           Sw : Array of String;
                           var ParamValue : String;
                           IgnoreCase: Boolean) : boolean;
var
 i : integer;
begin

 Result := false;

  if Length(Sw) = 0 then
  begin
   //SW指定がない場合はそのままの文字列を返す
   ParamValue := ParameterString;
    Result := true;
  end
  else
  begin
   for i := low(Sw) to high(Sw) do
    begin
      if IgnoreCase then
      begin
        if StartsText(Sw[i],ParameterString) then
        begin
          Result := true;
          ParamValue := ReplaceText(ParameterString,Sw[i],'');
          Break;
        end;
      end
      else
      begin
        if StartsStr(Sw[i],ParameterString) then
        begin
          Result := true;
          ParamValue := ReplaceStr(ParameterString,Sw[i],'');
          Break;
        end;
      end;
    end;
  end;

end;

end.

サービスの起動と停止

現在、進行中の案件で、サービスの再起動を定期的に行う必要が
あるので、Delphiでできるかどうか調べてみた。

Delphi PrismではdotNetFreameworkに標準で用意されたクラスが使えるので
簡単だが、Delphi(Win32)では用意されていないみたいだ。

さらに調べたところ、Jedi Code Library(Jcl)には、サービスを扱うクラス
(TJclSCManager,TJclNTService)が用意されていることを知ったので、
実際に検証してみた。

以下、検証用に作ったサンプル（サービスの列挙と指定したサービスの
停止と起動）です。

view plain print ?

unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
ListBox1: TListBox;
LabeledEdit1: TLabeledEdit;
Button2: TButton;
Button3: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
private
{ Private 宣言 }
public
{ Public 宣言 }
end;
var
Form1: TForm1;
implementation
uses
JclSvcCtrl
, TypInfo
;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
SvcMgr : TJclSCManager;
i : Integer;
begin
//
SvcMgr := TJclSCManager.Create();
try
SvcMgr.Refresh(true);
ListBox1.Clear;
for i := 0 to SvcMgr.ServiceCount -1 do
begin
ListBox1.Items.Add(SvcMgr.Services[i].ServiceName);
end;
finally
SvcMgr.Free;
end;
end;
procedure TForm1.Button3Click(Sender: TObject);
var
SvcMgr : TJclSCManager;
Svc : TJclNTService;
begin
//
//if True then
SvcMgr := TJclSCManager.Create();
try
SvcMgr.Refresh(true);
if (SvcMgr.FindService(LabeledEdit1.Text,Svc)) Then
begin
if TComponent(Sender).Tag = 1 then
begin
Svc.Start;
end
else
begin
Svc.Stop;
end;
Label1.Caption := GetEnumName(TypeInfo(TJclServiceState),Ord(Svc.ServiceState)) ;
end;
finally
SvcMgr.Free;
end;
end;
procedure TForm1.ListBox1Click(Sender: TObject);
var
SvcMgr : TJclSCManager;
Svc : TJclNTService;
begin
if ListBox1.ItemIndex >=0 then
begin
LabeledEdit1.Text := ListBox1.Items.Strings[ListBox1.ItemIndex];
SvcMgr := TJclSCManager.Create();
try
SvcMgr.Refresh(true);
if (SvcMgr.FindService(LabeledEdit1.Text,Svc)) Then
begin
Label1.Caption := GetEnumName(TypeInfo(TJclServiceState),Ord(Svc.ServiceState));
end;
finally
SvcMgr.Free;
end;
end;
end;
end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    ListBox1: TListBox;
    LabeledEdit1: TLabeledEdit;
    Button2: TButton;
    Button3: TButton;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
    JclSvcCtrl
  , TypInfo
  ;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  SvcMgr : TJclSCManager;
  i : Integer;
begin
//
  SvcMgr := TJclSCManager.Create();

  try
    SvcMgr.Refresh(true);
    ListBox1.Clear;
    for i := 0 to SvcMgr.ServiceCount -1 do
    begin
      ListBox1.Items.Add(SvcMgr.Services[i].ServiceName);
    end;


  finally
    SvcMgr.Free;
  end;

end;

procedure TForm1.Button3Click(Sender: TObject);
var
  SvcMgr : TJclSCManager;
  Svc : TJclNTService;
begin
//
  //if True then
  SvcMgr := TJclSCManager.Create();
  try
    SvcMgr.Refresh(true);
    if (SvcMgr.FindService(LabeledEdit1.Text,Svc)) Then
    begin
      if TComponent(Sender).Tag = 1 then
      begin
        Svc.Start;
      end
      else
      begin
        Svc.Stop;
      end;
      Label1.Caption := GetEnumName(TypeInfo(TJclServiceState),Ord(Svc.ServiceState)) ;
    end;
  finally
    SvcMgr.Free;
  end;


end;

procedure TForm1.ListBox1Click(Sender: TObject);
var
  SvcMgr : TJclSCManager;
  Svc : TJclNTService;
begin
  if ListBox1.ItemIndex >=0 then
  begin
    LabeledEdit1.Text := ListBox1.Items.Strings[ListBox1.ItemIndex];
    SvcMgr := TJclSCManager.Create();
    try
      SvcMgr.Refresh(true);
      if (SvcMgr.FindService(LabeledEdit1.Text,Svc)) Then
      begin
        Label1.Caption := GetEnumName(TypeInfo(TJclServiceState),Ord(Svc.ServiceState));
      end;
    finally
      SvcMgr.Free;
    end;

  end;

end;

end.

なお、jclには上記クラスを使用したサンプルプログラムがありますので詳細については
そちらを参照して下さい。

2010年11月2日火曜日

JvScheduledEventsを試してみる。

仕事で、とあるプロセスを定刻起動する必要があった。

ＯＳ標準のタスクスケジューラを使用してもよっかったが
起動できるのがバッチファイルか単独のEXEになるので
もううちょっと処理を柔軟にしたいと思いJVCLの
JvScheduledEventsを試してみた。

TJvScheduledEventsは、画面でスケジューリングの
設定が可能であるが、今回は、スケジュールを外部
ファイルに持たせたかったので、プラグラム中で
設定することにした。

以下、サンプルで試したソース。

view plain print ?

unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, JvScheduledEvents, StdCtrls, ExtCtrls, ComCtrls, JvComponentBase,
JvCreateProcess;
type
TForm1 = class(TForm)
Button1: TButton;
DateTimePicker1: TDateTimePicker;
Label1: TLabel;
LabeledEdit1: TLabeledEdit;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private 宣言 }
FJvScheduledEvents : TJvScheduledEvents;
procedure JvScheduledEventsExecute(Sender: TJvEventCollectionItem;
const IsSnoozeEvent: Boolean);
public
{ Public 宣言 }
end;
var
Form1: TForm1;
implementation
uses
JclSchedule;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
EventItem : TJvEventCollectionItem;
IJclSched : JclSchedule.IJclSchedule;
IDaySched : IJclDailySchedule;
IDyaFreq : IJclScheduleDayFrequency;
begin
EventItem := FJvScheduledEvents.Events.Add;
IJclSched := EventItem.Schedule;
//イベントアイテムのスケジュール自体は、
//IJclScheduleで受けますが、実態はTJclScheduleで
//IJclScheduleのほか
//IJclScheduleDayFrequency,
//IJclDailySchedule,
//IJclWeeklySchedule,
//IJclMonthlySchedule,
//IJclYearlySchedule
//を継承しています。
IJclSched.RecurringType := srkDaily;
IDaySched := (IJclSched as IJclDailySchedule);
if Assigned(IDaySched) then
begin
//毎日実行する場合は、EveryWeekDayをFalseにして
//間隔を1(日)にします。
IDaySched.EveryWeekDay := false;
IDaySched.Interval := 1;
end;
IDyaFreq := (IJclSched as IJclScheduleDayFrequency);
if Assigned(IDyaFreq) then
begin
IDyaFreq.StartTime := DateTimeToTimeStamp(Self.DateTimePicker1.Time).Time;
IDyaFreq.EndTime := IDyaFreq.StartTime;
IDyaFreq.Interval := 1;
end;
EventItem.Name := LabeledEdit1.Text;
EventItem.OnExecute := JvScheduledEventsExecute;
EventItem.Start;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FJvScheduledEvents := TJvScheduledEvents.Create(Self);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FJvScheduledEvents.Events.Clear;
FJvScheduledEvents.Free;
end;
procedure TForm1.JvScheduledEventsExecute(Sender: TJvEventCollectionItem;
const IsSnoozeEvent: Boolean);
var
JvCreateProcess: TJvCreateProcess;
begin
JvCreateProcess := TJvCreateProcess.Create(Self);
try
JvCreateProcess.CommandLine := Sender.Name;
JvCreateProcess.WaitForTerminate := true;
JvCreateProcess.Run;
finally
JvCreateProcess.Free;
end;
end;
end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, JvScheduledEvents, StdCtrls, ExtCtrls, ComCtrls, JvComponentBase,
  JvCreateProcess;

type
  TForm1 = class(TForm)
    Button1: TButton;
    DateTimePicker1: TDateTimePicker;
    Label1: TLabel;
    LabeledEdit1: TLabeledEdit;

    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    FJvScheduledEvents : TJvScheduledEvents;
    procedure JvScheduledEventsExecute(Sender: TJvEventCollectionItem;
              const IsSnoozeEvent: Boolean);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  JclSchedule;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  EventItem : TJvEventCollectionItem;
  IJclSched : JclSchedule.IJclSchedule;
  IDaySched : IJclDailySchedule;
  IDyaFreq : IJclScheduleDayFrequency;

begin
  EventItem := FJvScheduledEvents.Events.Add;
  IJclSched := EventItem.Schedule;

   //イベントアイテムのスケジュール自体は、
   //IJclScheduleで受けますが、実態はTJclScheduleで
   //IJclScheduleのほか
   //IJclScheduleDayFrequency,
   //IJclDailySchedule,
    //IJclWeeklySchedule,
   //IJclMonthlySchedule,
   //IJclYearlySchedule
   //を継承しています。

   IJclSched.RecurringType := srkDaily;

   IDaySched := (IJclSched as IJclDailySchedule);
   if Assigned(IDaySched) then
   begin
      //毎日実行する場合は、EveryWeekDayをFalseにして
      //間隔を1(日)にします。
      IDaySched.EveryWeekDay := false;
      IDaySched.Interval := 1;
   end;

   IDyaFreq := (IJclSched as IJclScheduleDayFrequency);
   if Assigned(IDyaFreq) then
   begin
      IDyaFreq.StartTime := DateTimeToTimeStamp(Self.DateTimePicker1.Time).Time;
      IDyaFreq.EndTime   := IDyaFreq.StartTime;
      IDyaFreq.Interval := 1;
   end;

   EventItem.Name := LabeledEdit1.Text;
   EventItem.OnExecute := JvScheduledEventsExecute;
   EventItem.Start;

end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FJvScheduledEvents := TJvScheduledEvents.Create(Self);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FJvScheduledEvents.Events.Clear;
  FJvScheduledEvents.Free;
end;

procedure TForm1.JvScheduledEventsExecute(Sender: TJvEventCollectionItem;
  const IsSnoozeEvent: Boolean);
var
  JvCreateProcess: TJvCreateProcess;
begin

  JvCreateProcess := TJvCreateProcess.Create(Self);
  try
    JvCreateProcess.CommandLine := Sender.Name;
    JvCreateProcess.WaitForTerminate := true;
    JvCreateProcess.Run;

  finally
    JvCreateProcess.Free;
  end;


end;

end.

ポイントは、以下の２つかと思います。

JclScheduleをUsesに加えることと
TJvEventCollectionItem.Scheduleの戻り値がIJclSchedule型であるが実態はTJclSchedule型でIJclScheduleのほかIJclScheduleDayFrequency,IJclDailySchedule,IJclWeeklySchedule,IJclMonthlySchedule,
IJclYearlyScheduleを継承していて設定したいスケジュールにあわせて適切にキャストする必要があること

今回のサンプルは、『ボタンを押したら指定した時刻にメモ帳を起動する』というタイマーで処理しても
十分なものですが、リフレクション、パッケージの動的ロードなどを使えば、もっと面白いことが
できそうな気がします。

登録: 投稿 (Atom)

Delphiッこ倶楽部東京出張所

2010年11月5日金曜日

StartsStr関数,EndsStr関数

2010年11月3日水曜日

Purgeもどき

サービスの起動と停止

2010年11月2日火曜日

JvScheduledEventsを試してみる。

Blogspot Syntax Highlighter

Google Analytics