Программа для прослушивания журнала АРК Томск http://blindage.org/?p=6627
Ви не можете вибрати більше 25 тем Теми мають розпочинатися з літери або цифри, можуть містити дефіси (-) і не повинні перевищувати 35 символів.
 
 
 
 
 
 

425 рядки
11 KiB

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.