|
|
- unit Unit1;
-
- {$mode objfpc}{$H+}
-
- interface
-
- uses
- Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, EditBtn,
- StdCtrls, LCLProc, Buttons, ExtCtrls, ComCtrls, Grids, UTF8Process, process,
- ShellApi, httpsend;
-
- type
- TPlayThread = class(TThread)
- private
- fBusy: boolean;
- fIdx: integer;
- fTimeStamp: string;
- fTimeStampShow: boolean;
- procedure Hint;
- procedure Busy;
- procedure Play;
- procedure CheckBusy;
- procedure ThreadTerminate;
- procedure DownloadMessage;
- protected
- procedure Execute; override;
- public
- constructor Create(CreateSuspended: boolean);
- end;
-
- type
-
- { TForm1 }
-
- TForm1 = class(TForm)
- btnSave: TButton;
- chkAlwaysOnTop: TCheckBox;
- chkAutoRefresh: TCheckBox;
- chkAutoPlay: TCheckBox;
- DateEdit1: TDateEdit;
- intervalEdit: TEdit;
- Image1: TImage;
- Label1: TLabel;
- Label2: TLabel;
- Label3: TLabel;
- Label4: TLabel;
- Label5: TLabel;
- Label6: TLabel;
- SaveDialog1: TSaveDialog;
- btnRefresh: TSpeedButton;
- btnToday: TSpeedButton;
- StatusBar1: TStatusBar;
- StringGrid1: TStringGrid;
- Timer1: TTimer;
- TrayIcon1: TTrayIcon;
- UpDown1: TUpDown;
- procedure btnSaveClick(Sender: TObject);
- procedure chkAlwaysOnTopChange(Sender: TObject);
- procedure chkAutoRefreshChange(Sender: TObject);
- procedure DateEdit1Change(Sender: TObject);
- procedure FormShow(Sender: TObject);
- procedure btnRefreshClick(Sender: TObject);
- procedure btnTodayClick(Sender: TObject);
- procedure FormWindowStateChange(Sender: TObject);
- procedure StringGrid1DblClick(Sender: TObject);
- procedure Timer1Timer(Sender: TObject);
- procedure TrayIcon1DblClick(Sender: TObject);
- procedure UpdateMessages(date: string);
- procedure DownloadMessage(fIdx: integer; fName: string);
- procedure UpDown1ChangingEx(Sender: TObject; var AllowChange: Boolean;
- NewValue: SmallInt; Direction: TUpDownDirection);
- private
- { private declarations }
- public
- { public declarations }
- end;
-
- var
- Form1: TForm1;
- count_prev, count_current: integer;
- PlayQueue: integer;
- PlayBusy: boolean;
- PlayThread: TPlayThread;
- PlayList: TStringList;
-
- implementation
-
- {$R *.lfm}
-
- { TForm1 }
-
-
- procedure TForm1.UpdateMessages(date: string);
- var
- url: string;
- csv: TStringList;
- begin
- url := 'http://tomsk.cb-radio.ru/archive.php?date='; //2015-02-27
- csv := TStringList.Create;
- with THTTPSend.Create do
- begin
- if HTTPMethod('GET', url + date) then
- try
- csv.LoadFromStream(Document);
- csv.Text := StringReplace(csv.Text, '''', '', [rfReplaceAll]);
- csv.SaveToFile(GetTempDir(False) + 'playlist.csv');
- if not Assigned(PlayList) then
- PlayList := TStringList.Create;
- count_prev := count_current;
- PlayList.Clear;
- PlayList.LoadFromFile(GetTempDir(False) + 'playlist.csv');
- StringGrid1.Clean;
- StringGrid1.RowCount := 0;
- StringGrid1.LoadFromCSVFile(GetTempDir(False) + 'playlist.csv');
- StringGrid1.InsertRowWithValues(0, ['Дата', 'Время', 'Длит', 'Путь']);
- StringGrid1.DeleteCol(0);
- StringGrid1.DeleteCol(2);
- StringGrid1.Row := 0;
- count_current := PlayList.Count;
- Label5.Caption := IntToStr(PlayList.Count);
- StatusBar1.Panels[0].Text := TimeToStr(now()) + ' Скачан список файлов';
- except
- //Application.MessageBox('Ошибка при скачивании списка воспроизведения','Error', 0);
- end;
- Free;
- end;
- csv.Free;
- if PlayList.Count > 0 then
- begin
- btnSave.Enabled := True;
- end
- else
- begin
- btnSave.Enabled := False;
- end;
- if chkAutoRefresh.Checked then
- DateEdit1.Text := FormatDateTime('DD.MM.YYYY', Now);
- if (DateToStr(DateEdit1.Date) = DateToStr(Now)) then
- begin
- btnRefresh.Enabled := True;
- chkAutoRefresh.Enabled := True;
- //chkAutoRefresh.Checked := False;
- //chkAutoPlay.Enabled := False;
- //chkAutoPlay.Checked := False;
- end
- else
- begin
- btnRefresh.Enabled := False;
- chkAutoRefresh.Enabled := False;
- chkAutoRefresh.Checked := False;
- chkAutoPlay.Enabled := False;
- chkAutoPlay.Checked := False;
- end;
- end;
-
- function get_value(item, Value: integer): string;
- var
- params: TStringList;
- begin
- params := TStringList.Create;
- params.Delimiter := ',';
- params.DelimitedText := PlayList[item - 1];
- Result := params[Value];
- params.Free;
- end;
-
- procedure TForm1.DownloadMessage(fIdx: integer; fName: string);
- var
- url, path: string;
- memstream: TMemoryStream;
- begin
- url := 'http://tomsk.cb-radio.ru/archive/';
- path := get_value(fIdx, 3);
- with THTTPSend.Create do
- begin
- if HTTPMethod('GET', url + path) then
- try
- memstream := TMemoryStream.Create;
- memstream := Document;
- memstream.SaveToFile(UTF8ToSys(fName));
- memstream.Free;
- except
- Application.MessageBox('Ошибка при скачивании файла', 'Error', 0);
- end;
- end;
- end;
-
-
- procedure TForm1.UpDown1ChangingEx(Sender: TObject; var AllowChange: Boolean;
- NewValue: SmallInt; Direction: TUpDownDirection);
- begin
- Timer1.Interval:=NewValue * 1000;
- end;
-
- procedure TPlayThread.DownloadMessage();
- var
- url, path: string;
- memstream: TMemoryStream;
- begin
- url := 'http://tomsk.cb-radio.ru/archive/';
- path := get_value(fIdx, 3);
- with THTTPSend.Create do
- begin
- if HTTPMethod('GET', url + path) then
- try
- memstream := TMemoryStream.Create;
- memstream := Document;
- memstream.SaveToFile(SysToUTF8(GetTempDir(False) + 'ak47.mp3'));
- memstream.Free;
- except
- Application.MessageBox('Ошибка при скачивании файла', 'Error', 0);
- end;
- end;
- end;
-
- constructor TPlayThread.Create(CreateSuspended: boolean);
- begin
- FreeOnTerminate := True;
- inherited Create(CreateSuspended);
- Inc(PlayQueue);
- end;
-
- procedure TPlayThread.ThreadTerminate;
- begin
- Dec(PlayQueue);
- end;
-
-
- procedure TplayThread.Busy;
- begin
- if fBusy = True then
- begin
- PlayBusy := True;
- end
- else
- begin
- PlayBusy := False;
- end;
- end;
-
- procedure TPlayThread.CheckBusy;
- begin
- if PlayBusy = True then
- begin
- fBusy := True;
- end
- else
- begin
- fBusy := False;
- end;
- end;
-
- procedure TPlayThread.Hint;
- begin
- Form1.TrayIcon1.BalloonHint := fTimeStamp;
- Form1.TrayIcon1.ShowBalloonHint;
- end;
-
- procedure TPlayThread.Execute;
- begin
- Synchronize(@CheckBusy);
- while (not Terminated) and (fBusy = True) do
- begin
- sleep(2000);
- Synchronize(@CheckBusy);
- end;
- fBusy := True;
- Synchronize(@Busy);
- if fTimeStampShow then
- Synchronize(@Hint);
- Play();
- fBusy := False;
- Synchronize(@Busy);
- Synchronize(@ThreadTerminate);
- Terminate;
- end;
-
- procedure TPlayThread.play();
- var
- tmp: ansistring;
- Player: TProcessUTF8;
- PlayerPath: ansistring;
- PlayerParams: ansistring;
- begin
- //tmp := GetTempDir(False) + 'ak47.mp3';
- //Synchronize(@DownloadMessage);
- PlayerPath := SysToUTF8(ExtractFileDir(Application.ExeName) + '\mpg123.exe');
- //PlayerParams := SysToUTF8(' -q "' + tmp + '"');
- PlayerParams := '-q http://tomsk.cb-radio.ru/archive/' + get_value(fIdx, 3);
- Player := TProcessUTF8.Create(nil);
- Form1.StatusBar1.Panels.Items[0].Text := 'Играет запись от ' + fTimeStamp;
- Form1.StatusBar1.Panels.Items[1].Text := 'В очереди ' + IntToStr(PlayQueue);
- try
- Player.CommandLine := PlayerPath + ' ' + PlayerParams;
- Player.Options := Player.Options + [poNoConsole, poWaitOnExit];
- Player.Execute;
- finally
- Player.Free;
- end;
- Form1.StatusBar1.Panels.Items[0].Text := '';
- Form1.StatusBar1.Panels.Items[1].Text := '';
- end;
-
- procedure TForm1.DateEdit1Change(Sender: TObject);
- begin
- try
- UpdateMessages(FormatDateTime('YYYY-MM-DD', DateEdit1.Date));
- except
- end;
- end;
-
- procedure TForm1.btnSaveClick(Sender: TObject);
- begin
- SaveDialog1.FileName := StringReplace(get_value(StringGrid1.Row, 0) +
- ' ' + get_value(StringGrid1.Row, 1), ':', '_', [rfReplaceAll]);
- if SaveDialog1.Execute then
- begin
- DownloadMessage(StringGrid1.Row, SaveDialog1.FileName);
- end;
- end;
-
- procedure TForm1.chkAlwaysOnTopChange(Sender: TObject);
- begin
- if chkAlwaysOnTop.Checked then
- Form1.FormStyle := fsSystemStayOnTop
- else
- Form1.FormStyle := fsNormal;
- end;
-
- procedure TForm1.chkAutoRefreshChange(Sender: TObject);
- begin
- if chkAutoRefresh.Checked then
- chkAutoPlay.Enabled := True
- else
- chkAutoPlay.Enabled := False;
- end;
-
- procedure TForm1.FormShow(Sender: TObject);
- var
- v: TStringList;
- begin
- try
- v := TStringList.Create;
- DateEdit1.Date := now();
- UpdateMessages(FormatDateTime('YYYY-MM-DD', DateEdit1.Date));
- v.LoadFromFile('version');
- Label3.Caption := 'Версия ' + v.Text;
- v.Free;
- if FileExists(ExtractFileDir(Application.ExeName) + '\ark_laucher.new') then
- begin
- DeleteFileUTF8(ExtractFileDir(Application.ExeName) + '\ark_laucher.exe');
- RenameFileUTF8(ExtractFileDir(Application.ExeName) + '\ark_laucher.new',
- ExtractFileDir(Application.ExeName) + '\ark_laucher.exe');
- end;
- except
-
- end;
- end;
-
- procedure TForm1.FormWindowStateChange(Sender: TObject);
- begin
- if Form1.WindowState = wsMinimized then
- begin
- form1.WindowState := wsNormal;
- form1.Hide;
- Form1.ShowInTaskBar := stNever;
- Form1.TrayIcon1.BalloonHint :=
- 'Программа все еще запущена. Чтобы отключить вместо сворачивания закройте её.';
- Form1.TrayIcon1.ShowBalloonHint;
- end;
- end;
-
- procedure TForm1.StringGrid1DblClick(Sender: TObject);
- begin
- PlayThread := TPlayThread.Create(True);
- PlayThread.fIdx := StringGrid1.row;
- PlayThread.fTimeStamp := get_value(StringGrid1.row, 1);
- PlayThread.fTimeStampShow := True;
- PlayThread.Resume;
- end;
-
- procedure TForm1.TrayIcon1DblClick(Sender: TObject);
- begin
- Form1.Show;
- end;
-
- procedure TForm1.btnRefreshClick(Sender: TObject);
- begin
- UpdateMessages(FormatDateTime('YYYY-MM-DD', DateEdit1.Date));
- count_current := PlayList.Count;
- count_prev := count_current;
- end;
-
- procedure TForm1.btnTodayClick(Sender: TObject);
- begin
- DateEdit1.Date := now();
- end;
-
- procedure TForm1.Timer1Timer(Sender: TObject);
- var
- p, raznica: integer;
- begin
- if ((chkAutoRefresh.Checked) and (chkAutoRefresh.Enabled)) then
- begin
- Timer1.Enabled := False;
- UpdateMessages(FormatDateTime('YYYY-MM-DD', Now));
- DateEdit1.Date := Now;
- raznica := count_current - count_prev;
- if ((count_current > count_prev) and (chkAutoPlay.Checked) and
- (chkAutoPlay.Enabled)) then
- begin
- for p := 0 to raznica - 1 do
- begin
- PlayThread := TPlayThread.Create(True);
- PlayThread.fIdx := count_current - count_prev - p;
- PlayThread.fTimeStamp := get_value(count_current - count_prev - p, 1);
- PlayThread.fTimeStampShow := True;
- PlayThread.Resume;
- end;
- end;
- Timer1.Enabled := True;
- end;
- end;
-
- end.
|