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

https://github.com/the-Arioch/jcl · Pascal · 237 lines · 210 code · 25 blank · 2 comment · 49 complexity · d6dbc28e0fc5ff706a3a48ed37f274e0 MD5 · raw file

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