unit MainFrm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, ComCtrls, Menus, FFmpeg, FFmpegVCL;
type
TfrmMain = class(TForm)
btnAdd: TButton;
mmoLog: TMemo;
OpenDialog1: TOpenDialog;
btnStop: TButton;
chkThreadMode: TCheckBox;
chkVerNum: TCheckBox;
btnPause: TButton;
FFVCL: TFFmpegVCL;
btnStart: TButton;
btnResume: TButton;
edtThreadCount: TEdit;
Label7: TLabel;
btnRemove: TButton;
btnClear: TButton;
grpOption: TGroupBox;
lvFiles: TListView;
btnExit: TButton;
grpLogLevel: TRadioGroup;
grpPriority: TRadioGroup;
btnWebSite: TButton;
PopupMenu1: TPopupMenu;
mnuAdd: TMenuItem;
mnuRemove: TMenuItem;
mnuClear: TMenuItem;
N1: TMenuItem;
mnuOpenFolder: TMenuItem;
mnuPlay: TMenuItem;
procedure btnAddClick(Sender: TObject);
procedure btnStopClick(Sender: TObject);
procedure chkVerNumClick(Sender: TObject);
procedure btnPauseClick(Sender: TObject);
procedure btnResumeClick(Sender: TObject);
procedure btnStartClick(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormCreate(Sender: TObject);
procedure FFVCLBeforeHook(const AIndex: Integer; const APTS: Int64;
var AHookAction: THookAction);
procedure FFVCLCustomHook(const AIndex: Integer; ABitmap: TBitmap;
const AFrameNumber: Integer; const APTS: Int64; var AUpdate, AStopHook: Boolean);
procedure FFVCLLog(const AIndex: Integer; const ALogLevel: TLogLevel; const AMsg: string);
procedure FFVCLProgress(const AIndex, AFrameNumber, AFPS,
ACurrentDuration: Integer; const AQuality, ABitRate: Single;
const ACurrentSize: Int64; const ATotalOutputDuration: Integer);
procedure FFVCLTerminate(const AIndex: Integer; const AFinished,
AException: Boolean; const AMessage: string);
procedure btnClearClick(Sender: TObject);
procedure btnRemoveClick(Sender: TObject);
procedure btnExitClick(Sender: TObject);
procedure btnWebSiteClick(Sender: TObject);
procedure mnuOpenFolderClick(Sender: TObject);
procedure PopupMenu1Popup(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure mnuPlayClick(Sender: TObject);
private
FFolderList: TStringList;
FOutFileList: TStringList;
procedure DoException(Sender: TObject; E: Exception);
procedure DoAddFile(const AIO: TInputOptions; const AOO: TOutputOptions);
public
end;
var
frmMain: TfrmMain;
implementation
uses
XPMan,
ShellAPI,
OptionFrm;
var
GfrmOption: TfrmOption = nil;
const
CLibAVPath = 'LibAV';
SAppTitle = 'Demo of FFVCL %s';
SCaption = 'Demo of FFVCL - Delphi FFmpeg VCL Component %s';
SWebSiteC = 'http://www.CCAVC.com';
SWebSiteE = 'http://www.DelphiFFmpeg.com';
DEMO_INFO =
'* The Demo Version FFVCL only works in Delphi IDE' +
#13#10 +
'* Load VerNum DLL means "avcodec-51.dll" rather than "avcodec.dll"' +
#13#10 +
'* Thread Mode means creating new threads to do converting jobs, ' +
'it dose not using the main thread so you can Stop/Pause/Resume ' +
'converting without block.' +
#13#10 +
' * Thread Count means the quantity of converting jobs in the same time.' +
#13#10 +
' * WARNING: if you want to debug your code in IDE such as Breakpoints, ' +
'please do not check Thread Mode, or choose Thread Priority below "Normal", ' +
'because Delphi Debugger maybe fall into trouble in Thread Mode.' +
#13#10 +
'* Log Level means the log messages level' +
#13#10 +
'* Thread Priority only works in Thread Mode' +
#13#10 +
#13#10;
LICENSE_SEED = $D24E9E33;
LICENSE_KEY =
'39EA968465F26B6CDCA1E51EC8FAC6392100A838813BD0E0F5575E31AC38AEE4' +
'34E3AF85FDC4B84FBC8BC88078E83D482D8CD226F013CF85BA90F88765D91977' +
'A8C2E0E345B052AFC342FF244A8D7A95306623716DDBB1B512A1F44F32D6731C' +
'49308768679B36FC8F6AEF3207ED6CC8EA5EF8F4D2F2AA0F2DC5F13654B78322';
CDialogOptions = [ofHideReadOnly, ofFileMustExist, ofEnableSizing];
CPictureFiles = '*.BMP;*.GIF;*.JPEG;*.JPG;*.PNG;';
CAudioFiles = '*.MP3;*.AAC;*.WAV;*.WMA;*.CDA;*.FLAC;*.M4A;*.MID;*.MKA;' +
'*.MP2;*.MPA;*.MPC;*.APE;*.OFR;*.OGG;*.RA;*.WV;*.TTA;*.AC3;*.DTS;';
CVideoFiles = '*.AVI;*.AVM;*.ASF;*.WMV;*.AVS;*.FLV;*.MKV;*.MOV;*.3GP;' +
'*.MP4;*.MPG;*.MPEG;*.DAT;*.OGM;*.VOB;*.RM;*.RMVB;*.TS;*.TP;*.IFO;*.NSV;';
CDialogFilter =
'Video/Audio/Picture Files|' + CVideoFiles + CAudioFiles + CPictureFiles +
'|Video Files|' + CVideoFiles +
'|Audio Files|' + CAudioFiles +
'|Picture Files|' + CPictureFiles +
'|All Files|*.*';
SHookFrameNumber = 'FFVCL - Frame Number: %d';
SHookTimeStamp = 'FFVCL - Time Stamp: %d';
SHookTextImage = 'FFVCL';
SHookReverseVertical = 'Reverse Picture Vertically';
SHookReverseHorizontal = 'Reverse Picture Horizontally';
var
SWebSite: string = SWebSiteE;
procedure TfrmMain.FormCreate(Sender: TObject);
begin
Application.Title := Format(SAppTitle, [FFVCL.Version]);
Self.Caption := Format(SCaption, [FFVCL.Version]);
if SysUtils.SysLocale.PriLangID = LANG_CHINESE then
SWebSite := SWebSiteC
else
SWebSite := SWebSiteE;
btnWebSite.Caption := SWebSite;
mmoLog.Text := DEMO_INFO;
FFolderList := TStringList.Create;
FOutFileList := TStringList.Create;
OpenDialog1.Options := CDialogOptions;
OpenDialog1.Filter := CDialogFilter;
Application.OnException := DoException;
FFVCL.SetLicenseKey(LICENSE_KEY, LICENSE_SEED);
end;
procedure TfrmMain.FormDestroy(Sender: TObject);
begin
FreeAndNil(FFolderList);
FreeAndNil(FOutFileList);
end;
procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
with FFVCL do
begin
OnBeforeHook := nil;
OnCustomHook := nil;
OnLog := nil;
OnProgress := nil;
OnTerminate := nil;
BreakConverting;
end;
end;
procedure TfrmMain.DoException(Sender: TObject; E: Exception);
var
LMsg: string;
begin
LMsg := E.Message;
if (LMsg <> '') and (AnsiLastChar(LMsg) > '.') then
LMsg := LMsg + '.';
if E is FFmpegException then
Application.MessageBox(PChar(LMsg), PChar(Application.Title), MB_OK + MB_ICONWARNING)
else
Application.MessageBox(PChar(LMsg), PChar(Application.Title), MB_OK + MB_ICONERROR);
end;
procedure TfrmMain.chkVerNumClick(Sender: TObject);
begin
FFVCL.UnloadAVLib;
end;
procedure TfrmMain.btnAddClick(Sender: TObject);
begin
if not FFVCL.LoadAVLib(ExtractFilePath(Application.ExeName) + CLibAVPath, chkVerNum.Checked) then
begin
mmoLog.Lines.Add(FFVCL.LastErrMsg);
Exit;
end;
FFVCL.LogLevel := TLogLevel(grpLogLevel.ItemIndex);
if not OpenDialog1.Execute then
Exit;
if FFVCL.AVProbe.LoadFile(OpenDialog1.FileName) then
begin
if not Assigned(GfrmOption) then
GfrmOption := TfrmOption.Create(Self);
GfrmOption.AVProbe := FFVCL.AVProbe;
if GfrmOption.ShowModal = mrOk then
DoAddFile(GfrmOption.InputOptions, GfrmOption.OutputOptions);
FFVCL.AVProbe.CloseFile;
end
else
begin
mmoLog.Lines.Add('');
mmoLog.Lines.Add('***File load error: ' + FFVCL.AVProbe.LastErrMsg);
mmoLog.Lines.Add('');
end;
end;
procedure TfrmMain.DoAddFile(const AIO: TInputOptions; const AOO: TOutputOptions);
var
LIndex: Integer;
begin
LIndex := FFVCL.AddInputFile(AIO.FileName, @AIO);
if LIndex < 0 then
begin
mmoLog.Lines.Add('');
mmoLog.Lines.Add('***File open error: ' + FFVCL.LastErrMsg);
mmoLog.Lines.Add('');
end
else
begin
if FFVCL.SetOutputFile(LIndex, AOO.FileName, @AOO) then
begin
with lvFiles.Items.Add do
begin
Caption := ExtractFileName(AIO.FileName);
SubItems.Add(IntToStr(FFVCL.AVProbe.FileStreamInfo.Duration div 1000000));
SubItems.Add(IntToStr(FFVCL.AVProbe.FileSize));
SubItems.Add(ExtractFileName(AOO.FileName));
SubItems.Add('');
SubItems.Add('');
SubItems.Add('');
SubItems.Add('');
end;
FFolderList.Add(ExtractFilePath(AOO.FileName));
FOutFileList.AddObject(AOO.FileName, nil);
mmoLog.Lines.Add('');
mmoLog.Lines.Add('***File has been added to convert list.');
mmoLog.Lines.Add('');
btnRemove.Enabled := True;
btnClear.Enabled := True;
btnStart.Enabled := True;
end
else
begin
FFVCL.RemoveInputFile(LIndex);
mmoLog.Lines.Add('');
mmoLog.Lines.Add('***Cannot do convert, error: ' + FFVCL.LastErrMsg);
mmoLog.Lines.Add('');
end;
end;
end;
procedure TfrmMain.btnRemoveClick(Sender: TObject);
begin
if lvFiles.ItemIndex >= 0 then
begin
FFVCL.RemoveInputFile(lvFiles.ItemIndex);
FFolderList.Delete(lvFiles.ItemIndex);
FOutFileList.Delete(lvFiles.ItemIndex);
lvFiles.Items.Delete(lvFiles.ItemIndex);
btnRemove.Enabled := lvFiles.Items.Count > 0;
btnClear.Enabled := lvFiles.Items.Count > 0;
btnStart.Enabled := lvFiles.Items.Count > 0;
end;
end;
procedure TfrmMain.btnClearClick(Sender: TObject);
begin
FFVCL.ClearInputFiles;
FFolderList.Clear;
FOutFileList.Clear;
lvFiles.Items.Clear;
btnAdd.Enabled := True;
btnRemove.Enabled := False;
btnClear.Enabled := False;
btnStart.Enabled := False;
end;
procedure TfrmMain.btnStartClick(Sender: TObject);
begin
FFVCL.LogLevel := TLogLevel(grpLogLevel.ItemIndex);
FFVCL.ThreadPriority := TThreadPriority(grpPriority.ItemIndex);
btnAdd.Enabled := False;
btnRemove.Enabled := False;
btnClear.Enabled := False;
btnStart.Enabled := False;
btnStop.Enabled := chkThreadMode.Checked;
btnPause.Enabled := chkThreadMode.Checked;
btnResume.Enabled := False;
if chkThreadMode.Checked then
FFVCL.StartConvert(StrToIntDef(edtThreadCount.Text, 1))
else
FFVCL.StartConvert(0);
end;
procedure TfrmMain.btnStopClick(Sender: TObject);
begin
btnStop.Enabled := False;
FFVCL.BreakConverting;
end;
procedure TfrmMain.btnPauseClick(Sender: TObject);
begin
btnPause.Enabled := False;
btnResume.Enabled := True;
FFVCL.PauseConverting;
end;
procedure TfrmMain.btnResumeClick(Sender: TObject);
begin
btnPause.Enabled := True;
btnResume.Enabled := False;
FFVCL.ResumeConverting;
end;
procedure TfrmMain.btnWebSiteClick(Sender: TObject);
begin
ShellExecute(Application.Handle, 'Open',
PChar(LowerCase(SWebSite)), '',
PChar(ExtractFilePath(Application.ExeName)), 1);
end;
procedure TfrmMain.btnExitClick(Sender: TObject);
begin
Close;
end;
procedure TfrmMain.mnuOpenFolderClick(Sender: TObject);
var
LPath: string;
begin
if (lvFiles.ItemIndex >= 0) and (lvFiles.ItemIndex < FFolderList.Count) then
LPath := FFolderList.Strings[lvFiles.ItemIndex]
else if FFolderList.Count > 0 then
LPath := FFolderList.Strings[FFolderList.Count - 1]
else
LPath := '';
if (LPath <> '') and DirectoryExists(LPath) then
ShellExecute(Application.Handle, 'Open',
PChar(LPath), nil,
PChar(LPath), SW_SHOWDEFAULT);
end;
procedure TfrmMain.mnuPlayClick(Sender: TObject);
var
I: Integer;
begin
if (lvFiles.ItemIndex >= 0) and (lvFiles.ItemIndex < FFolderList.Count) then
I := lvFiles.ItemIndex
else
I := FOutFileList.Count - 1;
if (I >= 0) and Assigned(FOutFileList.Objects[I]) and FileExists(FOutFileList.Strings[I]) then
ShellExecute(Application.Handle, 'Open',
PChar(FOutFileList.Strings[I]), '',
PChar(ExtractFilePath(FOutFileList.Strings[I])), SW_SHOWNORMAL);
end;
procedure TfrmMain.PopupMenu1Popup(Sender: TObject);
var
I: Integer;
begin
mnuAdd.Enabled := btnAdd.Enabled;
mnuRemove.Enabled := btnRemove.Enabled;
mnuClear.Enabled := btnClear.Enabled;
mnuOpenFolder.Enabled := lvFiles.Items.Count > 0;
if (lvFiles.ItemIndex >= 0) and (lvFiles.ItemIndex < FFolderList.Count) then
I := lvFiles.ItemIndex
else
I := FOutFileList.Count - 1;
mnuPlay.Enabled := (I >= 0) and Assigned(FOutFileList.Objects[I]);
end;
procedure TfrmMain.FFVCLBeforeHook(const AIndex: Integer; const APTS: Int64;
var AHookAction: THookAction);
begin
if APTS < 5 * 1000 * 1000 then
AHookAction := haContinue
else if APTS < 10 * 1000 * 1000 then
AHookAction := haIgnore
else if APTS < 15 * 1000 * 1000 then
AHookAction := haContinue
else
AHookAction := haStop;
end;
procedure TfrmMain.FFVCLCustomHook(const AIndex: Integer; ABitmap: TBitmap;
const AFrameNumber: Integer; const APTS: Int64; var AUpdate, AStopHook: Boolean);
const
CBytes = 3;
var
H, W: Integer;
I, J, K: Integer;
P1, P2: PChar;
B: Char;
begin
if AFrameNumber = 1 then
begin
with ABitmap.Canvas.Font do
begin
Color := clWhite;
Name := 'Tahoma';
Size := 12;
Style := [fsBold, fsUnderline];
end;
end;
if AFrameNumber < 100 then
ABitmap.Canvas.TextOut(10, 10, Format(SHookFrameNumber, [AFrameNumber]))
else if AFrameNumber < 150 then
AUpdate := False
else if AFrameNumber < 250 then
ABitmap.Canvas.TextOut(10, 10, Format(SHookTimeStamp, [APTS]))
else if AFrameNumber < 350 then
begin
if AFrameNumber = 250 then
with ABitmap.Canvas.Font do
begin
Color := clRed;
Size := 16;
end;
ABitmap.Canvas.TextOut(10, 10, SHookTextImage);
ABitmap.Canvas.Draw(ABitmap.Width - Application.Icon.Width - 10,
ABitmap.Height - Application.Icon.Height - 10,
Application.Icon);
end
else if AFrameNumber < 450 then
begin
if AFrameNumber = 350 then
with ABitmap.Canvas.Font do
begin
Color := clWhite;
Style := [fsBold];
end;
ABitmap.Canvas.TextOut(10, 10, SHookReverseVertical);
H := ABitmap.Height;
W := ABitmap.Width;
for I := 0 to H div 2 - 1 do
begin
P1 := PChar(ABitmap.ScanLine[I]);
P2 := PChar(ABitmap.ScanLine[H - 1 - I]);
for J := 0 to CBytes * W - 1 do
begin
B := P1^;
P1^ := P2^;
P2^ := B;
Inc(P1);
Inc(P2);
end;
end;
end
else if AFrameNumber < 550 then
begin
if AFrameNumber = 350 then
with ABitmap.Canvas.Font do
begin
Style := [];
end;
ABitmap.Canvas.TextOut(10, 10, SHookReverseHorizontal);
H := ABitmap.Height;
W := ABitmap.Width;
for I := 0 to H - 1 do
begin
P1 := PChar(ABitmap.ScanLine[I]);
P2 := P1 + CBytes * (W - 1);
for J := 0 to W div 2 - 1 do
begin
for K := 0 to CBytes - 1 do
begin
B := (P1 + K)^;
(P1 + K)^ := (P2 + K)^;
(P2 + K)^ := B;
end;
Inc(P1, CBytes);
Dec(P2, CBytes);
end;
end;
end
else
AStopHook := True;
end;
procedure TfrmMain.FFVCLLog(const AIndex: Integer; const ALogLevel: TLogLevel; const AMsg: string);
begin
mmoLog.Lines.Add('#' + IntToStr(AIndex) + '.' + IntToStr(Ord(ALogLevel)) + ': ' + AMsg);
end;
procedure TfrmMain.FFVCLProgress(const AIndex, AFrameNumber, AFPS,
ACurrentDuration: Integer; const AQuality, ABitRate: Single;
const ACurrentSize: Int64; const ATotalOutputDuration: Integer);
begin
with lvFiles.Items.Item[AIndex].SubItems do
begin
Strings[3] := IntToStr(ACurrentDuration * 100 div ATotalOutputDuration) + '%';
if AFPS > 0 then
Strings[4] := IntToStr(AFPS);
Strings[5] := IntToStr(ACurrentDuration div 1000);
Strings[6] := IntToStr(ACurrentSize);
end;
if not chkThreadMode.Checked then
begin
lvFiles.Repaint;
end;
end;
procedure TfrmMain.FFVCLTerminate(const AIndex: Integer; const AFinished,
AException: Boolean; const AMessage: string);
begin
if AIndex < 0 then
begin
btnAdd.Enabled := False;
btnRemove.Enabled := False;
btnClear.Enabled := True;
btnStart.Enabled := False;
btnStop.Enabled := False;
btnPause.Enabled := False;
btnResume.Enabled := False;
FFVCL.ClearInputFiles;
end
else if AFinished then
begin
lvFiles.Items.Item[AIndex].SubItems.Strings[3] := '100%';
if not chkThreadMode.Checked then
begin
lvFiles.Repaint;
end;
end;
if (AIndex >= 0) and not AException then
FOutFileList.Objects[AIndex] := TObject(1);
if AException then
Application.MessageBox(PChar(AMessage), PChar(Application.Title), MB_OK + MB_ICONWARNING);
end;
end.