/jcl/examples/windows/tasks/TaskDemoMain.pas

  1unit TaskDemoMain;
  2
  3{$INCLUDE jcl.inc}
  4
  5interface
  6
  7uses
  8  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  9  Dialogs, ComCtrls, Menus, ExtCtrls, OleCtrls, SHDocVw,
 10  HTTPProd, HTTPApp;
 11
 12type
 13  TfrmMain = class(TForm)
 14    barStatus: TStatusBar;
 15    lstTasks: TListView;
 16    mnuMain: TMainMenu;
 17    mnuFile: TMenuItem;
 18    mnuFileExit: TMenuItem;
 19    mnuPopup: TPopupMenu;
 20    popTaskProp: TMenuItem;
 21    mnuTask: TMenuItem;
 22    mnuTaskProp: TMenuItem;
 23    SplitterV: TSplitter;
 24    WebBrowser: TWebBrowser;
 25    ppTaskInfo: TPageProducer;
 26    popTaskAdd: TMenuItem;
 27    popTaskDelete: TMenuItem;
 28    popLine0: TMenuItem;
 29    mnuTaskAdd: TMenuItem;
 30    mnuTaskDelete: TMenuItem;
 31    mnuTaskLine0: TMenuItem;
 32    mnuTaskLine2: TMenuItem;
 33    mnuTaskRefresh: TMenuItem;
 34    popLine2: TMenuItem;
 35    popTaskRefresh: TMenuItem;
 36    mnuTaskLine1: TMenuItem;
 37    mnuTaskRun: TMenuItem;
 38    mnuTaskStop: TMenuItem;
 39    popLine1: TMenuItem;
 40    popTaskRun: TMenuItem;
 41    popTaskStop: TMenuItem;
 42    procedure FormCreate(Sender: TObject);
 43    procedure WebBrowserDocumentComplete(Sender: TObject;
 44      const pDisp: IDispatch; var URL: OleVariant);
 45    procedure lstTasksSelectItem(Sender: TObject; Item: TListItem;
 46      Selected: Boolean);
 47    procedure ppTaskInfoHTMLTag(Sender: TObject; Tag: TTag;
 48      const TagString: String; TagParams: TStrings;
 49      var ReplaceText: String);
 50    procedure FormDestroy(Sender: TObject);
 51  private
 52    FWebBrowserInitialized: Boolean;
 53
 54    function SystemTimeToString(const SysTime: TSystemTime): string;
 55    function MsToStr(const MsTime: DWORD): string;
 56
 57    procedure SetHtml(const wb: TWebBrowser; const Html: string);
 58    procedure OnRefresh(Sender: TObject);
 59  public
 60    procedure Refresh;
 61  end;
 62
 63var
 64  frmMain: TfrmMain;
 65
 66implementation
 67
 68uses ActiveX, ComObj, TypInfo, MsHtml, TaskDemoDataModule, JclTask;
 69
 70{$R *.dfm}
 71
 72procedure TfrmMain.FormCreate(Sender: TObject);
 73begin
 74  FWebBrowserInitialized := False;
 75
 76  WebBrowser.Navigate('about:blank');
 77
 78  Refresh;
 79
 80  DM.OnRefresh := OnRefresh;
 81end;
 82
 83procedure TfrmMain.FormDestroy(Sender: TObject);
 84begin
 85  DM.OnRefresh := nil;
 86end;
 87
 88procedure TfrmMain.Refresh;
 89var
 90  I: Integer;
 91begin
 92  lstTasks.Clear;
 93  for I:=0 to DM.Task.TaskCount-1 do
 94  with lstTasks.Items.Add, DM.Task[I] do
 95  begin
 96    Caption := TaskName;
 97    Data    := DM.Task[I];
 98    SubItems.Add(SystemTimeToString(MostRecentRunTime));
 99    SubItems.Add(SystemTimeToString(NextRunTime));
