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

unit1.pas 11KB

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