Программа для прослушивания журнала АРК Томск 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.

414 lines
11KB

  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://radio70.ru/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
  119. DateEdit1.Text := FormatDateTime('DD.MM.YYYY', Now);
  120. if (DateToStr(DateEdit1.Date) = DateToStr(Now)) then
  121. begin
  122. btnRefresh.Enabled := True;
  123. chkAutoRefresh.Enabled := True;
  124. //chkAutoRefresh.Checked := False;
  125. //chkAutoPlay.Enabled := False;
  126. //chkAutoPlay.Checked := False;
  127. end
  128. else
  129. begin
  130. btnRefresh.Enabled := False;
  131. chkAutoRefresh.Enabled := False;
  132. chkAutoRefresh.Checked := False;
  133. chkAutoPlay.Enabled := False;
  134. chkAutoPlay.Checked := False;
  135. end;
  136. end;
  137. function get_value(item, Value: integer): string;
  138. var
  139. params: TStringList;
  140. begin
  141. params := TStringList.Create;
  142. params.Delimiter := ',';
  143. params.DelimitedText := PlayList[item - 1];
  144. Result := params[Value];
  145. params.Free;
  146. end;
  147. procedure TForm1.DownloadMessage(fIdx: integer; fName: string);
  148. var
  149. url, path: string;
  150. memstream: TMemoryStream;
  151. begin
  152. url := 'http://radio70.ru/archive/';
  153. path := get_value(fIdx, 3);
  154. with THTTPSend.Create do
  155. begin
  156. if HTTPMethod('GET', url + path) then
  157. try
  158. memstream := TMemoryStream.Create;
  159. memstream := Document;
  160. memstream.SaveToFile(UTF8ToSys(fName));
  161. memstream.Free;
  162. except
  163. Application.MessageBox('Ошибка при скачивании файла', 'Error', 0);
  164. end;
  165. end;
  166. end;
  167. procedure TPlayThread.DownloadMessage();
  168. var
  169. url, path: string;
  170. memstream: TMemoryStream;
  171. begin
  172. url := 'http://radio70.ru/archive/';
  173. path := get_value(fIdx, 3);
  174. with THTTPSend.Create do
  175. begin
  176. if HTTPMethod('GET', url + path) then
  177. try
  178. memstream := TMemoryStream.Create;
  179. memstream := Document;
  180. memstream.SaveToFile(SysToUTF8(GetTempDir(False) + 'ak47.mp3'));
  181. memstream.Free;
  182. except
  183. Application.MessageBox('Ошибка при скачивании файла', 'Error', 0);
  184. end;
  185. end;
  186. end;
  187. constructor TPlayThread.Create(CreateSuspended: boolean);
  188. begin
  189. FreeOnTerminate := True;
  190. inherited Create(CreateSuspended);
  191. Inc(PlayQueue);
  192. end;
  193. procedure TPlayThread.ThreadTerminate;
  194. begin
  195. Dec(PlayQueue);
  196. end;
  197. procedure TplayThread.Busy;
  198. begin
  199. if fBusy = True then
  200. begin
  201. PlayBusy := True;
  202. end
  203. else
  204. begin
  205. PlayBusy := False;
  206. end;
  207. end;
  208. procedure TPlayThread.CheckBusy;
  209. begin
  210. if PlayBusy = True then
  211. begin
  212. fBusy := True;
  213. end
  214. else
  215. begin
  216. fBusy := False;
  217. end;
  218. end;
  219. procedure TPlayThread.Hint;
  220. begin
  221. Form1.TrayIcon1.BalloonHint := fTimeStamp;
  222. Form1.TrayIcon1.ShowBalloonHint;
  223. end;
  224. procedure TPlayThread.Execute;
  225. begin
  226. Synchronize(@CheckBusy);
  227. while (not Terminated) and (fBusy = True) do
  228. begin
  229. sleep(2000);
  230. Synchronize(@CheckBusy);
  231. end;
  232. fBusy := True;
  233. Synchronize(@Busy);
  234. if fTimeStampShow then
  235. Synchronize(@Hint);
  236. Play();
  237. fBusy := False;
  238. Synchronize(@Busy);
  239. Synchronize(@ThreadTerminate);
  240. Terminate;
  241. end;
  242. procedure TPlayThread.play();
  243. var
  244. tmp: ansistring;
  245. Player: TProcessUTF8;
  246. PlayerPath: ansistring;
  247. PlayerParams: ansistring;
  248. begin
  249. //tmp := GetTempDir(False) + 'ak47.mp3';
  250. //Synchronize(@DownloadMessage);
  251. PlayerPath := SysToUTF8(ExtractFileDir(Application.ExeName) + '\mpg123.exe');
  252. //PlayerParams := SysToUTF8(' -q "' + tmp + '"');
  253. PlayerParams := '-q http://radio70.ru/archive/' + get_value(fIdx, 3);
  254. Player := TProcessUTF8.Create(nil);
  255. Form1.StatusBar1.Panels.Items[0].Text := 'Играет запись от ' + fTimeStamp;
  256. Form1.StatusBar1.Panels.Items[1].Text := 'В очереди ' + IntToStr(PlayQueue);
  257. try
  258. Player.CommandLine := PlayerPath + ' ' + PlayerParams;
  259. Player.Options := Player.Options + [poNoConsole, poWaitOnExit];
  260. Player.Execute;
  261. finally
  262. Player.Free;
  263. end;
  264. Form1.StatusBar1.Panels.Items[0].Text := '';
  265. Form1.StatusBar1.Panels.Items[1].Text := '';
  266. end;
  267. procedure TForm1.DateEdit1Change(Sender: TObject);
  268. begin
  269. try
  270. UpdateMessages(FormatDateTime('YYYY-MM-DD', DateEdit1.Date));
  271. except
  272. end;
  273. end;
  274. procedure TForm1.btnSaveClick(Sender: TObject);
  275. begin
  276. SaveDialog1.FileName := StringReplace(get_value(StringGrid1.Row, 0) +
  277. ' ' + get_value(StringGrid1.Row, 1), ':', '_', [rfReplaceAll]);
  278. if SaveDialog1.Execute then
  279. begin
  280. DownloadMessage(StringGrid1.Row, SaveDialog1.FileName);
  281. end;
  282. end;
  283. procedure TForm1.chkAlwaysOnTopChange(Sender: TObject);
  284. begin
  285. if chkAlwaysOnTop.Checked then
  286. Form1.FormStyle := fsSystemStayOnTop
  287. else
  288. Form1.FormStyle := fsNormal;
  289. end;
  290. procedure TForm1.chkAutoRefreshChange(Sender: TObject);
  291. begin
  292. if chkAutoRefresh.Checked then
  293. chkAutoPlay.Enabled := True
  294. else
  295. chkAutoPlay.Enabled := False;
  296. end;
  297. procedure TForm1.FormShow(Sender: TObject);
  298. var
  299. v: TStringList;
  300. begin
  301. try
  302. v := TStringList.Create;
  303. DateEdit1.Date := now();
  304. UpdateMessages(FormatDateTime('YYYY-MM-DD', DateEdit1.Date));
  305. v.LoadFromFile('version');
  306. Label3.Caption := 'Версия ' + v.Text;
  307. v.Free;
  308. if FileExists(ExtractFileDir(Application.ExeName) + '\ark_laucher.new') then
  309. begin
  310. DeleteFileUTF8(ExtractFileDir(Application.ExeName) + '\ark_laucher.exe');
  311. RenameFileUTF8(ExtractFileDir(Application.ExeName) + '\ark_laucher.new',
  312. ExtractFileDir(Application.ExeName) + '\ark_laucher.exe');
  313. end;
  314. except
  315. end;
  316. end;
  317. procedure TForm1.FormWindowStateChange(Sender: TObject);
  318. begin
  319. if Form1.WindowState = wsMinimized then
  320. begin
  321. form1.WindowState := wsNormal;
  322. form1.Hide;
  323. Form1.ShowInTaskBar := stNever;
  324. Form1.TrayIcon1.BalloonHint :=
  325. 'Программа все еще запущена. Чтобы отключить вместо сворачивания закройте её.';
  326. Form1.TrayIcon1.ShowBalloonHint;
  327. end;
  328. end;
  329. procedure TForm1.StringGrid1DblClick(Sender: TObject);
  330. begin
  331. PlayThread := TPlayThread.Create(True);
  332. PlayThread.fIdx := StringGrid1.row;
  333. PlayThread.fTimeStamp := get_value(StringGrid1.row, 1);
  334. PlayThread.fTimeStampShow := True;
  335. PlayThread.Resume;
  336. end;
  337. procedure TForm1.TrayIcon1DblClick(Sender: TObject);
  338. begin
  339. Form1.Show;
  340. end;
  341. procedure TForm1.btnRefreshClick(Sender: TObject);
  342. begin
  343. UpdateMessages(FormatDateTime('YYYY-MM-DD', DateEdit1.Date));
  344. count_current := PlayList.Count;
  345. count_prev := count_current;
  346. end;
  347. procedure TForm1.btnTodayClick(Sender: TObject);
  348. begin
  349. DateEdit1.Date := now();
  350. end;
  351. procedure TForm1.Timer1Timer(Sender: TObject);
  352. var
  353. p, raznica: integer;
  354. begin
  355. if ((chkAutoRefresh.Checked) and (chkAutoRefresh.Enabled)) then
  356. begin
  357. Timer1.Enabled := False;
  358. UpdateMessages(FormatDateTime('YYYY-MM-DD', Now));
  359. DateEdit1.Date := Now;
  360. raznica := count_current - count_prev;
  361. if ((count_current > count_prev) and (chkAutoPlay.Checked) and
  362. (chkAutoPlay.Enabled)) then
  363. begin
  364. for p := 0 to raznica - 1 do
  365. begin
  366. PlayThread := TPlayThread.Create(True);
  367. PlayThread.fIdx := count_current - count_prev - p;
  368. PlayThread.fTimeStamp := get_value(count_current - count_prev - p, 1);
  369. PlayThread.fTimeStampShow := True;
  370. PlayThread.Resume;
  371. end;
  372. end;
  373. Timer1.Enabled := True;
  374. end;
  375. end;
  376. end.