プロセスの再起動

仕事で、プロセスを外部から強制的に再起動を
する必要があったのでとりあえずつくってみた。

停止させるプロセスは、仕様上一意性が保障されている
ので、コマンドライン引数に起動するプロセスの絶対パスを
与えて、そこからプロセスIDを求めています。

プロセスに停止メッセージ（メインウインドウのクローズ）を
ポストし、5秒まっても終了していなかったら
強制終了しています。

プロセスの起動には、JvCreateProcessコンポーネントを
使っています。
このコンポーネントは、非常に便利ですね。

view plainprint?

1. program RestartProcess;  
2.   
3. {$APPTYPE CONSOLE}  
4.   
5. uses  
6.   SysUtils,Windows,TLHELP32,Messages,JvCreateProcess;  
7.   
8.   
9. function GetProcessFromName(ProcessName :String) : Cardinal;  
10. var  
11.    ProcEntry : TProcessEntry32;  
12.    SanpshotHandle : THandle;  
13.    ListProcName : String;  
14.   
15. begin  
16.    //Toolhelp32を使用する例  
17.   Result := 0;  
18.    SanpshotHandle := TlHelp32.CreateToolhelp32Snapshot(TlHelp32.TH32CS_SNAPPROCESS,0);  
19.    if (SanpshotHandle <> -1) then  
20.       begin  
21.          ProcEntry.dwSize := Sizeof(TProcessEntry32W);  
22.          if (TlHelp32.Process32First(SanpshotHandle,ProcEntry)) Then  
23.          begin  
24.             repeat  
25.               ListProcName := ProcEntry.szExeFile;  
26.               if CompareText(ListProcName,ProcessName) = 0 then  
27.               begin  
28.                  Result := ProcEntry.th32ProcessID;  
29.               end;  
30.               //WriteLn(ListProcName);  
31.           until (TlHelp32.Process32Next(SanpshotHandle,ProcEntry) = false);  
32.        end;  
33.     end;  
34.     CloseHandle(SanpshotHandle);  
35.   
36. end;  
37.   
38.   
39. function EnumWindowsProc(hwindow :HWnd; lparam :LPARAM):BOOL; stdcall;  
40. var  
41.   ProcessID : Cardinal;  
42.   ThreadID : Cardinal;  
43. begin  
44.   
45.    Result := True;  
46.   
47.    ThreadID := GetWindowThreadProcessId(hwindow, ProcessID);  
48.   
49.    If (ProcessID = lParam) Then  
50.    begin  
51.       PostMessage(hwindow, WM_CLOSE, 0, 0);  
52.      Result := true;  
53.    End;  
54. End;  
55.   
56.   
57. function SendClose(ProcID : Cardinal) : Boolean;  
58. begin  
59.    Result := EnumWindows(@EnumWindowsProc, ProcID)  
60. End;  
61.   
62. function StopProcess(ProcessName : String; Force : Boolean = false) : Integer;  
63. var  
64.    ProcessID : Cardinal;  
65.   hProcess : THandle;  
66. begin  
67.    ProcessID := GetProcessFromName(ProcessName);  
68.   if ProcessID = 0 then  
69.   begin  
70.      Result := -1;  
71.   end  
72.   else  
73.   begin  
74.      if (ProcessID > 0) Then  
75.      begin  
76.         if Force then  
77.         begin  
78.            hProcess := OpenProcess(PROCESS_TERMINATE, False, ProcessID);  
79.            TerminateProcess(hProcess , 0 );  
80.            CloseHandle(hProcess);  
81.            Result := 0;  
82.         end  
83.         else  
84.         begin  
85.            Result := 1;  
86.            if SendClose(ProcessID) then  
87.            begin  
88.               Result := 0;  
89.            end;  
90.         end;  
91.      end;  
92.   end;  
93. end;  
94.   
95. var  
96.    StopResult : Integer;  
97.    JvCreateProcess: TJvCreateProcess;  
98.   ExeName : String;  
99.   ProcessID : Cardinal;  
100.   
101. begin  
102.   try  
103.   { TODO -oUser -cConsole Main : ここにコードを記述してください }  
104.   
105.      if ParamCount > 0 then  
106.      begin  
107.         ExeName := ExtractFileName(ParamStr(1));  
108.          StopResult := StopProcess(ExeName);  
109.   
110.         //五秒まって停止イしたかどうかを確認する  
111.         Sleep(5000);  
112.   
113.         ProcessID := GetProcessFromName(ExeName);  
114.   
115.         //プロセスが正常に停止できなかったので' +  
116.         //強制終了する  
117.         if ProcessID > 0 Then  
118.         begin  
119.            StopResult := StopProcess(ExeName,true);  
120.            Sleep(10000);  
121.         end;  
122.   
123.   
124.         if StopResult <> 1 then  
125.         begin  
126.            JvCreateProcess := TJvCreateProcess.Create(nil);  
127.            try  
128.               JvCreateProcess.CommandLine := ParamStr(1);  
129.               JvCreateProcess.WaitForTerminate := false;  
130.               JvCreateProcess.Run;  
131.            finally  
132.               JvCreateProcess.Free;  
133.             end;  
134.         end;  
135.      end;  
136.      //ReadLn;  
137.   except  
138.     on E:Exception do  
139.       Writeln(E.Classname, ': ', E.Message);  
140.   end;  
141. end.  

program RestartProcess;

{$APPTYPE CONSOLE}

uses
  SysUtils,Windows,TLHELP32,Messages,JvCreateProcess;


function GetProcessFromName(ProcessName :String) : Cardinal;
var
   ProcEntry : TProcessEntry32;
   SanpshotHandle : THandle;
   ListProcName : String;

begin
   //Toolhelp32を使用する例
  Result := 0;
   SanpshotHandle := TlHelp32.CreateToolhelp32Snapshot(TlHelp32.TH32CS_SNAPPROCESS,0);
   if (SanpshotHandle <> -1) then
      begin
         ProcEntry.dwSize := Sizeof(TProcessEntry32W);
         if (TlHelp32.Process32First(SanpshotHandle,ProcEntry)) Then
         begin
            repeat
              ListProcName := ProcEntry.szExeFile;
              if CompareText(ListProcName,ProcessName) = 0 then
              begin
                 Result := ProcEntry.th32ProcessID;
              end;
              //WriteLn(ListProcName);
          until (TlHelp32.Process32Next(SanpshotHandle,ProcEntry) = false);
       end;
    end;
    CloseHandle(SanpshotHandle);

end;


function EnumWindowsProc(hwindow :HWnd; lparam :LPARAM):BOOL; stdcall;
var
  ProcessID : Cardinal;
  ThreadID : Cardinal;
begin

   Result := True;

   ThreadID := GetWindowThreadProcessId(hwindow, ProcessID);

   If (ProcessID = lParam) Then
   begin
      PostMessage(hwindow, WM_CLOSE, 0, 0);
     Result := true;
   End;
End;


function SendClose(ProcID : Cardinal) : Boolean;
begin
   Result := EnumWindows(@EnumWindowsProc, ProcID)
End;

function StopProcess(ProcessName : String; Force : Boolean = false) : Integer;
var
   ProcessID : Cardinal;
  hProcess : THandle;
begin
   ProcessID := GetProcessFromName(ProcessName);
  if ProcessID = 0 then
  begin
     Result := -1;
  end
  else
  begin
     if (ProcessID > 0) Then
     begin
        if Force then
        begin
           hProcess := OpenProcess(PROCESS_TERMINATE, False, ProcessID);
           TerminateProcess(hProcess , 0 );
           CloseHandle(hProcess);
           Result := 0;
        end
        else
        begin
           Result := 1;
           if SendClose(ProcessID) then
           begin
              Result := 0;
           end;
        end;
     end;
  end;
end;

var
   StopResult : Integer;
   JvCreateProcess: TJvCreateProcess;
  ExeName : String;
  ProcessID : Cardinal;

begin
  try
  { TODO -oUser -cConsole Main : ここにコードを記述してください }

     if ParamCount > 0 then
     begin
        ExeName := ExtractFileName(ParamStr(1));
         StopResult := StopProcess(ExeName);

        //五秒まって停止イしたかどうかを確認する
        Sleep(5000);

        ProcessID := GetProcessFromName(ExeName);

        //プロセスが正常に停止できなかったので' +
        //強制終了する
        if ProcessID > 0 Then
        begin
           StopResult := StopProcess(ExeName,true);
           Sleep(10000);
        end;


        if StopResult <> 1 then
        begin
           JvCreateProcess := TJvCreateProcess.Create(nil);
           try
              JvCreateProcess.CommandLine := ParamStr(1);
              JvCreateProcess.WaitForTerminate := false;
              JvCreateProcess.Run;
           finally
              JvCreateProcess.Free;
            end;
        end;
     end;
     //ReadLn;
  except
    on E:Exception do
      Writeln(E.Classname, ': ', E.Message);
  end;
end.

StartsStr関数,EndsStr関数

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

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

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

以下、サンプル

view plainprint?