100    SubItems.Add(Comment);
101  end;
102end;
103
104function TfrmMain.SystemTimeToString(const SysTime: TSystemTime): string;
105begin
106  if SysTime.wYear = 0 then
107    Result := 'Never'
108  else
109    Result := DateTimeToStr(SystemTimeToDateTime(SysTime));
110end;
111
112function TfrmMain.MsToStr(const MsTime: DWORD): string;
113var
114  RealTime: TDateTime;
115begin
116  RealTime := MsTime / MSecsPerDay;
117  Result := IntToStr(Trunc(RealTime)) + ' days ' + TimeToStr(RealTime);
118end;
119
120procedure TfrmMain.SetHtml(const wb: TWebBrowser; const Html: string);
121var
122  Stream: TStream;
123  Adapter: TStreamAdapter;
124  psi: IPersistStreamInit;
125begin
126  Stream := TStringStream.Create(Html);
127  try
128    Adapter := TStreamAdapter.Create(Stream);
129    psi := wb.Document as IPersistStreamInit;
130    OleCheck(psi.InitNew);
131    OleCheck(psi.Load(Adapter));
132  finally
133    FreeAndNil(Stream);
134  end;
135end;
136
137procedure TfrmMain.OnRefresh(Sender: TObject);
138begin
139  Refresh;
140end;
141
142procedure TfrmMain.WebBrowserDocumentComplete(Sender: TObject;
143  const pDisp: IDispatch; var URL: OleVariant);
144begin
145  if not FWebBrowserInitialized then
146  begin
147    FWebBrowserInitialized := True;
148
149    (((pDisp as IWebBrowser2).Document as IHTMLDocument2).body as IHTMLBodyElement).scroll := 'no';
150  end;
151end;
152
153procedure TfrmMain.lstTasksSelectItem(Sender: TObject; Item: TListItem;
154  Selected: Boolean);
155begin
156  if Selected and Assigned(Item) then
157    SetHtml(WebBrowser, ppTaskInfo.Content);
158end;
159
160procedure TfrmMain.ppTaskInfoHTMLTag(Sender: TObject; Tag: TTag;
161  const TagString: String; TagParams: TStrings; var ReplaceText: String);
162  function TaskStatusToString(const Status: TJclScheduledTaskStatus): string;
163  const
164    StatusName: array[TJclScheduledTaskStatus] of string =
165      ('Unknown', 'Ready', 'Running', 'Not Scheduled', 'Has Not Run');
166  begin
167    Result := StatusName[Status];
168  end;
169  function TaskFlagsToString(const Flags: TJclScheduledTaskFlags): string;
170  var
171    AFlag: TJclScheduledTaskFlag;
172  begin
173    for AFlag:=Low(TJclScheduledTaskFlag) to High(TJclScheduledTaskFlag) do
174      if AFlag in Flags then
175        Result := Result + GetEnumName(TypeInfo(TJclScheduledTaskFlag), Integer(AFlag)) + ' ';
176    if Result = '' then
177      Result := 'Empty';
178  end;
179  function TriggersToHtml(const Task: TJclScheduledTask): string;
180  var
181    I: Integer;
182  begin
183    for I:=0 to Task.TriggerCount-1 do
184      Result := Format('%s<LI>%s</LI>', [Result, Task.Triggers[I].TriggerString]);
185    Result := '<UL>' + Result + '</UL>';
186  end;
187begin
188  with TJclScheduledTask(frmMain.lstTasks.Selected.Data) do
189  try
190    if CompareText(TagString, 'TaskName') = 0 then
191      ReplaceText := TaskName
192    else if CompareText(TagString, 'AccountName') = 0 then
193      ReplaceText := AccountName
194    else if CompareText(TagString, 'Comment') = 0 then
195      ReplaceText := Comment
196    else if CompareText(TagString, 'Creator') = 0 then
197      ReplaceText := Creator
198    else if CompareText(TagString, 'ErrorRetryCount') = 0 then
199      ReplaceText := 'Unimplemented' // IntToStr(ErrorRetryCount)
200    else if CompareText(TagString, 'ErrorRetryInterval') = 0 then
201      ReplaceText := 'Unimplemented' // IntToStr(ErrorRetryInterval)
202    else if CompareText(TagString, 'ExitCode') = 0 then
203      ReplaceText := IntToStr(ExitCode)
204    else if CompareText(TagString, 'Data') = 0 then
205      ReplaceText := IntToStr(OwnerData.Size) + ' Bytes'
206    else if CompareText(TagString, 'IdleMinutes') = 0 then
207      ReplaceText := IntToStr(IdleMinutes) + ' Minutes'
208    else if CompareText(TagString, 'DeadlineMinutes') = 0 then
209      ReplaceText := IntToStr(DeadlineMinutes) + ' Minutes'
210    else if CompareText(TagString, 'MostRecentRunTime') = 0 then
211      ReplaceText := SystemTimeToString(MostRecentRunTime)
212    else if CompareText(TagString, 'NextRunTime') = 0 then
213      ReplaceText := SystemTimeToString(NextRunTime)
214    else if CompareText(TagString, 'Status') = 0 then
215      ReplaceText := TaskStatusToString(Status)
216    else if CompareText(TagString, 'Flags') = 0 then
217      ReplaceText := TaskFlagsToString(Flags)
218    else if CompareText(TagString, 'ApplicationName') = 0 then
219      ReplaceText := ApplicationName
220    else if CompareText(TagString, 'WorkingDirectory') = 0 then
221      ReplaceText := WorkingDirectory
222    else if CompareText(TagString, 'MaxRunTime') = 0 then
223      ReplaceText := MsToStr(MaxRunTime)
224    else if CompareText(TagString, 'Parameters') = 0 then
225      ReplaceText := Parameters
226    else if CompareText(TagString, 'Priority') = 0 then
227      ReplaceText := IntToStr(Priority)
228    else if CompareText(TagString, 'TaskFlags') = 0 then
229      ReplaceText := IntToHex(TaskFlags, 8)
230    else if CompareText(TagString, 'Triggers') = 0 then
231      ReplaceText := TriggersToHtml(TJclScheduledTask(frmMain.lstTasks.Selected.Data));
232  except
233    ReplaceText := 'Unknown';
234  end;
235end;
236
237end.