f7fc7a0503
Полосы прокрутки рисует система, и цвет им задать нечем. Единственный способ получить их в своих цветах — не пользоваться системными вовсе. Таблица при этом остаётся обычной: у неё выключаются свои полосы, а прокрутка задаётся свойствами TopRow и LeftCol. По дороге найдены и исправлены три ошибки, две из них — от раскраски окон: - контекстное меню библиотеки перестало открываться: раскраска принудительно создавала системный дескриптор всплывающего меню задолго до показа. Теперь дескриптор только читается; - окно кадрирования падало при открытии: смена режима отрисовки выпадающего списка вызывает его обработчик изменения, а тот обращался к таймеру, который создавался ниже по коду; - полосы не появлялись вовсе: размер содержимого таблицы брался из GridWidth и GridHeight, а с выключенными полосами те возвращают не полный размер. Теперь считается сложением ширин столбцов и высот строк. Многострочные поля в сведениях о проекте и в перепаковке заменены своим журналом: у них оставались системные полосы. Заодно ответ ffprobe стало можно выделить и скопировать. Удалён неиспользуемый uScrollAid: горизонтальная прокрутка колесом теперь внутри журнала и одинакова на обеих системах. Список юнитов в файле проекта приведён в соответствие с тем, что лежит на диске.
445 lines
13 KiB
ObjectPascal
445 lines
13 KiB
ObjectPascal
{
|
||
uRemuxForm — окно перепаковки файлов в другой контейнер.
|
||
|
||
Устройство повторяет диалог ремукса OBS Studio: таблица со строками
|
||
«состояние, исходный файл, целевой файл», последняя строка пустая и
|
||
служит приглашением добавить ещё, файлы можно бросать на окно мышью,
|
||
кнопка запуска превращается в кнопку остановки.
|
||
|
||
Перекодирования здесь нет: меняется только контейнер, потоки копируются
|
||
как есть. Поэтому операция упирается в скорость диска.
|
||
}
|
||
unit uRemuxForm;
|
||
|
||
{$mode objfpc}{$H+}
|
||
|
||
interface
|
||
|
||
uses
|
||
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ComCtrls,
|
||
Grids, ExtCtrls,
|
||
uRemuxQueue, uTheme, uThemedScroll, uLogView;
|
||
|
||
type
|
||
|
||
{ TRemuxForm }
|
||
|
||
TRemuxForm = class(TForm)
|
||
btnAdd: TThemedButton;
|
||
btnClearAll: TThemedButton;
|
||
btnClearDone: TThemedButton;
|
||
btnClose: TThemedButton;
|
||
btnStart: TThemedButton;
|
||
cbTargetExt: TComboBox;
|
||
grid: TStringGrid;
|
||
lblHelp: TLabel;
|
||
lblTarget: TLabel;
|
||
memoLog: TLogView;
|
||
OpenDialog: TOpenDialog;
|
||
pbBar: TProgressBar;
|
||
pnlBottom: TPanel;
|
||
pnlTop: TPanel;
|
||
procedure btnAddClick(Sender: TObject);
|
||
procedure btnClearAllClick(Sender: TObject);
|
||
procedure btnClearDoneClick(Sender: TObject);
|
||
procedure btnCloseClick(Sender: TObject);
|
||
procedure btnStartClick(Sender: TObject);
|
||
procedure cbTargetExtChange(Sender: TObject);
|
||
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
|
||
procedure FormCreate(Sender: TObject);
|
||
procedure FormDropFiles(Sender: TObject; const FileNames: array of string);
|
||
procedure FormShow(Sender: TObject);
|
||
procedure gridSelectEditor(Sender: TObject; aCol, aRow: Integer;
|
||
var Editor: TWinControl);
|
||
procedure gridValidateEntry(Sender: TObject; aCol, aRow: Integer;
|
||
const OldValue: string; var NewValue: string);
|
||
private
|
||
FEntries: TRemuxEntries;
|
||
FThread: TRemuxThread;
|
||
FRunning: Boolean;
|
||
FStartOnShow: Boolean;
|
||
procedure AddFile(const APath: string);
|
||
procedure RebuildGrid;
|
||
procedure UpdateButtons;
|
||
function TargetExt: string;
|
||
function HasOverwrites(out AList: string): Boolean;
|
||
procedure Log(const AText: string);
|
||
procedure ThreadProgress(Sender: TObject);
|
||
procedure ThreadLog(Sender: TObject);
|
||
procedure ThreadItem(Sender: TObject; AIndex: Integer;
|
||
AState: TRemuxState; const AMessage: string);
|
||
procedure ThreadDone(Sender: TObject);
|
||
public
|
||
{ Поставить файлы в очередь программно. Используется при запуске
|
||
программы с именами файлов: так их можно перетащить на значок
|
||
программы или передать из файлового менеджера. }
|
||
procedure AddFiles(const APaths: array of string);
|
||
{ Запустить обработку, как будто нажата кнопка. }
|
||
procedure StartQueue;
|
||
{ Запустить очередь сразу после показа окна. }
|
||
property StartQueueOnShow: Boolean read FStartOnShow write FStartOnShow;
|
||
property Running: Boolean read FRunning;
|
||
end;
|
||
|
||
implementation
|
||
|
||
{$R *.lfm}
|
||
|
||
const
|
||
ColState = 0;
|
||
ColSource = 1;
|
||
ColTarget = 2;
|
||
|
||
BarScale = 10000;
|
||
|
||
{ TRemuxForm }
|
||
|
||
procedure TRemuxForm.FormCreate(Sender: TObject);
|
||
begin
|
||
{ Цвета задаём сами: системная тема может быть светлой, и тогда
|
||
тёмный таймлайн оказался бы в белой рамке. }
|
||
ApplyDarkTheme(Self);
|
||
{ Системные полосы прокрутки у таблицы светлые и цвета не берут —
|
||
заменяем своими. }
|
||
AttachThemedScrollBars(grid);
|
||
Caption := 'Перепаковка файлов';
|
||
lblHelp.Caption :=
|
||
'Смена контейнера без перекодирования. Перетащите файлы на окно ' +
|
||
'или нажмите «Добавить». Целевой путь можно исправить прямо в таблице.';
|
||
|
||
AllowDropFiles := True;
|
||
|
||
grid.ColCount := 3;
|
||
grid.RowCount := 1;
|
||
grid.FixedRows := 1;
|
||
grid.Cells[ColState, 0] := 'Состояние';
|
||
grid.Cells[ColSource, 0] := 'Исходный файл';
|
||
grid.Cells[ColTarget, 0] := 'Целевой файл';
|
||
grid.ColWidths[ColState] := 100;
|
||
grid.ColWidths[ColSource] := 380;
|
||
grid.ColWidths[ColTarget] := 380;
|
||
|
||
cbTargetExt.Items.Clear;
|
||
cbTargetExt.Items.Add('.mp4');
|
||
cbTargetExt.Items.Add('.mkv');
|
||
cbTargetExt.Items.Add('.mov');
|
||
cbTargetExt.ItemIndex := 0;
|
||
|
||
pbBar.Min := 0;
|
||
pbBar.Max := BarScale;
|
||
pbBar.Position := 0;
|
||
pbBar.Visible := False;
|
||
|
||
memoLog.Clear;
|
||
RebuildGrid;
|
||
UpdateButtons;
|
||
end;
|
||
|
||
function TRemuxForm.TargetExt: string;
|
||
begin
|
||
if cbTargetExt.ItemIndex >= 0 then
|
||
Result := cbTargetExt.Items[cbTargetExt.ItemIndex]
|
||
else
|
||
Result := '.mp4';
|
||
end;
|
||
|
||
procedure TRemuxForm.AddFile(const APath: string);
|
||
var
|
||
N: Integer;
|
||
begin
|
||
N := Length(FEntries);
|
||
SetLength(FEntries, N + 1);
|
||
FEntries[N].Source := APath;
|
||
FEntries[N].Target := SuggestTarget(APath, TargetExt);
|
||
FEntries[N].Message := '';
|
||
if FileExists(APath) then
|
||
FEntries[N].State := rsReady
|
||
else
|
||
FEntries[N].State := rsBadPath;
|
||
end;
|
||
|
||
procedure TRemuxForm.RebuildGrid;
|
||
var
|
||
I: Integer;
|
||
{ Не Text: так называется свойство TControl, и внутри метода формы
|
||
локальная переменная его перекроет. }
|
||
StateText: string;
|
||
begin
|
||
{ Строк на одну больше, чем записей: последняя пустая — приглашение
|
||
добавить ещё, как в диалоге OBS. }
|
||
grid.RowCount := Length(FEntries) + 2;
|
||
for I := 0 to High(FEntries) do
|
||
begin
|
||
StateText := StateCaption(FEntries[I].State);
|
||
if FEntries[I].Message <> '' then
|
||
StateText := StateText + ' — ' + FEntries[I].Message;
|
||
grid.Cells[ColState, I + 1] := StateText;
|
||
grid.Cells[ColSource, I + 1] := FEntries[I].Source;
|
||
grid.Cells[ColTarget, I + 1] := FEntries[I].Target;
|
||
end;
|
||
grid.Cells[ColState, grid.RowCount - 1] := '';
|
||
grid.Cells[ColSource, grid.RowCount - 1] := '';
|
||
grid.Cells[ColTarget, grid.RowCount - 1] := '';
|
||
end;
|
||
|
||
procedure TRemuxForm.UpdateButtons;
|
||
var
|
||
I: Integer;
|
||
HasWork, HasDone: Boolean;
|
||
begin
|
||
HasWork := False;
|
||
HasDone := False;
|
||
for I := 0 to High(FEntries) do
|
||
begin
|
||
if FEntries[I].State = rsReady then
|
||
HasWork := True;
|
||
if FEntries[I].State in [rsDone, rsError, rsBadPath] then
|
||
HasDone := True;
|
||
end;
|
||
|
||
if FRunning then
|
||
btnStart.Caption := 'Стоп'
|
||
else
|
||
btnStart.Caption := 'Перепаковать';
|
||
|
||
btnStart.Enabled := FRunning or HasWork;
|
||
btnAdd.Enabled := not FRunning;
|
||
btnClearDone.Enabled := (not FRunning) and HasDone;
|
||
btnClearAll.Enabled := (not FRunning) and (Length(FEntries) > 0);
|
||
cbTargetExt.Enabled := not FRunning;
|
||
grid.Enabled := not FRunning;
|
||
end;
|
||
|
||
procedure TRemuxForm.Log(const AText: string);
|
||
begin
|
||
memoLog.Add(AText);
|
||
end;
|
||
|
||
procedure TRemuxForm.FormShow(Sender: TObject);
|
||
begin
|
||
if FStartOnShow then
|
||
begin
|
||
FStartOnShow := False;
|
||
StartQueue;
|
||
end;
|
||
end;
|
||
|
||
procedure TRemuxForm.AddFiles(const APaths: array of string);
|
||
var
|
||
I: Integer;
|
||
begin
|
||
for I := 0 to High(APaths) do
|
||
AddFile(APaths[I]);
|
||
RebuildGrid;
|
||
UpdateButtons;
|
||
end;
|
||
|
||
procedure TRemuxForm.StartQueue;
|
||
begin
|
||
if not FRunning then
|
||
btnStartClick(nil);
|
||
end;
|
||
|
||
procedure TRemuxForm.btnAddClick(Sender: TObject);
|
||
var
|
||
I: Integer;
|
||
begin
|
||
if not OpenDialog.Execute then
|
||
Exit;
|
||
for I := 0 to OpenDialog.Files.Count - 1 do
|
||
AddFile(OpenDialog.Files[I]);
|
||
RebuildGrid;
|
||
UpdateButtons;
|
||
end;
|
||
|
||
procedure TRemuxForm.FormDropFiles(Sender: TObject;
|
||
const FileNames: array of string);
|
||
var
|
||
I: Integer;
|
||
begin
|
||
if FRunning then
|
||
Exit;
|
||
for I := 0 to High(FileNames) do
|
||
AddFile(FileNames[I]);
|
||
RebuildGrid;
|
||
UpdateButtons;
|
||
end;
|
||
|
||
procedure TRemuxForm.cbTargetExtChange(Sender: TObject);
|
||
var
|
||
I: Integer;
|
||
begin
|
||
{ Уже обработанные строки не трогаем: их файлы существуют, менять им
|
||
имя задним числом бессмысленно. }
|
||
for I := 0 to High(FEntries) do
|
||
if FEntries[I].State in [rsReady, rsBadPath] then
|
||
FEntries[I].Target := SuggestTarget(FEntries[I].Source, TargetExt);
|
||
RebuildGrid;
|
||
end;
|
||
|
||
procedure TRemuxForm.gridSelectEditor(Sender: TObject; aCol, aRow: Integer;
|
||
var Editor: TWinControl);
|
||
begin
|
||
{ Править разрешено только целевой путь: состояние вычисляется, а
|
||
исходный файл задаётся добавлением. }
|
||
if aCol <> ColTarget then
|
||
Editor := nil;
|
||
end;
|
||
|
||
procedure TRemuxForm.gridValidateEntry(Sender: TObject; aCol, aRow: Integer;
|
||
const OldValue: string; var NewValue: string);
|
||
begin
|
||
if (aCol = ColTarget) and (aRow >= 1) and (aRow <= Length(FEntries)) then
|
||
FEntries[aRow - 1].Target := NewValue;
|
||
end;
|
||
|
||
function TRemuxForm.HasOverwrites(out AList: string): Boolean;
|
||
var
|
||
I: Integer;
|
||
begin
|
||
AList := '';
|
||
for I := 0 to High(FEntries) do
|
||
if (FEntries[I].State = rsReady) and FileExists(FEntries[I].Target) then
|
||
AList := AList + LineEnding + FEntries[I].Target;
|
||
Result := AList <> '';
|
||
end;
|
||
|
||
procedure TRemuxForm.btnStartClick(Sender: TObject);
|
||
var
|
||
I: Integer;
|
||
Overwrites: string;
|
||
begin
|
||
if FRunning then
|
||
begin
|
||
if Assigned(FThread) then
|
||
begin
|
||
FThread.RequestCancel;
|
||
btnStart.Enabled := False;
|
||
Log('Останавливаю...');
|
||
end;
|
||
Exit;
|
||
end;
|
||
|
||
if HasOverwrites(Overwrites) then
|
||
if ThemedMessageDlg('Перепаковка',
|
||
'Эти файлы уже существуют и будут перезаписаны:' + LineEnding +
|
||
Overwrites + LineEnding + LineEnding + 'Продолжить?',
|
||
mtWarning, [mbYes, mbNo], 0) <> mrYes then
|
||
Exit;
|
||
|
||
for I := 0 to High(FEntries) do
|
||
if FEntries[I].State = rsReady then
|
||
begin
|
||
FEntries[I].State := rsPending;
|
||
FEntries[I].Message := '';
|
||
end;
|
||
RebuildGrid;
|
||
|
||
FThread := TRemuxThread.Create(FEntries);
|
||
FThread.OnProgress := @ThreadProgress;
|
||
FThread.OnLog := @ThreadLog;
|
||
FThread.OnItem := @ThreadItem;
|
||
FThread.OnTerminate := @ThreadDone;
|
||
|
||
FRunning := True;
|
||
pbBar.Position := 0;
|
||
pbBar.Visible := True;
|
||
UpdateButtons;
|
||
FThread.Start;
|
||
end;
|
||
|
||
procedure TRemuxForm.ThreadProgress(Sender: TObject);
|
||
begin
|
||
pbBar.Position := Round(FThread.Fraction * BarScale);
|
||
end;
|
||
|
||
procedure TRemuxForm.ThreadLog(Sender: TObject);
|
||
begin
|
||
Log(FThread.PendingLog);
|
||
end;
|
||
|
||
procedure TRemuxForm.ThreadItem(Sender: TObject; AIndex: Integer;
|
||
AState: TRemuxState; const AMessage: string);
|
||
begin
|
||
{ AIndex — номер строки в этом же списке: поток отдаёт исходные номера. }
|
||
if (AIndex < 0) or (AIndex > High(FEntries)) then
|
||
Exit;
|
||
FEntries[AIndex].State := AState;
|
||
FEntries[AIndex].Message := AMessage;
|
||
RebuildGrid;
|
||
end;
|
||
|
||
procedure TRemuxForm.ThreadDone(Sender: TObject);
|
||
var
|
||
I, Ok, Bad: Integer;
|
||
begin
|
||
FRunning := False;
|
||
pbBar.Position := BarScale;
|
||
|
||
Ok := 0;
|
||
Bad := 0;
|
||
for I := 0 to High(FEntries) do
|
||
begin
|
||
{ Всё, что осталось в очереди после остановки, снова становится
|
||
готовым к работе. }
|
||
if FEntries[I].State in [rsPending, rsInProgress] then
|
||
FEntries[I].State := rsReady;
|
||
if FEntries[I].State = rsDone then
|
||
Inc(Ok);
|
||
if FEntries[I].State in [rsError, rsBadPath] then
|
||
Inc(Bad);
|
||
end;
|
||
|
||
RebuildGrid;
|
||
UpdateButtons;
|
||
|
||
FThread := nil;
|
||
|
||
if Bad > 0 then
|
||
Log(Format('Завершено. Успешно: %d, с ошибками: %d.', [Ok, Bad]))
|
||
else
|
||
Log(Format('Завершено. Успешно: %d.', [Ok]));
|
||
end;
|
||
|
||
procedure TRemuxForm.btnClearDoneClick(Sender: TObject);
|
||
var
|
||
I, N: Integer;
|
||
Kept: TRemuxEntries = nil;
|
||
begin
|
||
N := 0;
|
||
SetLength(Kept, Length(FEntries));
|
||
for I := 0 to High(FEntries) do
|
||
if not (FEntries[I].State in [rsDone, rsError, rsBadPath]) then
|
||
begin
|
||
Kept[N] := FEntries[I];
|
||
Inc(N);
|
||
end;
|
||
SetLength(Kept, N);
|
||
FEntries := Kept;
|
||
RebuildGrid;
|
||
UpdateButtons;
|
||
end;
|
||
|
||
procedure TRemuxForm.btnClearAllClick(Sender: TObject);
|
||
begin
|
||
FEntries := nil;
|
||
RebuildGrid;
|
||
UpdateButtons;
|
||
end;
|
||
|
||
procedure TRemuxForm.btnCloseClick(Sender: TObject);
|
||
begin
|
||
Close;
|
||
end;
|
||
|
||
procedure TRemuxForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
|
||
begin
|
||
CanClose := not FRunning;
|
||
if not CanClose then
|
||
begin
|
||
ThemedMessageDlg('Перепаковка',
|
||
'Сначала остановите обработку.', mtInformation, [mbOK], 0);
|
||
end;
|
||
end;
|
||
|
||
end.
|