1. WriteLn('大文字小文字区別して比較');  
2.       if StartsStr('so','So What ?') then  
3.       begin  
4.        WriteLn('はじまるよ')  
5.       end  
6.       else  
7.       begin  
8.        WriteLn('はじまらない')  
9.       end;  
10.   
11.       WriteLn('大文字小文字区別なしに比較');  
12.       if StartsText('so','So what ?') then  
13.       begin  
14.        WriteLn('はじまるよ')  
15.       end  
16.       else  
17.       begin  
18.        WriteLn('はじまらない')  
19.       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には
あったようだけど

Purgeもどき

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

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

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

使い方は、

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

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

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

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

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

まずはメイン。

view plainprint?

1. program PurgeMock;  
2.   
3. {$APPTYPE CONSOLE}  
4.   
5. uses  
6.   SysUtils,  
7.   PurgeMockImp in 'PurgeMockImp.pas',  
8.   MidasLib  
9.   ;  
10.   
11. function CreatePurgeMockParams : TPurgeMockParams;  
12. var  
13.   PurgeMockParams : TPurgeMockParams;  
14.  i : Integer;  
15. begin  
16.   
17.   PurgeMockParams := TPurgeMockParams.Create;  
18.   try  
19.     try  
20.    PurgeMockParams.Init(Paramstr(0));  
21.    for i := 1 to ParamCount -1 do  
22.       begin  
23.        PurgeMockParams.SetPurgeParam(Paramstr(i));  
24.       end;  
25.     except  
26.       PurgeMockParams.Free;  
27.       PurgeMockParams := nil;  
28.     end;  
29.   
30.   finally  
31.     Result := PurgeMockParams;  
32.   end;  
33.   
34. end;  
35.   
36. var  
37.   PurgeMockParams : TPurgeMockParams;  
38.   DoPurgeMock     : TPuregMock;  
39.   Ret : Integer;  
40.   
41. begin  
42.   try  
43.     { TODO -oUser -cConsole メイン : ここにコードを記述してください }  
44.     PurgeMockParams := CreatePurgeMockParams;  
45.     if Assigned(PurgeMockParams) then  
46.     begin  
47.       DoPurgeMock := TPuregMock.Create(PurgeMockParams);  
48.       try  
49.         Ret := DoPurgeMock.Purge;  
50.       finally  
51.         DoPurgeMock.Free;  
52.       end;  
53.       PurgeMockParams.Free;  
54.     end;  
55.   
56.   
57.   except  
58.     on E: Exception do  
59.       Writeln(E.ClassName, ': ', E.Message);  
60.   end;  
61. 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 plainprint?

1. unit PurgeMockImp;  
2.   
3. interface  
4.   
5. uses  
6.   SysUtils  
7.  ,DB  
8.   ,DBClient  
9.   ;  
10.   
11. type  
12.   TPurgeTimeStamp = (ptCreate, ptUpdate);  
13.   
14.   TPurgeMockParams = class  
15.   private  
16.     FTargetDir: String;  
17.     FUseRegularExpression: Boolean;  
18.     FFileMask: String;  
19.     FLeavingGenerations: Integer;  
20.     FPurgeTimeStamp: TPurgeTimeStamp;  
21.     procedure SetTargetDir(val: String);  
22.     procedure SetUseRegularExpression(val: Boolean);  
23.     procedure SetFileMask(val: String);  
24.     procedure SetLeavingGenerations(val: Integer);  
25.     procedure SetPurgeTimeStamp(val: TPurgeTimeStamp);  
26.   public  
27.     property TargetDir: String read FTargetDir write SetTargetDir;  
28.     property UseRegularExpression: Boolean read FUseRegularExpression  
29.       write SetUseRegularExpression;  
30.     property FileMask: String read FFileMask write SetFileMask;  
31.     property LeavingGenerations: Integer read FLeavingGenerations  
32.       write SetLeavingGenerations;  
33.     property PurgeTimeStamp: TPurgeTimeStamp read FPurgeTimeStamp  
34.       write SetPurgeTimeStamp;  
35.     procedure Init(ExePath: String);  
36.   procedure SetPurgeParam(PurgeParam : String);  
37.   end;  
38.   
39.   TPuregMock = class  
40.   public  
41.     constructor Create(Params: TPurgeMockParams);  
42.     function Purge: Integer;  
43.     destructor Destroy; override;  
44.   strict private  
45.     FPurgeMockParams: TPurgeMockParams;  
46.     FPurgeMockDataSet : TClientDataSet;  
47.     function MakePurgeFileList: Integer;  
48.     function ExecPurge: Integer;  
49.     function CreatePurgeDataSet : TClientDataSet;  
50.   end;  
51.   
52.   function TryParseCmdLineSw(ParameterString : String; Sw : Array of String; var ParamValue : String; IgnoreCase: Boolean = true) : boolean;  
53.   
54. implementation  
55.   
56. Uses  
57.    StrUtils  
58.   ,IOUtils  
59.   ,Types  
60.   ,RegularExpressionsCore  
61.   ;  
62.   
63. procedure TPurgeMockParams.SetTargetDir(val: String);  
64. begin  
65.   FTargetDir := val;  
66. end;  
67.   
68. procedure TPurgeMockParams.SetUseRegularExpression(val: Boolean);  
69. begin  
70.   FUseRegularExpression := val;  
71. end;  
72.   
73. procedure TPurgeMockParams.Init(ExePath: String);  
74. begin  
75.   
76.  FTargetDir := ExtractFileDir(ExePath);  
77.  FUseRegularExpression := false;  
78.  FileMask := '*.*';  
79.  FLeavingGenerations := 1;  
80.  FPurgeTimeStamp := ptUpdate;  
81.   
82. end;  
83.   
84. procedure TPurgeMockParams.SetFileMask(val: String);  
85. begin  
86.   FFileMask := val  
87. end;  
88.   
89. procedure TPurgeMockParams.SetLeavingGenerations(val: Integer);  
90. begin  
91.  if Val >= 0 then  
92.   begin  
93.    FLeavingGenerations := val;  
94.   end  
95.   else  
96.   begin  
97.    FLeavingGenerations := 0;  
98.   end;  
99. end;  
100.   
101. procedure TPurgeMockParams.SetPurgeParam(PurgeParam: String);  
102. var  
103.   ValueStr : String;  
104. begin  
105.   
106.  if TryParseCmdLineSw(PurgeParam,['/D:','-D:'],ValueStr) then  
107.   begin  
108.    FTargetDir := ValueStr;  
109.     Exit;  
110.   end;  
111.   
112.  if TryParseCmdLineSw(PurgeParam,['/U:','-U:'],ValueStr) then  
113.   begin  
114.    FUseRegularExpression := true;  
115.     Exit;  
116.   end;  
117.   
118.  if TryParseCmdLineSw(PurgeParam,['/G:','-G:'],ValueStr) then  
119.   begin  
120.    LeavingGenerations := StrToIntDef(ValueStr,1);  
121.     Exit;  
122.   end;  
123.   
124.  if TryParseCmdLineSw(PurgeParam,['/T:','-T:'],ValueStr) then  
125.   begin  
126.    FPurgeTimeStamp := ptCreate;  
127.     Exit;  
128.   end;  
129.   
130.  if TryParseCmdLineSw(PurgeParam,[],ValueStr) then  
131.   begin  
132.     FFileMask := ValueStr;  
133.     Exit;  
134.   end;  
135.   
136. end;  
137.   
138. procedure TPurgeMockParams.SetPurgeTimeStamp(val: TPurgeTimeStamp);  
139. begin  
140.   FPurgeTimeStamp := val;  
141. end;  
142.   
143. constructor TPuregMock.Create(Params: TPurgeMockParams);  
144. begin  
145.   inherited Create;  
146.   FPurgeMockParams := Params;  
147. end;  
148.   
149. function TPuregMock.Purge: Integer;  
150. begin  
151.   
152.   Result := -1;  
153.   
154.  FPurgeMockDataSet := CreatePurgeDataSet;  
155.   if Assigned(FPurgeMockDataSet) then  
156.   begin  
157.     if MakePurgeFileList > 0 then  
158.     begin  
159.       Result := ExecPurge;  
160.     end;  
161.     FPurgeMockDataSet.EmptyDataSet;  
162.     FPurgeMockDataSet.Active := false;  
163.     FPurgeMockDataSet.Free;  
164.   end;  
165.   
166. end;  
167.   
168. function TPuregMock.CreatePurgeDataSet: TClientDataSet;  
169. var  
170.  PurgeDataSet : TClientDataSet;  
171.  FD : TFieldDef;  
172. begin  
173.  PurgeDataSet := TClientDataSet.Create(nil);  
174.   try  
175.     try  
176.    FD := PurgeDataSet.FieldDefs.AddFieldDef;  
177.       FD.Name := 'FileName';  
178.       FD.DataType := ftString;  
179.       FD.Size := 1024;  
180.   
181.    FD := PurgeDataSet.FieldDefs.AddFieldDef;  
182.       FD.Name := 'TimeStamp';  
183.       FD.DataType := ftDatetime;  
184.   
185.       PurgeDataSet.CreateDataSet;  
186.       PurgeDataSet.AddIndex('Purge_Idx','TimeStamp;FileName',[]);  
187.       PurgeDataSet.IndexName := 'Purge_Idx';  
188.   
189.     Except  
190.      if Assigned(PurgeDataSet) then PurgeDataSet.Free;  
191.       PurgeDataSet := nil;  
192.     end;  
193.   finally  
194.    Result := PurgeDataSet;  
195.   end;  
196. end;  
197.   
198. destructor TPuregMock.Destroy;  
199. begin  
200.   if Assigned(FPurgeMockParams) then  
201.   begin  
202.     FPurgeMockParams := nil;  
203.   end;  
204.   
205.   inherited Destroy;  
206. end;  
207.   
208. function TPuregMock.MakePurgeFileList: Integer;  
209. var  
210.  SearchOption: TSearchOption;  
211.  SearchDir : TDirectory;  
212.   SearchFileMask : String;  
213.   LList: TStringDynArray;  
214.   FileFullName,FileName : String;  
215.   CanAddList : Boolean;  
216.   PerlRegEx: TPerlRegEx;  
217.   PurgeFile : TFile;  
218.   
219. begin  
220.   
221.   Result := 0;  
222.   
223.   //使っても使わなくても正規表現用のクラスをオープンしておく。  
224.   PerlRegEx:= TPerlRegEx.Create;  
225.   try  
226.     SearchOption := TSearchOption.soTopDirectoryOnly;  
227.     SearchFileMask := FPurgeMockParams.FileMask;  
228.   
229.   
230.     if FPurgeMockParams.UseRegularExpression then  
231.     begin  
232.       PerlRegEx.RegEx := SearchFileMask;  
233.       SearchFileMask := '*.*';  
234.     end;  
235.   
236.     try  
237.       LList := SearchDir.GetFiles(FPurgeMockParams.FTargetDir,SearchFileMask, SearchOption);  
238.       FPurgeMockDataSet.Active := true;  
239.       for FileFullName in LList do  
240.       begin  
241.         CanAddList := true;  
242.         if FPurgeMockParams.UseRegularExpression then  
243.         begin  
244.           FileName := ExtractFileName(FileFullName);  
245.           PerlRegEx.Subject := FileName;  
246.           CanAddList := PerlRegEx.Match;  
247.         end;  
248.   
249.         if CanAddList then  
250.         begin  
251.           //パージ対象リストに追加  
252.           FPurgeMockDataSet.Append;  
253.           FPurgeMockDataSet.FieldByName('FileName').AsString := FileFullName;  
254.           if FPurgeMockParams.FPurgeTimeStamp = ptCreate then  
255.           begin  
256.            FPurgeMockDataSet.FieldByName('TimeStamp').AsDateTime := PurgeFile.GetCreationTime(FileFullName);  
257.           end  
258.           else  
259.           begin  
260.            FPurgeMockDataSet.FieldByName('TimeStamp').AsDateTime := PurgeFile.GetLastAccessTime(FileFullName);  
261.           end;  
262.           FPurgeMockDataSet.Post;  
263.         end;  
264.       end;  
265.       Result := FPurgeMockDataSet.RecordCount;  
266.   
267.     except  
268.       Result := -1;  
269.     end;  
270.   finally  
271.   if Assigned(PerlRegEx) then PerlRegEx.Free;  
272.   
273.   end;  
274. end;  
275.   
276. function TPuregMock.ExecPurge: Integer;  
277. var  
278.  DeleteCount : integer;  
279.   DeleteFileName : string;  
280.   PurgeFile : TFile;  
281. begin  
282.   DeleteCount := 0;  
283.   
284.   try  
285.     FPurgeMockDataSet.Active := true;  
286.     FPurgeMockDataSet.First;  
287.   
288.     while not(FPurgeMockDataSet.Eof) do  
289.     begin  
290.       DeleteFileName := FPurgeMockDataSet.FieldByName('FileName').AsString;  
291.       PurgeFile.Delete(DeleteFileName);  
292.       inc(DeleteCount);  
293.   
294.       //レコードをDeleteした場合は、Next不要なので注意  
295.       FPurgeMockDataSet.Delete;  
296.       if FPurgeMockDataSet.RecordCount <= FPurgeMockParams.LeavingGenerations then Break;  
297.     end;  
298.    Result := DeleteCount;  
299.   
300.   Except  
301.    Result := -1;  
302.   end;  
303. end;  
304.   
305. function TryParseCmdLineSw(ParameterString : String;  
306.                            Sw : Array of String;  
307.                            var ParamValue : String;  
308.                            IgnoreCase: Boolean) : boolean;  
309. var  
310.  i : integer;  
311. begin  
312.   
313.  Result := false;  
314.   
315.   if Length(Sw) = 0 then  
316.   begin  
317.    //SW指定がない場合はそのままの文字列を返す  
318.    ParamValue := ParameterString;  
319.     Result := true;  
320.   end  
321.   else  
322.   begin  
323.    for i := low(Sw) to high(Sw) do  
324.     begin  
325.       if IgnoreCase then  
326.       begin  
327.         if StartsText(Sw[i],ParameterString) then  
328.         begin  
329.           Result := true;  
330.           ParamValue := ReplaceText(ParameterString,Sw[i],'');  
331.           Break;  
332.         end;  
333.       end  
334.       else  
335.       begin  
336.         if StartsStr(Sw[i],ParameterString) then  
337.         begin  
338.           Result := true;  
339.           ParamValue := ReplaceStr(ParameterString,Sw[i],'');  
340.           Break;  
341.         end;  
342.       end;  
343.     end;  
344.   end;  
345.   
346. end;  
347.   
348. 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 plainprint?

