Программа для прослушивания журнала АРК Томск http://blindage.org/?p=6627
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

406 lines
10KB

  1. unit Unit1;
  2. {$mode objfpc}{$H+}
  3. interface
  4. uses
  5. Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, EditBtn,
  6. StdCtrls, LCLProc, Buttons, ExtCtrls, ComCtrls, Grids, UTF8Process, process,
  7. ShellApi, httpsend;
  8. type
  9. TPlayThread = class(TThread)
  10. private
  11. fBusy: boolean;
  12. fIdx: integer;
  13. fTimeStamp: string;
  14. fTimeStampShow: boolean;
  15. procedure Hint;
  16. procedure Busy;
  17. procedure Play;
  18. procedure CheckBusy;
  19. procedure ThreadTerminate;
  20. procedure DownloadMessage;
  21. protected
  22. procedure Execute; override;
  23. public
  24. constructor Create(CreateSuspended: boolean);
  25. end;
  26. type
  27. { TForm1 }
  28. TForm1 = class(TForm)
  29. btnSave: TButton;
  30. chkAlwaysOnTop: TCheckBox;
  31. chkAutoRefresh: TCheckBox;
  32. chkAutoPlay: TCheckBox;
  33. DateEdit1: TDateEdit;
  34. Image1: TImage;
  35. Label1: TLabel;
  36. Label2: TLabel;
  37. Label3: TLabel;
  38. Label4: TLabel;
  39. Label5: TLabel;
  40. SaveDialog1: TSaveDialog;
  41. btnRefresh: TSpeedButton;
  42. btnToday: TSpeedButton;
  43. StatusBar1: TStatusBar;
  44. StringGrid1: TStringGrid;
  45. Timer1: TTimer;
  46. TrayIcon1: TTrayIcon;
  47. procedure btnSaveClick(Sender: TObject);
  48. procedure chkAlwaysOnTopChange(Sender: TObject);
  49. procedure chkAutoRefreshChange(Sender: TObject);
  50. procedure DateEdit1Change(Sender: TObject);
  51. procedure FormShow(Sender: TObject);
  52. procedure btnRefreshClick(Sender: TObject);
  53. procedure btnTodayClick(Sender: TObject);
  54. procedure FormWindowStateChange(Sender: TObject);
  55. procedure StringGrid1DblClick(Sender: TObject);
  56. procedure Timer1Timer(Sender: TObject);
  57. procedure TrayIcon1DblClick(Sender: TObject);
  58. procedure UpdateMessages(date: string);
  59. procedure DownloadMessage(fIdx: integer; fName: string);
  60. private
  61. { private declarations }
  62. public
  63. { public declarations }
  64. end;
  65. var
  66. Form1: TForm1;
  67. count_prev, count_current: integer;
  68. PlayQueue: integer;
  69. PlayBusy: boolean;
  70. PlayThread: TPlayThread;
  71. PlayList: TStringList;
  72. implementation
  73. {$R *.lfm}
  74. { TForm1 }
  75. procedure TForm1.UpdateMessages(date: string);
  76. var
  77. url: string;
  78. csv: TStringList;
  79. begin
  80. url := 'http://avto.opentomsk.net/archive.php?date='; //2015-02-27
  81. csv := TStringList.Create;
  82. with THTTPSend.Create do
  83. begin
  84. if HTTPMethod('GET', url + date) then
  85. try
  86. csv.LoadFromStream(Document);
  87. csv.Text := StringReplace(csv.Text, '''', '', [rfReplaceAll]);
  88. csv.SaveToFile(GetTempDir(False) + 'playlist.csv');
  89. if not Assigned(PlayList) then
  90. PlayList := TStringList.Create;
  91. count_prev := count_current;
  92. PlayList.Clear;
  93. PlayList.LoadFromFile(GetTempDir(False) + 'playlist.csv');
  94. StringGrid1.Clean;
  95. StringGrid1.RowCount := 0;
  96. StringGrid1.LoadFromCSVFile(GetTempDir(False) + 'playlist.csv');
  97. StringGrid1.InsertRowWithValues(0, ['Дата', 'Время', 'Длит', 'Путь']);
  98. StringGrid1.DeleteCol(0);
  99. StringGrid1.DeleteCol(2);
  100. StringGrid1.Row := 0;
  101. count_current := PlayList.Count;
  102. Label5.Caption := IntToStr(PlayList.Count);
  103. StatusBar1.Panels[0].Text := TimeToStr(now()) + ' Скачан список файлов';
  104. except
  105. //Application.MessageBox('Ошибка при скачивании списка воспроизведения','Error', 0);
  106. end;
  107. Free;
  108. end;
  109. csv.Free;
  110. if PlayList.Count > 0 then
  111. begin
  112. btnSave.Enabled := True;
  113. end
  114. else
  115. begin
  116. btnSave.Enabled := False;
  117. end;
  118. if chkAutoRefresh.Checked then DateEdit1.text:=FormatDateTime('DD.MM.YYYY',Now);
  119. if (DateToStr(DateEdit1.Date) = DateToStr(Now) ) then
  120. begin
  121. btnRefresh.Enabled := True;
  122. chkAutoRefresh.Enabled := True;
  123. //chkAutoRefresh.Checked := False;
  124. //chkAutoPlay.Enabled := False;
  125. //chkAutoPlay.Checked := False;
  126. end
  127. else
  128. begin
  129. btnRefresh.Enabled := False;
  130. chkAutoRefresh.Enabled := False;
  131. chkAutoRefresh.Checked := False;
  132. chkAutoPlay.Enabled := False;
  133. chkAutoPlay.Checked := False;
  134. end;
  135. end;
  136. function get_value(item, Value: integer): string;
  137. var
  138. params: TStringList;
  139. begin
  140. params := TStringList.Create;
  141. params.Delimiter := ',';
  142. params.DelimitedText := PlayList[item - 1];
  143. Result := params[Value];
  144. params.Free;
  145. end;
  146. procedure TForm1.DownloadMessage(fIdx: integer; fName: string);
  147. var
  148. url, path: string;
  149. memstream: TMemoryStream;
  150. begin
  151. url := 'http://avto.opentomsk.net/archive/';
  152. path := get_value(fIdx, 3);
  153. with THTTPSend.Create do
  154. begin
  155. if HTTPMethod('GET', url + path) then
  156. try
  157. memstream := TMemoryStream.Create;
  158. memstream := Document;
  159. memstream.SaveToFile(UTF8ToSys(fName));
  160. memstream.Free;
  161. except
  162. Application.MessageBox('Ошибка при скачивании файла', 'Error', 0);
  163. end;
  164. end;
  165. end;
  166. procedure TPlayThread.DownloadMessage();
  167. var
  168. url, path: string;
  169. memstream: TMemoryStream;
  170. begin
  171. url := 'http://avto.opentomsk.net/archive/';
  172. path := get_value(fIdx, 3);
  173. with THTTPSend.Create do
  174. begin
  175. if HTTPMethod('GET', url + path) then
  176. try
  177. memstream := TMemoryStream.Create;
  178. memstream := Document;
  179. memstream.SaveToFile(SysToUTF8(GetTempDir(False) + 'ak47.mp3'));
  180. memstream.Free;
  181. except
  182. Application.MessageBox('Ошибка при скачивании файла', 'Error', 0);
  183. end;
  184. end;
  185. end;
  186. constructor TPlayThread.Create(CreateSuspended: boolean);
  187. begin
  188. FreeOnTerminate := True;
  189. inherited Create(CreateSuspended);
  190. Inc(PlayQueue);
  191. end;
  192. procedure TPlayThread.ThreadTerminate;
  193. begin
  194. Dec(PlayQueue);
  195. end;
  196. procedure TplayThread.Busy;
  197. begin
  198. if fBusy = True then
  199. begin
  200. PlayBusy := True;
  201. end
  202. else
  203. begin
  204. PlayBusy := False;
  205. end;
  206. end;
  207. procedure TPlayThread.CheckBusy;
  208. begin
  209. if PlayBusy = True then
  210. begin
  211. fBusy := True;
  212. end
  213. else
  214. begin
  215. fBusy := False;
  216. end;
  217. end;
  218. procedure TPlayThread.Hint;
  219. begin
  220. Form1.TrayIcon1.BalloonHint := fTimeStamp;
  221. Form1.TrayIcon1.ShowBalloonHint;
  222. end;
  223. procedure TPlayThread.Execute;
  224. begin
  225. Synchronize(@CheckBusy);
  226. while (not Terminated) and (fBusy = True) do
  227. begin
  228. sleep(2000);
  229. Synchronize(@CheckBusy);
  230. end;
  231. fBusy := True;
  232. Synchronize(@Busy);
  233. if fTimeStampShow then
  234. Synchronize(@Hint);
  235. Play();
  236. fBusy := False;
  237. Synchronize(@Busy);
  238. Synchronize(@ThreadTerminate);
  239. Terminate;
  240. end;
  241. procedure TPlayThread.play();
  242. var
  243. tmp: ansistring;
  244. Player: TProcessUTF8;
  245. PlayerPath: ansistring;
  246. PlayerParams: ansistring;
  247. begin
  248. //tmp := GetTempDir(False) + 'ak47.mp3';
  249. //Synchronize(@DownloadMessage);
  250. PlayerPath := SysToUTF8(ExtractFileDir(Application.ExeName) + '\mpg123.exe');
  251. //PlayerParams := SysToUTF8(' -q "' + tmp + '"');
  252. PlayerParams:= '-q http://avto.opentomsk.net/archive/'+get_value(fIdx, 3);
  253. Player := TProcessUTF8.Create(nil);
  254. Form1.StatusBar1.Panels.Items[0].Text := 'Играет запись от ' + fTimeStamp;
  255. Form1.StatusBar1.Panels.Items[1].Text := 'В очереди ' + IntToStr(PlayQueue);
  256. try
  257. Player.CommandLine := PlayerPath + ' ' + PlayerParams;
  258. Player.Options := Player.Options + [poNoConsole, poWaitOnExit];
  259. Player.Execute;
  260. finally
  261. Player.Free;
  262. end;
  263. Form1.StatusBar1.Panels.Items[0].Text := '';
  264. Form1.StatusBar1.Panels.Items[1].Text := '';
  265. end;
  266. procedure TForm1.DateEdit1Change(Sender: TObject);
  267. begin
  268. try
  269. UpdateMessages(FormatDateTime('YYYY-MM-DD', DateEdit1.Date));
  270. except
  271. end;
  272. end;
  273. procedure TForm1.btnSaveClick(Sender: TObject);
  274. begin
  275. SaveDialog1.FileName := StringReplace(get_value(StringGrid1.Row, 0) +
  276. ' ' + get_value(StringGrid1.Row, 1), ':', '_', [rfReplaceAll]);
  277. if SaveDialog1.Execute then
  278. begin
  279. DownloadMessage(StringGrid1.Row, SaveDialog1.FileName);
  280. end;
  281. end;
  282. procedure TForm1.chkAlwaysOnTopChange(Sender: TObject);
  283. begin
  284. if chkAlwaysOnTop.Checked then
  285. Form1.FormStyle := fsSystemStayOnTop
  286. else
  287. Form1.FormStyle := fsNormal;
  288. end;
  289. procedure TForm1.chkAutoRefreshChange(Sender: TObject);
  290. begin
  291. if chkAutoRefresh.Checked then
  292. chkAutoPlay.Enabled := True
  293. else
  294. chkAutoPlay.Enabled := False;
  295. end;
  296. procedure TForm1.FormShow(Sender: TObject);
  297. var v:TStringList;
  298. begin
  299. try
  300. v:=TStringList.Create;
  301. DateEdit1.Date := now();
  302. UpdateMessages(FormatDateTime('YYYY-MM-DD', DateEdit1.Date));
  303. v.LoadFromFile('version');
  304. Label3.Caption:='Версия '+ v.Text;
  305. v.Free;
  306. except
  307. //
  308. end;
  309. end;
  310. procedure TForm1.FormWindowStateChange(Sender: TObject);
  311. begin
  312. if Form1.WindowState = wsMinimized then
  313. begin
  314. form1.WindowState := wsNormal;
  315. form1.Hide;
  316. Form1.ShowInTaskBar := stNever;
  317. Form1.TrayIcon1.BalloonHint :=
  318. 'Программа все еще запущена. Чтобы отключить вместо сворачивания закройте её.';
  319. Form1.TrayIcon1.ShowBalloonHint;
  320. end;
  321. end;
  322. procedure TForm1.StringGrid1DblClick(Sender: TObject);
  323. begin
  324. PlayThread := TPlayThread.Create(True);
  325. PlayThread.fIdx := StringGrid1.row;
  326. PlayThread.fTimeStamp := get_value(StringGrid1.row, 1);
  327. PlayThread.fTimeStampShow := True;
  328. PlayThread.Resume;
  329. end;
  330. procedure TForm1.TrayIcon1DblClick(Sender: TObject);
  331. begin
  332. Form1.Show;
  333. end;
  334. procedure TForm1.btnRefreshClick(Sender: TObject);
  335. begin
  336. UpdateMessages(FormatDateTime('YYYY-MM-DD', DateEdit1.Date));
  337. count_current := PlayList.Count;
  338. count_prev := count_current;
  339. end;
  340. procedure TForm1.btnTodayClick(Sender: TObject);
  341. begin
  342. DateEdit1.Date := now();
  343. end;
  344. procedure TForm1.Timer1Timer(Sender: TObject);
  345. var
  346. p, raznica: integer;
  347. begin
  348. if ((chkAutoRefresh.Checked) and (chkAutoRefresh.Enabled)) then
  349. begin
  350. Timer1.Enabled := False;
  351. UpdateMessages(FormatDateTime( 'YYYY-MM-DD', Now ));
  352. DateEdit1.Date:=Now;
  353. raznica := count_current - count_prev;
  354. if ((count_current > count_prev) and (chkAutoPlay.Checked) and
  355. (chkAutoPlay.Enabled)) then
  356. begin
  357. for p := 0 to raznica - 1 do
  358. begin
  359. PlayThread := TPlayThread.Create(True);
  360. PlayThread.fIdx := count_current - count_prev - p;
  361. PlayThread.fTimeStamp := get_value(count_current - count_prev - p, 1);
  362. PlayThread.fTimeStampShow := True;
  363. PlayThread.Resume;
  364. end;
  365. end;
  366. Timer1.Enabled := True;
  367. end;
  368. end;
  369. end.