Once again I overcame the completion time of the video.
Here I provide the code for the .pas file as well as the .dfm file.
Of course, DSPack must be installed. I downloaded from the above link. Thanks so much for this.
Everything works, only you need to change the file type and file path in the ListFileDir procedure. Rest works great.
Just save the .PAS file with the name "NewPlayerSource", otherwise you will get an error when compiling the project.
.PAS File Code:
unit NewPlayerSource; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, MPlayer, StdCtrls, Buttons, FileCtrl, ComCtrls, DSPack, DirectShow9; type TForm1 = class(TForm) Timer1: TTimer; MediaPlayer1: TMediaPlayer; Panel1: TPanel; FileListBox1: TFileListBox; ListBox1: TListBox; Button1: TButton; Animate1: TAnimate; VideoWindow1: TVideoWindow; FilterGraph1: TFilterGraph; Label1: TLabel; Label2: TLabel; ProgressBar1: TProgressBar; Label3: TLabel; btnPlaySelectedFile: TButton; btnPause: TButton; btnResume: TButton; procedure FormShow(Sender: TObject); procedure Timer1Timer(Sender: TObject); procedure Button1Click(Sender: TObject); procedure ListFileDir(Path: string; var FileList: TListBox); procedure FilterGraph1GraphComplete(sender: TObject; Result: HRESULT; Renderer: IBaseFilter); procedure btnPlaySelectedFileClick(Sender: TObject); procedure btnPauseClick(Sender: TObject); procedure btnResumeClick(Sender: TObject); private { Private declarations } public { Public declarations } bVideoCompleted, bPlaySelectedVideo, bPuseButtonPressed : Boolean; procedure PlayVideo; procedure SetupProgressBar; function SecToTime(Sec: Integer): string; end; var Form1: TForm1; iCount, iSeconds: Integer; implementation {$R *.dfm} procedure TForm1.ListFileDir(Path: string; var FileList: TListBox); var SR: TSearchRec; begin if FindFirst(Path + '*.avi', faAnyFile, SR) = 0 then begin repeat if (SR.Attr <> faDirectory) then begin FileList.Items.Add(Path + SR.Name); end; until FindNext(SR) <> 0; FindClose(SR); end; end; procedure TForm1.FormShow(Sender: TObject); begin bVideoCompleted := False; bPlaySelectedVideo := False; bPuseButtonPressed := False; ListBox1.Items.Clear; Label1.Caption := EmptyStr; Label2.Caption := EmptyStr; ListFileDir('I:\Project Part 1\Clips\More Clips\', ListBox1); btnResume.Enabled := False; if ListBox1.Items.Count = 0 then begin btnPlaySelectedFile.Enabled := False; btnPause.Enabled := False; ShowMessage('No files to play'); Exit; end; iCount := 0; ListBox1.ItemIndex := iCount; PlayVideo; {with MediaPlayer1 do begin Close; //DeviceType := dtAVIVideo; DeviceType := dtAutoSelect; FileName := ListBox1.Items.Strings[iCount]; ListBox1.ItemIndex := iCount; iCount := iCount + 1; Open; //DisplayRect := Rect(0, 0, Panel1.Width, Panel1.Height); Play; end; } end; procedure TForm1.Timer1Timer(Sender: TObject); begin if ListBox1.Items.Count = 0 then Exit; if bPuseButtonPressed = True then Exit; if bVideoCompleted = True then begin bVideoCompleted := False; if iCount >= ListBox1.Items.Count then iCount := 0; PlayVideo; end; Label2.Caption := FormatDateTime('hh:nn:ss', iSeconds / SecsPerDay); ProgressBar1.Position := ProgressBar1.Position + 1; iSeconds := iSeconds + 1; {if MediaPlayer1.Position = MediaPlayer1.Length then begin if iCount = ListBox1.Items.Count then iCount := 0; with MediaPlayer1 do begin Close; FileName := ListBox1.Items.Strings[iCount]; ListBox1.ItemIndex := iCount; iCount := iCount + 1; Open; Play; end; end; } end; procedure TForm1.Button1Click(Sender: TObject); begin Close; end; procedure TForm1.FilterGraph1GraphComplete(sender: TObject; Result: HRESULT; Renderer: IBaseFilter); begin bVideoCompleted := True; end; procedure TForm1.PlayVideo; begin iSeconds := 0; SetupProgressBar; filtergraph1.Stop; filtergraph1.ClearGraph; videowindow1.FilterGraph:=filtergraph1; filtergraph1.Active:=true; if bPlaySelectedVideo = True then filtergraph1.RenderFile(ListBox1.Items.Strings[ListBox1.ItemIndex]) else filtergraph1.RenderFile(ListBox1.Items.Strings[iCount]); filtergraph1.Play; bPlaySelectedVideo := False; Label1.Caption := FormatDateTime('hh:nn:ss', (filtergraph1.Duration/1000) / SecsPerDay); Label2.Caption := FormatDateTime('hh:nn:ss', iSeconds / SecsPerDay); ListBox1.ItemIndex := iCount; iCount := iCount + 1; SetupProgressBar; end; procedure TForm1.SetupProgressBar; begin ProgressBar1.Position := 0; ProgressBar1.Step := 1; ProgressBar1.Min := 0; ProgressBar1.Max := StrToInt(FloatToStr(filtergraph1.Duration div 1000)) + 1; end; function TForm1.SecToTime(Sec: Integer): string; var H, M, S: string; ZH, ZM, ZS: Integer; begin Sec := Sec div 1000; ZH := Sec div 3600; ZM := Sec div 60 - ZH * 60; ZS := Sec - (ZH * 3600 + ZM * 60) ; H := IntToStr(ZH) ; M := IntToStr(ZM) ; S := IntToStr(ZS) ; Result := H + ':' + M + ':' + S; end; procedure TForm1.btnPlaySelectedFileClick(Sender: TObject); begin bPlaySelectedVideo := True; bPuseButtonPressed := False; btnPause.Enabled := True; btnResume.Enabled := False; iCount := ListBox1.ItemIndex; PlayVideo; end; procedure TForm1.btnPauseClick(Sender: TObject); begin filtergraph1.Pause; bPuseButtonPressed := True; btnPause.Enabled := False; btnResume.Enabled := True; end; procedure TForm1.btnResumeClick(Sender: TObject); begin filtergraph1.Play; bPuseButtonPressed := False; btnResume.Enabled := False; btnPause.Enabled := True; end; end.
. DFM File Code:
object Form1: TForm1 Left = 305 Top = 149 BorderStyle = bsSingle Caption = 'overflow' ClientHeight = 589 ClientWidth = 941 Color = clBtnFace Font.Charset = ANSI_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] OldCreateOrder = False Position = poDesktopCenter OnShow = FormShow PixelsPerInch = 96 TextHeight = 13 object Label1: TLabel Left = 897 Top = 568 Width = 32 Height = 13 Alignment = taRightJustify Caption = 'Label1' Font.Charset = ANSI_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] ParentFont = False end object Label2: TLabel Left = 256 Top = 568 Width = 32 Height = 13 Caption = 'Label2' Font.Charset = ANSI_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] ParentFont = False end object Label3: TLabel Left = 10 Top = 16 Width = 73 Height = 13 Caption = 'List of files path' Font.Charset = ANSI_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] ParentFont = False end object MediaPlayer1: TMediaPlayer Left = 300 Top = 132 Width = 113 Height = 23 EnabledButtons = [btPlay, btPause, btStop, btNext] VisibleButtons = [btPlay, btPause, btStop, btNext] AutoOpen = True DeviceType = dtAVIVideo Display = Panel1 TabOrder = 0 end object Panel1: TPanel Left = 504 Top = 18 Width = 139 Height = 109 Caption = 'Panel1' TabOrder = 1 end object FileListBox1: TFileListBox Left = 504 Top = 198 Width = 139 Height = 73 ItemHeight = 13 TabOrder = 2 end object ListBox1: TListBox Left = 10 Top = 32 Width = 231 Height = 163 ItemHeight = 13 TabOrder = 3 end object Button1: TButton Left = 312 Top = 276 Width = 56 Height = 19 Caption = 'CLOSE' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -13 Font.Name = 'Tahoma' Font.Style = [fsBold] ParentFont = False TabOrder = 4 OnClick = Button1Click end object Animate1: TAnimate Left = 664 Top = 48 Width = 209 Height = 185 Active = False end object VideoWindow1: TVideoWindow Left = 256 Top = 16 Width = 673 Height = 521 FilterGraph = FilterGraph1 VMROptions.Mode = vmrWindowed Color = clBlack end object ProgressBar1: TProgressBar Left = 256 Top = 544 Width = 673 Height = 17 Min = 0 Max = 100 Smooth = True Step = 1 TabOrder = 7 end object btnPlaySelectedFile: TButton Left = 8 Top = 208 Width = 234 Height = 25 Caption = '&Play selected file' TabOrder = 8 OnClick = btnPlaySelectedFileClick end object btnPause: TButton Left = 8 Top = 240 Width = 117 Height = 25 Caption = 'Pa&use' TabOrder = 9 OnClick = btnPauseClick end object btnResume: TButton Left = 128 Top = 240 Width = 117 Height = 25 Caption = '&Resume' TabOrder = 10 OnClick = btnResumeClick end object Timer1: TTimer OnTimer = Timer1Timer Left = 56 Top = 352 end object FilterGraph1: TFilterGraph GraphEdit = False LinearVolume = True OnGraphComplete = FilterGraph1GraphComplete Left = 128 Top = 352 end end
Thanks again for thinking so much about TLama.
Let me know if something is missing or something can be improved.