1. unit Unit1;  
2.   
3. interface  
4.   
5. uses  
6.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  
7.   Dialogs, StdCtrls, ExtCtrls;  
8.   
9. type  
10.   TForm1 = class(TForm)  
11.     Button1: TButton;  
12.     ListBox1: TListBox;  
13.     LabeledEdit1: TLabeledEdit;  
14.     Button2: TButton;  
15.     Button3: TButton;  
16.     Label1: TLabel;  
17.     procedure Button1Click(Sender: TObject);  
18.     procedure Button3Click(Sender: TObject);  
19.     procedure ListBox1Click(Sender: TObject);  
20.   private  
21.     { Private 宣言 }  
22.   public  
23.     { Public 宣言 }  
24.   end;  
25.   
26. var  
27.   Form1: TForm1;  
28.   
29. implementation  
30.   
31. uses  
32.     JclSvcCtrl  
33.   , TypInfo  
34.   ;  
35.   
36. {$R *.dfm}  
37.   
38. procedure TForm1.Button1Click(Sender: TObject);  
39. var  
40.   SvcMgr : TJclSCManager;  
41.   i : Integer;  
42. begin  
43. //  
44.   SvcMgr := TJclSCManager.Create();  
45.   
46.   try  
47.     SvcMgr.Refresh(true);  
48.     ListBox1.Clear;  
49.     for i := 0 to SvcMgr.ServiceCount -1 do  
50.     begin  
51.       ListBox1.Items.Add(SvcMgr.Services[i].ServiceName);  
52.     end;  
53.   
54.   
55.   finally  
56.     SvcMgr.Free;  
57.   end;  
58.   
59. end;  
60.   
61. procedure TForm1.Button3Click(Sender: TObject);  
62. var  
63.   SvcMgr : TJclSCManager;  
64.   Svc : TJclNTService;  
65. begin  
66. //  
67.   //if True then  
68.   SvcMgr := TJclSCManager.Create();  
69.   try  
70.     SvcMgr.Refresh(true);  
71.     if (SvcMgr.FindService(LabeledEdit1.Text,Svc)) Then  
72.     begin  
73.       if TComponent(Sender).Tag = 1 then  
74.       begin  
75.         Svc.Start;  
76.       end  
77.       else  
78.       begin  
79.         Svc.Stop;  
80.       end;  
81.       Label1.Caption := GetEnumName(TypeInfo(TJclServiceState),Ord(Svc.ServiceState)) ;  
82.     end;  
83.   finally  
84.     SvcMgr.Free;  
85.   end;  
86.   
87.   
88. end;  
89.   
90. procedure TForm1.ListBox1Click(Sender: TObject);  
91. var  
92.   SvcMgr : TJclSCManager;  
93.   Svc : TJclNTService;  
94. begin  
95.   if ListBox1.ItemIndex >=0 then  
96.   begin  
97.     LabeledEdit1.Text := ListBox1.Items.Strings[ListBox1.ItemIndex];  
98.     SvcMgr := TJclSCManager.Create();  
99.     try  
100.       SvcMgr.Refresh(true);  
101.       if (SvcMgr.FindService(LabeledEdit1.Text,Svc)) Then  
102.       begin  
103.         Label1.Caption := GetEnumName(TypeInfo(TJclServiceState),Ord(Svc.ServiceState));  
104.       end;  
105.     finally  
106.       SvcMgr.Free;  
107.     end;  
108.   
109.   end;  
110.   
111. end;  
112.   
113. 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には上記クラスを使用したサンプルプログラムがありますので詳細については
そちらを参照して下さい。

JvScheduledEventsを試してみる。

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

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

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

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

view plainprint?

1. unit Unit1;  
2.   
3. interface  
4.   
5. uses  
6.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  
7.   Dialogs, JvScheduledEvents, StdCtrls, ExtCtrls, ComCtrls, JvComponentBase,  
8.   JvCreateProcess;  
9.   
10. type  
11.   TForm1 = class(TForm)  
12.     Button1: TButton;  
13.     DateTimePicker1: TDateTimePicker;  
14.     Label1: TLabel;  
15.     LabeledEdit1: TLabeledEdit;  
16.   
17.     procedure FormCreate(Sender: TObject);  
18.     procedure FormDestroy(Sender: TObject);  
19.     procedure Button1Click(Sender: TObject);  
20.   private  
21.     { Private 宣言 }  
22.     FJvScheduledEvents : TJvScheduledEvents;  
23.     procedure JvScheduledEventsExecute(Sender: TJvEventCollectionItem;  
24.               const IsSnoozeEvent: Boolean);  
25.   public  
26.     { Public 宣言 }  
27.   end;  
28.   
29. var  
30.   Form1: TForm1;  
31.   
32. implementation  
33.   
34. uses  
35.   JclSchedule;  
36.   
37. {$R *.dfm}  
38.   
39. procedure TForm1.Button1Click(Sender: TObject);  
40. var  
41.   EventItem : TJvEventCollectionItem;  
42.   IJclSched : JclSchedule.IJclSchedule;  
43.   IDaySched : IJclDailySchedule;  
44.   IDyaFreq : IJclScheduleDayFrequency;  
45.   
46. begin  
47.   EventItem := FJvScheduledEvents.Events.Add;  
48.   IJclSched := EventItem.Schedule;  
49.   
50.    //イベントアイテムのスケジュール自体は、  
51.    //IJclScheduleで受けますが、実態はTJclScheduleで  
52.    //IJclScheduleのほか  
53.    //IJclScheduleDayFrequency,  
54.    //IJclDailySchedule,  
55.     //IJclWeeklySchedule,  
56.    //IJclMonthlySchedule,  
57.    //IJclYearlySchedule  
58.    //を継承しています。  
59.   
60.    IJclSched.RecurringType := srkDaily;  
61.   
62.    IDaySched := (IJclSched as IJclDailySchedule);  
63.    if Assigned(IDaySched) then  
64.    begin  
65.       //毎日実行する場合は、EveryWeekDayをFalseにして  
66.       //間隔を1(日)にします。  
67.       IDaySched.EveryWeekDay := false;  
68.       IDaySched.Interval := 1;  
69.    end;  
70.   
71.    IDyaFreq := (IJclSched as IJclScheduleDayFrequency);  
72.    if Assigned(IDyaFreq) then  
73.    begin  
74.       IDyaFreq.StartTime := DateTimeToTimeStamp(Self.DateTimePicker1.Time).Time;  
75.       IDyaFreq.EndTime   := IDyaFreq.StartTime;  
76.       IDyaFreq.Interval := 1;  
77.    end;  
78.   
79.    EventItem.Name := LabeledEdit1.Text;  
80.    EventItem.OnExecute := JvScheduledEventsExecute;  
81.    EventItem.Start;  
82.   
83. end;  
84.   
85. procedure TForm1.FormCreate(Sender: TObject);  
86. begin  
87.   FJvScheduledEvents := TJvScheduledEvents.Create(Self);  
88. end;  
89.   
90. procedure TForm1.FormDestroy(Sender: TObject);  
91. begin  
92.   FJvScheduledEvents.Events.Clear;  
93.   FJvScheduledEvents.Free;  
94. end;  
95.   
96. procedure TForm1.JvScheduledEventsExecute(Sender: TJvEventCollectionItem;  
97.   const IsSnoozeEvent: Boolean);  
98. var  
99.   JvCreateProcess: TJvCreateProcess;  
100. begin  
101.   
102.   JvCreateProcess := TJvCreateProcess.Create(Self);  
103.   try  
104.     JvCreateProcess.CommandLine := Sender.Name;  
105.     JvCreateProcess.WaitForTerminate := true;  
106.     JvCreateProcess.Run;  
107.   
108.   finally  
109.     JvCreateProcess.Free;  
110.   end;  
111.   
112.   
113. end;  
114.   
115. 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.

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

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

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

SQL Server のデータベースのテーブルとフィールド名を表示する。（その2)

Sql Server 2005以上であれば、システムカタログに対してクエリを発行することで
テーブル名とフィールド名のリストの取得ができます。
(詳細は、システムカタログのクエリのQandAページを参照)

クエリを発行できるということは、

程度の画面であればマスターリンクを使ってノンコーディング
（クエリーは組む必要はありますが）でテーブルとフィールドのリストを表示できます。

このへんがDelphiのすごいところですね。

以下、フォーム表示をテキスト表示したもの


object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 535
  ClientWidth = 727
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object PageControl1: TPageControl
    Left = 0
    Top = 0
    Width = 727
    Height = 535
    ActivePage = TabSheet2
    Align = alClient
    TabOrder = 0
    object TabSheet1: TTabSheet
      Caption = 'TabSheet1'
      object Label1: TLabel
        Left = 192
        Top = 88
        Width = 56
        Height = 13
        Caption = #12501#12451#12540#12523#12489#21517
      end
      object Label2: TLabel
        Left = 16
        Top = 88
        Width = 50
        Height = 13
        Caption = #12486#12540#12502#12523#21517
      end
      object Label3: TLabel
        Left = 552
        Top = 88
        Width = 56
        Height = 13
        Caption = #12501#12451#12540#12523#12489#21517
      end
      object Label4: TLabel
        Left = 376
        Top = 88
        Width = 50
        Height = 13
        Caption = #12486#12540#12502#12523#21517
      end
      object Button1: TButton
        Left = 96
        Top = 16
        Width = 169
        Height = 33
        Caption = 'dbGo'#12398#12513#12477#12483#12489#12434#20351#29992
        TabOrder = 0
        OnClick = Button1Click
      end
      object ListBox1: TListBox
        Left = 16
        Top = 106
        Width = 169
        Height = 401
        ItemHeight = 13
        TabOrder = 1
        OnClick = ListBox1Click
      end
      object ListBox2: TListBox
        Left = 191
        Top = 106
        Width = 169
        Height = 401
        ItemHeight = 13
        TabOrder = 2
      end
      object ListBox3: TListBox
        Left = 376
        Top = 106
        Width = 169
        Height = 401
        ItemHeight = 13
        TabOrder = 3
        OnClick = ListBox3Click
      end
      object ListBox4: TListBox
        Left = 550
        Top = 106
        Width = 169
        Height = 401
        ItemHeight = 13
        TabOrder = 4
      end
      object Button2: TButton
        Left = 472
        Top = 16
        Width = 169
        Height = 33
        Caption = 'DbExpress'#12398#12513#12477#12483#12489#12434#20351#29992
        TabOrder = 5
        OnClick = Button2Click
      end
    end
    object TabSheet2: TTabSheet
      Caption = 'TabSheet2'
      ImageIndex = 1
      object DBGrid1: TDBGrid
        Left = 0
        Top = 0
        Width = 145
        Height = 507
        Align = alLeft
        DataSource = DataSource1
        TabOrder = 0
        TitleFont.Charset = DEFAULT_CHARSET
        TitleFont.Color = clWindowText
        TitleFont.Height = -11
        TitleFont.Name = 'Tahoma'
        TitleFont.Style = []
        Columns = <
          item
            Expanded = False
            FieldName = 'Name'
            Visible = True
          end>
      end
      object DBGrid2: TDBGrid
        Left = 145
        Top = 0
        Width = 160
        Height = 507
        Align = alLeft
        DataSource = DataSource2
        TabOrder = 1
        TitleFont.Charset = DEFAULT_CHARSET
        TitleFont.Color = clWindowText
        TitleFont.Height = -11
        TitleFont.Name = 'Tahoma'
        TitleFont.Style = []
        Columns = <
          item
            Expanded = False
            FieldName = 'NAME'
            Visible = True
          end>
      end
    end
    object TabSheet3: TTabSheet
      Caption = 'TabSheet3'
      ImageIndex = 2
      object DBGrid3: TDBGrid
        Left = 0
        Top = 0
        Width = 177
        Height = 507
        Align = alLeft
        DataSource = DataSource3
        TabOrder = 0
        TitleFont.Charset = DEFAULT_CHARSET
        TitleFont.Color = clWindowText
        TitleFont.Height = -11
        TitleFont.Name = 'Tahoma'
        TitleFont.Style = []
        Columns = <
          item
            Expanded = False
            FieldName = 'Name'
            Visible = True
          end>
      end
      object DBGrid4: TDBGrid
        Left = 177
        Top = 0
        Width = 184
        Height = 507
        Align = alLeft
        DataSource = DataSource4
        TabOrder = 1
        TitleFont.Charset = DEFAULT_CHARSET
        TitleFont.Color = clWindowText
        TitleFont.Height = -11
        TitleFont.Name = 'Tahoma'
        TitleFont.Style = []
        Columns = <
          item
            Expanded = False
            FieldName = 'NAME'
            Visible = True
          end>
      end
    end
  end
  object ADOConnection1: TADOConnection
    Connected = True
    ConnectionString =
      'Provider=SQLNCLI10.1;Integrated Security="";Persist Security Inf' +
      'o=False;User ID=sa;Initial Catalog=AdventureWorks;Data Source=SA' +
      'KANOTE-PC\SqlExpress;Initial File Name="";Server SPN=""'
    LoginPrompt = False
    Provider = 'SQLNCLI10.1'
    Left = 16
    Top = 456
  end
  object SQLConnection1: TSQLConnection
    ConnectionName = 'MSSQLConnection'
    DriverName = 'MSSQL'
    GetDriverFunc = 'getSQLDriverMSSQL'
    LibraryName = 'dbxmss.dll'
    LoginPrompt = False
    Params.Strings = (
      'SchemaOverride=%.dbo'
      'DriverUnit=DBXMSSQL'
    
        'DriverPackageLoader=TDBXDynalinkDriverLoader,DBXCommonDriver150.' +
        'bpl'
    
        'DriverAssemblyLoader=Borland.Data.TDBXDynalinkDriverLoader,Borla' +
        'nd.Data.DbxCommonDriver,Version=15.0.0.0,Culture=neutral,PublicK' +
        'eyToken=91d62ebb5b0d1b1b'
    
        'MetaDataPackageLoader=TDBXMsSqlMetaDataCommandFactory,DbxMSSQLDr' +
        'iver150.bpl'
    
        'MetaDataAssemblyLoader=Borland.Data.TDBXMsSqlMetaDataCommandFact' +
        'ory,Borland.Data.DbxMSSQLDriver,Version=15.0.0.0,Culture=neutral' +
        ',PublicKeyToken=91d62ebb5b0d1b1b'
      'GetDriverFunc=getSQLDriverMSSQL'
      'LibraryName=dbxmss.dll'
      'VendorLib=sqlncli10.dll'
      'MaxBlobSize=-1'
      'OSAuthentication=False'
      'PrepareSQL=True'
      'DriverName=MSSQL'
      'HostName=SAKANOTE-PC\SQLEXPRESS'
      'Database=AdventureWorks'
      'User_Name=sa'
      'Password=sysdba'
      'BlobSize=-1'
      'ErrorResourceFile='
      'LocaleCode=0000'
      'IsolationLevel=ReadCommitted'
      'OS Authentication=False'
      'Prepare SQL=False'
      'ConnectTimeout=60'
      'Mars_Connection=False')
    VendorLib = 'sqlncli10.dll'
    Connected = True
    Left = 464
    Top = 56
  end
  object ADOQuery1: TADOQuery
    Connection = ADOConnection1
    CursorType = ctStatic
    Parameters = <>
    SQL.Strings = (
      'SELECT Object_ID, Name FROM SYS.TABLES')
    Left = 16
    Top = 488
  end
  object DataSetProvider1: TDataSetProvider
    DataSet = ADOQuery1
    Left = 56
    Top = 504
  end
  object ClientDataSet1: TClientDataSet
    Active = True
    Aggregates = <>
    Params = <>
    ProviderName = 'DataSetProvider1'
    Left = 88
    Top = 504
  end
  object DataSource1: TDataSource
    DataSet = ClientDataSet1
    Left = 24
    Top = 184
  end
  object ADOQuery2: TADOQuery
    Connection = ADOConnection1
    CursorType = ctStatic
    Parameters = <
      item
        Name = 'Object_ID'
        DataType = ftInteger
        Value = 14623095
      end>
    SQL.Strings = (
      'SELECT Object_ID , NAME FROM sys.columns')
    Left = 144
    Top = 504
  end
  object ClientDataSet2: TClientDataSet
    Active = True
    Aggregates = <>
    IndexFieldNames = 'Object_ID'
    MasterFields = 'Object_ID'
    MasterSource = DataSource1
    PacketRecords = 0
    Params = <>
    ProviderName = 'DataSetProvider2'
    Left = 208
    Top = 504
  end
  object DataSetProvider2: TDataSetProvider
    DataSet = ADOQuery2
    Left = 176
    Top = 504
  end
  object DataSource2: TDataSource
    DataSet = ClientDataSet2
    Left = 96
    Top = 176
  end
  object ClientDataSet3: TClientDataSet
    Active = True
    Aggregates = <>
    Params = <>
    ProviderName = 'DataSetProvider3'
    Left = 464
    Top = 112
  end
  object DataSetProvider3: TDataSetProvider
    DataSet = SQLQuery1
    Left = 464
    Top = 168
  end
  object SQLQuery1: TSQLQuery
    MaxBlobSize = -1
    Params = <>
    SQL.Strings = (
      'SELECT Object_ID, Name FROM SYS.TABLES')
    SQLConnection = SQLConnection1
    Left = 464
    Top = 216
  end
  object DataSource3: TDataSource
    DataSet = ClientDataSet3
    Left = 456
    Top = 280
  end
  object DataSetProvider4: TDataSetProvider
    DataSet = SQLQuery2
    Left = 600
    Top = 176
  end
  object ClientDataSet4: TClientDataSet
    Active = True
    Aggregates = <>
    IndexFieldNames = 'Object_ID'
    MasterFields = 'Object_ID'
    MasterSource = DataSource3
    PacketRecords = 0
    Params = <>
    ProviderName = 'DataSetProvider4'
    Left = 592
    Top = 104
  end
  object DataSource4: TDataSource
    DataSet = ClientDataSet4
    Left = 576
    Top = 280
  end
  object SQLQuery2: TSQLQuery
    MaxBlobSize = -1
    Params = <
      item
        DataType = ftInteger
        Name = 'Object_ID'
        ParamType = ptInput
        Value = 14623095
      end>
    SQL.Strings = (
      'SELECT Object_ID , NAME FROM sys.columns')
    SQLConnection = SQLConnection1
    Left = 584
    Top = 240
  end
end

SQL Server のデータベースのテーブルとフィールド名を表示する。（その1)

仕事でSql Serverのテーブルリストを表示する必要があったので・・・

DelphiでSQl Srerverのテーブルリストを表示する方法をいくつか


1. dbGOのConnectionのGetTableNamesメソッドとGetFieldNamesメソッドを利用する。


dbGoのGetTableNamesを利用すればInitial_Catalogで指定したデータベースの
テーブルリストを取得できます。

また、GetFieldNamesを利用すれば、指定したテーブルのフィールドのリストを表示できます。

ソースは、こんな感じ・・・
（ボタンをクリックするとテーブルのリストを表示し、リストの中のテーブルをクリックすると
クリックしたテーブルのリストを表示します。）

view plainprint?

1. procedure TForm1.Button1Click(Sender: TObject);  
2. begin  
3.   ADOConnection1.Connected := true;  
4.   ADOConnection1.GetTableNames(ListBox1.Items,false);  
5.   ADOConnection1.Connected := false;  
6. end;  
7.   
8. procedure TForm1.ListBox1Click(Sender: TObject);  
9. var  
10.   TableName : String;  
11. begin  
12.    if ListBox1.Items.Count > 0 then  
13.    begin  
14.       TableName := ListBox1.Items[ListBox1.ItemIndex];  
15.       if Length(TableName) > 0 then  
16.       begin  
17.         ADOConnection1.Connected := true;  
18.         ADOConnection1.GetFieldNames(TableName,ListBox2.Items);  
19.         ADOConnection1.Connected := false;  
20.       end;  
21.    end;  
22. end;  

procedure TForm1.Button1Click(Sender: TObject);
begin
  ADOConnection1.Connected := true;
  ADOConnection1.GetTableNames(ListBox1.Items,false);
  ADOConnection1.Connected := false;
end;

procedure TForm1.ListBox1Click(Sender: TObject);
var
  TableName : String;
begin
   if ListBox1.Items.Count > 0 then
   begin
      TableName := ListBox1.Items[ListBox1.ItemIndex];
      if Length(TableName) > 0 then
      begin
        ADOConnection1.Connected := true;
        ADOConnection1.GetFieldNames(TableName,ListBox2.Items);
        ADOConnection1.Connected := false;
      end;
   end;
end;

2. DbExpressを利用する。

DbExpressのSQLConnectionにもGetTableNamesメソッドとGetFieldNamesがあるので
dbGOと同様に処理できます。

ただし、試した中では、DbExpressでは、スキーマを指定しないとdboスキーマのテーブル
しか取得しないようなので、GetSchemaNamesでスキーマ名のリストを取得したうえで
スキーマ毎にテーブルを取得する必要がありました。

でソースはこんな感じ。スキーマ名を取得してる関係でちょっと複雑です。

view plainprint?

1. procedure TForm1.Button1Click(Sender: TObject);  
2.   
3. procedure TForm1.Button2Click(Sender: TObject);  
4. var  
5.   GetSchemaNames : TStringList;  
6.   TableNames : TStringList;  
7.   i,j : Integer;  
8. begin  
9.   ListBox3.Items.Clear;  
10.   SQLConnection1.Connected := true;  
11.   GetSchemaNames := TStringList.Create;  
12.   try  
13.     SQLConnection1.GetSchemaNames(GetSchemaNames);  
14.     for i := 0 to GetSchemaNames.Count -1 do  
15.     begin  
16.       TableNames := TStringList.Create;  
17.       try  
18.         SQLConnection1.GetTableNames(TableNames,GetSchemaNames.Strings[i],false);  
19.         for j := 0 to TableNames.Count-1 do  
20.         begin  
21.           ListBox3.Items.Add(GetSchemaNames.Strings[i] + '.' + TableNames.Strings[j]);  
22.         end;  
23.       finally  
24.         TableNames.Free;  
25.       end;  
26.     end;  
27.   finally  
28.     GetSchemaNames.Free;  
29.   end;  
30.   SQLConnection1.Connected := false;  
31. end;  
32.   
33. procedure TForm1.ListBox3Click(Sender: TObject);  
34. var  
35.   TableName : String;  
36. begin  
37.    if ListBox1.Items.Count > 0 then  
38.    begin  
39.       TableName := ListBox3.Items[ListBox3.ItemIndex];  
40.       if Length(TableName) > 0 then  
41.       begin  
42.         SQLConnection1.Connected := true;  
43.         SQLConnection1.GetFieldNames(TableName,ListBox4.Items);  
44.         SQLConnection1.Connected := false;  
45.       end;  
46.   
47.    end;  
48. end;  

procedure TForm1.Button1Click(Sender: TObject);

procedure TForm1.Button2Click(Sender: TObject);
var
  GetSchemaNames : TStringList;
  TableNames : TStringList;
  i,j : Integer;
begin
  ListBox3.Items.Clear;
  SQLConnection1.Connected := true;
  GetSchemaNames := TStringList.Create;
  try
    SQLConnection1.GetSchemaNames(GetSchemaNames);
    for i := 0 to GetSchemaNames.Count -1 do
    begin
      TableNames := TStringList.Create;
      try
        SQLConnection1.GetTableNames(TableNames,GetSchemaNames.Strings[i],false);
        for j := 0 to TableNames.Count-1 do
        begin
          ListBox3.Items.Add(GetSchemaNames.Strings[i] + '.' + TableNames.Strings[j]);
        end;
      finally
        TableNames.Free;
      end;
    end;
  finally
    GetSchemaNames.Free;
  end;
  SQLConnection1.Connected := false;
end;

procedure TForm1.ListBox3Click(Sender: TObject);
var
  TableName : String;
begin
   if ListBox1.Items.Count > 0 then
   begin
      TableName := ListBox3.Items[ListBox3.ItemIndex];
      if Length(TableName) > 0 then
      begin
        SQLConnection1.Connected := true;
        SQLConnection1.GetFieldNames(TableName,ListBox4.Items);
        SQLConnection1.Connected := false;
      end;

   end;
end;

JoinStringはないの？（その２）

Delフサさんから指摘を受けましたので、オープン配列版のJoinString関数を
作成してみました。(Delフサ様ご指摘ありがとうございます。）

でついでに、文字列の最後にDelemeterを付加するかどうかを指定できる
オーバーロード関数をも作ってみました。

以下、ソースコード

view plainprint?

1. unit VbLikeStringUtil;  
2.   
3. interface  
4.   
5. uses  
6.   StrUtils,Types;  
7.   
8.   function JoinString(AStrings : Array of String; Delemeter: String) : String overload;  
9.   function JoinString(AStrings : Array of String; Delemeter: String; AddLastDelemeter : Boolean) : String overload;  
10.   
11.   
12. implementation  
13.   
14. uses  
15.   SysUtils;  
16.   
17.   
18. function JoinString(AStrings : Array of String; Delemeter: String) : String overload;  
19. begin  
20.   Result := JoinString(AStrings,Delemeter,false);  
21. end;  
22.   
23. function JoinString(AStrings : Array of String; Delemeter: String; AddLastDelemeter : Boolean) : String overload;  
24. var  
25.   i : Longint;  
26. begin  
27.   
28.   Result := '';  
29.   if (Length(AStrings) > 0) then  
30.   begin  
31.   
32.     //最後の  
33.     for i := low(AStrings) to high(AStrings)-1 do  
34.     begin  
35.       Result := Result + AStrings[i] + Delemeter;  
36.     end;  
37.   
38.     //文字配列の最後の要素  
39.     Result := Result + AStrings[high(AStrings)];  
40.   
41.     //最後にデリミターを付加する場合  
42.     if AddLastDelemeter then  
43.     begin  
44.       Result := Result + Delemeter;  
45.     end;  
46.   
47.   end;  
48. end;  

unit VbLikeStringUtil;

interface

uses
  StrUtils,Types;

  function JoinString(AStrings : Array of String; Delemeter: String) : String overload;
  function JoinString(AStrings : Array of String; Delemeter: String; AddLastDelemeter : Boolean) : String overload;


implementation

uses
  SysUtils;


function JoinString(AStrings : Array of String; Delemeter: String) : String overload;
begin
  Result := JoinString(AStrings,Delemeter,false);
end;

function JoinString(AStrings : Array of String; Delemeter: String; AddLastDelemeter : Boolean) : String overload;
var
  i : Longint;
begin

  Result := '';
  if (Length(AStrings) > 0) then
  begin

    //最後の
    for i := low(AStrings) to high(AStrings)-1 do
    begin
      Result := Result + AStrings[i] + Delemeter;
    end;

    //文字配列の最後の要素
    Result := Result + AStrings[high(AStrings)];

    //最後にデリミターを付加する場合
    if AddLastDelemeter then
    begin
      Result := Result + Delemeter;
    end;

  end;
end;

でテストコードはこんな感じ。

view plainprint?

1. unit Unit1;  
2.   
3. interface  
4.   
5. uses  
6.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  
7.   Dialogs, StdCtrls;  
8.   
9. type  
10.   TForm1 = class(TForm)  
11.     Button1: TButton;  
12.     Label1: TLabel;  
13.     Button2: TButton;  
14.     procedure Button1Click(Sender: TObject);  
15.     procedure Button2Click(Sender: TObject);  
16.   private  
17.     { Private 宣言 }  
18.   public  
19.     { Public 宣言 }  
20.   end;  
21.   
22. var  
23.   Form1: TForm1;  
24.   
25. implementation  
26.   
27. uses  
28.   StrUtils,Types, VbLikeStringUtil;  
29.   
30. {$R *.dfm}  
31.   
32. procedure TForm1.Button1Click(Sender: TObject);  
33. var  
34.   JoinItems : TStringDynArray;  
35. begin  
36.   
37.   
38.   SetLength(JoinItems,5);  
39.   
40.   JoinItems[0] := 'イージス';  
41.   JoinItems[1] := 'ジャスティス';  
42.   JoinItems[2] := 'ザク';  
43.   JoinItems[3] := 'セイバー';  
44.   JoinItems[4] := 'グフ';  
45.   
46.   Assert('イージス|ジャスティス|ザク|セイバー|グフ'=JoinString(JoinItems,'|'));  
47.   
48.   Label1.Caption := JoinString(JoinItems,'|');  
49.   
50.   
51.   
52. end;  
53.   
54. procedure TForm1.Button2Click(Sender: TObject);  
55. begin  
56.   
57.   //空配列の場合は空文字を返す  
58.   Assert(''=JoinString([],'|'));  
59.   
60.   //通常の場合  
61.   Assert('ミリアリア|キラ|メイリン|バルトフェルド'  
62.      = JoinString(['ミリアリア','キラ','メイリン','バルトフェルド'],'|'));  
63.   
64.   //オプションの第３引数にTrueを指定すると文字列の最後にデリミタを付加します。  
65.   Assert('ミリアリア|キラ|メイリン|バルトフェルド|'  
66.      = JoinString(['ミリアリア','キラ','メイリン','バルトフェルド'],'|',true));  
67.   
68.   Label1.Caption := JoinString(['ミリアリア','キラ','メイリン','バルトフェルド'],'|',true);  
69. end;  
70.   
71. end.  

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  StrUtils,Types, VbLikeStringUtil;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  JoinItems : TStringDynArray;
begin


  SetLength(JoinItems,5);

  JoinItems[0] := 'イージス';
  JoinItems[1] := 'ジャスティス';
  JoinItems[2] := 'ザク';
  JoinItems[3] := 'セイバー';
  JoinItems[4] := 'グフ';

  Assert('イージス|ジャスティス|ザク|セイバー|グフ'=JoinString(JoinItems,'|'));

  Label1.Caption := JoinString(JoinItems,'|');



end;

procedure TForm1.Button2Click(Sender: TObject);
begin

  //空配列の場合は空文字を返す
  Assert(''=JoinString([],'|'));

  //通常の場合
  Assert('ミリアリア|キラ|メイリン|バルトフェルド'
     = JoinString(['ミリアリア','キラ','メイリン','バルトフェルド'],'|'));

  //オプションの第３引数にTrueを指定すると文字列の最後にデリミタを付加します。
  Assert('ミリアリア|キラ|メイリン|バルトフェルド|'
     = JoinString(['ミリアリア','キラ','メイリン','バルトフェルド'],'|',true));

  Label1.Caption := JoinString(['ミリアリア','キラ','メイリン','バルトフェルド'],'|',true);
end;

end.

ちなみに、今回の文字列は、Seedの自分の好きなキャラシリーズです。

JoinStringはないの？

VB6のJoin関数および.Net FrameworkのString.Joinメソッドは、
XEで追加されたほどSplitString使用頻度は多くないがたまに必要に
なることがある。

Help,ソースをざっくり見たところなさそうだったので実装してみた。
（といっても文字列を連結しただけですが・・・)

以下、ソースコード

view plainprint?

1. unit VbLikeStringUtil;  
2.   
3. interface  
4.   
5. uses  
6.   StrUtils,Types;  
7.   
8.   function JoinString(AStrings: TStringDynArray; Delemeter : String) : String;  
9.   
10. implementation  
11.   
12. uses  
13.   SysUtils;  
14.   
15. function JoinString(AStrings: TStringDynArray; Delemeter : String) : String;  
16. var  
17.   i : Longint;  
18. begin  
19.   
20.   Result := '';  
21.   for i := low(AStrings) to high(AStrings) do  
22.   begin  
23.     Result := Result + AStrings[i];  
24.     if i < high(AStrings) then Result := Result + Delemeter;  
25.   end;  
26.   
27.   
28. end;  
29.   
30. end.  

unit VbLikeStringUtil;

interface

uses
  StrUtils,Types;

  function JoinString(AStrings: TStringDynArray; Delemeter : String) : String;

implementation

uses
  SysUtils;

function JoinString(AStrings: TStringDynArray; Delemeter : String) : String;
var
  i : Longint;
begin

  Result := '';
  for i := low(AStrings) to high(AStrings) do
  begin
    Result := Result + AStrings[i];
    if i < high(AStrings) then Result := Result + Delemeter;
  end;


end;

end.

実際の使用方法のサンプルは、こんな感じ

view plainprint?

1. unit Unit1;  
2.   
3. interface  
4.   
5. uses  
6.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  
7.   Dialogs, StdCtrls;  
8.   
9. type  
10.   TForm1 = class(TForm)  
11.     Button1: TButton;  
12.     Label1: TLabel;  
13.     procedure Button1Click(Sender: TObject);  
14.   private  
15.     { Private 宣言 }  
16.   public  
17.     { Public 宣言 }  
18.   end;  
19.   
20. var  
21.   Form1: TForm1;  
22.   
23. implementation  
24.   
25. uses  
26.   StrUtils,Types, VbLikeStringUtil;  
27.   
28. {$R *.dfm}  
29.   
30. procedure TForm1.Button1Click(Sender: TObject);  
31. var  
32.   JoinItems : TStringDynArray;  
33. begin  
34.   
35.   
36.   SetLength(JoinItems,5);  
37.   
38.   JoinItems[0] := 'イージス';  
39.   JoinItems[1] := 'ジャスティス';  
40.   JoinItems[2] := 'ザク';  
41.   JoinItems[3] := 'セイバー';  
42.   JoinItems[4] := 'グフ';  
43.   
44.   
45.   Label1.Caption := JoinString(JoinItems,'|');  
46.   
47.   
48. end;  
49.   
50. end.  

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  StrUtils,Types, VbLikeStringUtil;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  JoinItems : TStringDynArray;
begin


  SetLength(JoinItems,5);

  JoinItems[0] := 'イージス';
  JoinItems[1] := 'ジャスティス';
  JoinItems[2] := 'ザク';
  JoinItems[3] := 'セイバー';
  JoinItems[4] := 'グフ';


  Label1.Caption := JoinString(JoinItems,'|');


end;

end.

SplitStringを試してみる。

Delphi XEでSplitString関数が追加された。VBにあって、Delphiになかった関数で
個人的には気になってた関数です。（欲しかった関数です。）

で、ちょっとためしてみた。

以下、ソースコード

view plainprint?

1. unit Unit1;  
2.   
3. interface  
4.   
5. uses  
6.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  
7.   Dialogs, StdCtrls;  
8.   
9. type  
10.   TForm1 = class(TForm)  
11.     Button1: TButton;  
12.     Label1: TLabel;  
13.     ListBox1: TListBox;  
14.     procedure Button1Click(Sender: TObject);  
15.   private  
16.     { Private 宣言 }  
17.   public  
18.     { Public 宣言 }  
19.   end;  
20.   
21. var  
22.   Form1: TForm1;  
23.   
24. implementation  
25.   
26. {$R *.dfm}  
27.   
28. uses  
29.   StrUtils,Types;  
30.   
31. procedure TForm1.Button1Click(Sender: TObject);  
32. var  
33.   TestString : String;  
34.   SplitResult:TStringDynArray;  
35. begin  
36.   TestString := 'フリーダム,ジャスティス,デストロイ,セイバー';  
37.   SplitResult := SplitString(TestString,',');  
38.   Label1.Caption := TestString;  
39.   
40.   for TestString in SplitResult do begin  
41.     ListBox1.Items.Add(TestString);  
42.   end;  
43.   
44. end;  
45.   
46. end.  

unit Unit1;

interface

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

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

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  StrUtils,Types;

procedure TForm1.Button1Click(Sender: TObject);
var
  TestString : String;
  SplitResult:TStringDynArray;
begin
  TestString := 'フリーダム,ジャスティス,デストロイ,セイバー';
  SplitResult := SplitString(TestString,',');
  Label1.Caption := TestString;

  for TestString in SplitResult do begin
    ListBox1.Items.Add(TestString);
  end;

end;

end.

Visual Basicライクで非常に簡単に使えます。

内部的には、FindDelimiter関数を使ってDelemeterをみつけ
Copy関数で部分文字列を切り出してます。

これなら、下位バージョンでも実装できそうですね。

ところでFindDelimiter関数は、いつから存在したのでしょうか？
個人的には、Delphiにはまだまだ知らない便利な関数が一杯ありそうです。


2010.09.10 山本隆の開発日記で紹介して頂いたので
調子にのってC++ Builderで書いてみました。
(C++は自信がないので、役に立つかどうかわかりませんが・・・)

view plainprint?

1. //---------------------------------------------------------------------------  
2.   
3. #include <vcl.h>  
4. #include <strutils.hpp>  
5. #pragma hdrstop  
6.   
7. #include "Unit1.h"  
8. //---------------------------------------------------------------------------  
9. #pragma package(smart_init)  
10. #pragma resource "*.dfm"  
11. TForm1 *Form1;  
12. //---------------------------------------------------------------------------  
13. __fastcall TForm1::TForm1(TComponent* Owner)  
14.  : TForm(Owner)  
15. {  
16.   
17. }  
18. //---------------------------------------------------------------------------  
19. void __fastcall TForm1::Button1Click(TObject *Sender)  
20. {  
21.   
22.  UnicodeString TestString = "イージス|バスター|デュエル|ブリッツ|ストライク";  
23.   
24.  LabeledEdit1->Text = TestString;  
25.   
26.  TStringDynArray SplitResult = SplitString(TestString,"|");  
27.   
28.  for (int i = 0; i < SplitResult.Length; i ++) {  
29.   ListBox1->Items->Add(SplitResult[i]);  
30.  }  
31.   
32.  SplitResult.set_length(0);  
33.   
34. }  
35. //---------------------------------------------------------------------------  
36.   
37. </strutils.hpp></vcl.h>  

//---------------------------------------------------------------------------

#include 
#include 
#pragma hdrstop

#include "Unit1.h"
//---------------------------------------------------------------------------
#pragma package(smart_init)
#pragma resource "*.dfm"
TForm1 *Form1;
//---------------------------------------------------------------------------
__fastcall TForm1::TForm1(TComponent* Owner)
 : TForm(Owner)
{

}
//---------------------------------------------------------------------------
void __fastcall TForm1::Button1Click(TObject *Sender)
{

 UnicodeString TestString = "イージス|バスター|デュエル|ブリッツ|ストライク";

 LabeledEdit1->Text = TestString;

 TStringDynArray SplitResult = SplitString(TestString,"|");

 for (int i = 0; i < SplitResult.Length; i ++) {
  ListBox1->Items->Add(SplitResult[i]);
 }

 SplitResult.set_length(0);

}
//---------------------------------------------------------------------------

SameValue関数

StackOverFlowのTopicのトピックを見ていてDelphiのMathユニットに

SameValue関数なる関数が用意されていることを初めて知りました。

この関数は、指定した値が、２つの値がEpsilonで指定した値以内に
あれば、等しいと見なす関数です。

DelphiというかVCL(RTLも含むには）便利な比較関数が用意されています。

今まで、都度都度、自作していたかと思うとちょっと反省。

プロセスリストを表示する。

プロセスの一覧を表示するサンプルです。

Toolhelp32(DelphではTlHelp32)が使える環境では
比較的簡単ですが、

view plainprint?

1. procedure TForm1.Button2Click(Sender: TObject);  
2. var  
3.  ProcEntry : TProcessEntry32W;  
4.    SanpshotHandle : THandle;  
5. begin  
6.  //Toolhelp32を使用する例  
7.    SanpshotHandle := TlHelp32.CreateToolhelp32Snapshot(TlHelp32.TH32CS_SNAPPROCESS,0);  
8.    if (SanpshotHandle <> -1) then  
9.    begin  
10.     ListBox1.Items.Clear;  
11.     ProcEntry.dwSize := Sizeof(TProcessEntry32W);  
12.       if (TlHelp32.Process32First(SanpshotHandle, ProcEntry)) Then  
13.       begin  
14.          repeat  
15.           ListBox1.Items.Add(ProcEntry.szExeFile);  
16.          until (TlHelp32.Process32Next(SanpshotHandle,ProcEntry) = false);  
17.       end;  
18.    end;  
19.    CloseHandle(SanpshotHandle);  
20.   
21. end;  

procedure TForm1.Button2Click(Sender: TObject);
var
 ProcEntry : TProcessEntry32W;
   SanpshotHandle : THandle;
begin
 //Toolhelp32を使用する例
   SanpshotHandle := TlHelp32.CreateToolhelp32Snapshot(TlHelp32.TH32CS_SNAPPROCESS,0);
   if (SanpshotHandle <> -1) then
   begin
    ListBox1.Items.Clear;
    ProcEntry.dwSize := Sizeof(TProcessEntry32W);
      if (TlHelp32.Process32First(SanpshotHandle, ProcEntry)) Then
      begin
         repeat
          ListBox1.Items.Add(ProcEntry.szExeFile);
         until (TlHelp32.Process32Next(SanpshotHandle,ProcEntry) = false);
      end;
   end;
   CloseHandle(SanpshotHandle);

end;

使えない環境(といいても、4.0以下のNTだけですが・・・）だと
大変です。

view plainprint?

1. procedure TForm1.Button1Click(Sender: TObject);  
2. var  
3.     cb : Cardinal;  
4.    elements : Cardinal;  
5.    Needs : Cardinal;  
6.    ProcIdArray : Array of DWORD;  
7.    Win32Ret : LongBool;  
8.    i : Cardinal;  
9.    ProcHandle : THandle;  
10.    OpenMode : THandle;  
11.    ProcessName : String;  
12.   
13. begin  
14.   
15.     //プロセス数がいくつあるか解らないので大きめにとっておく  
16.    elements := 128;  
17.    Needs := elements * Sizeof(DWORD);  
18.    cb := 0;  
19.    while (cb <= Needs) do  
20.    begin  
21.   
22.         SetLength(ProcIdArray, elements);  
23.        cb := Length(ProcIdArray) * Sizeof(DWORD);  
24.        Needs := 0;  
25.       Win32Ret := PsApi.EnumProcesses(PDWORD(ProcIdArray),cb,Needs);  
26.   
27.       //APIが失敗したら抜ける  
28.       if (not(Win32Ret)) then  
29.       begin  
30.          break;  
31.       end;  
32.   
33.       //領域が足りなかったときに備えて倍にする。  
34.       elements := elements * 2;  
35.   
36.    end;  
37.   
38.    if (Win32Ret) then  
39.    begin  
40.        ListBox1.Items.Clear;  
41.       OpenMode := Windows.PROCESS_QUERY_INFORMATION or Windows.PROCESS_VM_READ;  
42.         elements := Needs div Sizeof(DWORD);  
43.        for i := 0 to elements - 1 do  
44.        begin  
45.           //プロセスIDから情報をえる  
46.          ProcHandle := Windows.OpenProcess(OpenMode,FALSE,ProcIdArray[i]);  
47.          if (ProcHandle <> 0) then  
48.          begin  
49.              ProcessName := GetProcessName(ProcHandle);  
50.             if (Length(ProcessName) > 0) then  
51.             begin  
52.                 ListBox1.Items.Add(ProcessName);  
53.             end;  
54.          end;  
55.          Windows.CloseHandle(ProcHandle);  
56.       end;  
57.    end;  
58.   
59. end;  
60.   
61. function TForm1.GetProcessName(ProcessHandle: THandle): String;  
62. var  
63.     cb : Cardinal;  
64.    elements : Cardinal;  
65.    Needs : Cardinal;  
66.    ModuleHandleArray : Array of THandle;  
67.    Win32Ret : LongBool;  
68.    i : longint;  
69.    ModuleHandle: THandle;  
70.    ModuleName : WideString;  
71.    ModeleNameLength : Integer;  
72.    ProcessName : String;  
73.    FileExt : String;  
74. begin  
75.   
76.     Result := '';  
77.     //モジュール数数がいくつあるか解らないので大きめにとっておく  
78.    elements := 128;  
79.    Needs := elements * Sizeof(DWORD);  
80.    cb := 0;  
81.    while (cb <= Needs) do  
82.    begin  
83.   
84.         SetLength(ModuleHandleArray, elements);  
85.        cb := Length(ModuleHandleArray) * Sizeof(DWORD);  
86.        Needs := 0;  
87.       Win32Ret := PsApi.EnumProcessModules(ProcessHandle,PDWORD(ModuleHandleArray),cb,Needs);  
88.   
89.       //APIが失敗したら抜ける  
90.       if (not(Win32Ret)) then  
91.       begin  
92.          break;  
93.       end;  
94.       //領域が足りなかったときに備えて倍にする。  
95.       elements := elements * 2;  
96.    end;  
97.   
98.    if (Win32Ret) then  
99.    begin  
100.        ModeleNameLength := 255;  
101.       SetLength(ModuleName,ModeleNameLength);  
102.         elements := Needs div Sizeof(DWORD);  
103.        for i := 0 to elements - 1 do  
104.        begin  
105.           ModuleHandle := ModuleHandleArray[i];  
106.           ModeleNameLength := PsApi.GetModuleBaseName(  
107.                                   ProcessHandle,  
108.                                 ModuleHandle,  
109.                                 PWideChar(ModuleName),  
110.                                 ModeleNameLength);  
111.          if (ModeleNameLength > 0) then  
112.          begin  
113.              //モジュール名がExeファイルであればプロセスとみなす。  
114.              SetLength(ModuleName,ModeleNameLength);  
115.             ProcessName := ModuleName;  
116.             FileExt := ExtractFileExt(ProcessName);  
117.             if (CompareText(FileExt,'.EXE') = 0)  then  
118.             begin  
119.                 Result :=  ProcessName;  
120.                break;  
121.             end;  
122.          end;  
123.       end;  
124.    end;  
125. end;  

procedure TForm1.Button1Click(Sender: TObject);
var
    cb : Cardinal;
   elements : Cardinal;
   Needs : Cardinal;
   ProcIdArray : Array of DWORD;
   Win32Ret : LongBool;
   i : Cardinal;
   ProcHandle : THandle;
   OpenMode : THandle;
   ProcessName : String;

begin

    //プロセス数がいくつあるか解らないので大きめにとっておく
   elements := 128;
   Needs := elements * Sizeof(DWORD);
   cb := 0;
   while (cb <= Needs) do
   begin

        SetLength(ProcIdArray, elements);
       cb := Length(ProcIdArray) * Sizeof(DWORD);
       Needs := 0;
      Win32Ret := PsApi.EnumProcesses(PDWORD(ProcIdArray),cb,Needs);

      //APIが失敗したら抜ける
      if (not(Win32Ret)) then
      begin
         break;
      end;

      //領域が足りなかったときに備えて倍にする。
      elements := elements * 2;

   end;

   if (Win32Ret) then
   begin
       ListBox1.Items.Clear;
      OpenMode := Windows.PROCESS_QUERY_INFORMATION or Windows.PROCESS_VM_READ;
        elements := Needs div Sizeof(DWORD);
       for i := 0 to elements - 1 do
       begin
          //プロセスIDから情報をえる
         ProcHandle := Windows.OpenProcess(OpenMode,FALSE,ProcIdArray[i]);
         if (ProcHandle <> 0) then
         begin
             ProcessName := GetProcessName(ProcHandle);
            if (Length(ProcessName) > 0) then
            begin
                ListBox1.Items.Add(ProcessName);
            end;
         end;
         Windows.CloseHandle(ProcHandle);
      end;
   end;

end;

function TForm1.GetProcessName(ProcessHandle: THandle): String;
var
    cb : Cardinal;
   elements : Cardinal;
   Needs : Cardinal;
   ModuleHandleArray : Array of THandle;
   Win32Ret : LongBool;
   i : longint;
   ModuleHandle: THandle;
   ModuleName : WideString;
   ModeleNameLength : Integer;
   ProcessName : String;
   FileExt : String;
begin

    Result := '';
    //モジュール数数がいくつあるか解らないので大きめにとっておく
   elements := 128;
   Needs := elements * Sizeof(DWORD);
   cb := 0;
   while (cb <= Needs) do
   begin

        SetLength(ModuleHandleArray, elements);
       cb := Length(ModuleHandleArray) * Sizeof(DWORD);
       Needs := 0;
      Win32Ret := PsApi.EnumProcessModules(ProcessHandle,PDWORD(ModuleHandleArray),cb,Needs);

      //APIが失敗したら抜ける
      if (not(Win32Ret)) then
      begin
         break;
      end;
      //領域が足りなかったときに備えて倍にする。
      elements := elements * 2;
   end;

   if (Win32Ret) then
   begin
       ModeleNameLength := 255;
      SetLength(ModuleName,ModeleNameLength);
        elements := Needs div Sizeof(DWORD);
       for i := 0 to elements - 1 do
       begin
          ModuleHandle := ModuleHandleArray[i];
          ModeleNameLength := PsApi.GetModuleBaseName(
                                  ProcessHandle,
                                ModuleHandle,
                                PWideChar(ModuleName),
                                ModeleNameLength);
         if (ModeleNameLength > 0) then
         begin
             //モジュール名がExeファイルであればプロセスとみなす。
             SetLength(ModuleName,ModeleNameLength);
            ProcessName := ModuleName;
            FileExt := ExtractFileExt(ProcessName);
            if (CompareText(FileExt,'.EXE') = 0)  then
            begin
                Result :=  ProcessName;
               break;
            end;
         end;
      end;
   end;
end;