проигрывание Mpeg на панели Delphi

{
MCI-проигрыватель видеофайлов

Данный проигрыватель использует интерфейс командный строк
}
unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons, MMSystem, ComCtrls, ExtCtrls, Spin;

type
  TFormMain = class(TForm)
    BitBtnPlay: TBitBtn;
    BitBtnStop: TBitBtn;
    Timer: TTimer;
    Label1: TLabel;
    StatusBar: TStatusBar;
    BitBtnLoadFile: TBitBtn;
    OpenDialog: TOpenDialog;
    ScrollBar: TScrollBar;
    StaticTextTime: TStaticText;
    StaticTextPos: TStaticText;
    Label2: TLabel;
    Label3: TLabel;
    procedure BitBtnPlayClick(Sender: TObject);
    procedure BitBtnStopClick(Sender: TObject);
    procedure TimerTimer(Sender: TObject);
    procedure BitBtnLoadFileClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure ScrollBarScroll(Sender: TObject; ScrollCode: TScrollCode;
                              var ScrollPos: Integer);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    ErrMsg     : array[0..4095] of Char;
    ErrMsgStr  : String;
    AVILength : Cardinal;                           // Длина видео
  public
    { Public declarations }
    ErrorID      : DWORD;                           // ID ошибки
    FlgOpen      : Boolean;
    CommandStr   : String;                          // Командная строка
    ReturnStr    : array[0..50] of Char;            // Возвращаемая строка
    Ret          : String;                          // Возвращаемая строка

    Procedure OpenFile(FileName : String);          // Инициализация MCI
    Procedure CloseMCIDevice;
    Procedure ShowMCIError;
    // Проиграть с заданной позиции
    procedure Play(Position : Cardinal);
    // стоп
    Procedure Stop;
    // Проигрыватель играет - да / нет
    Function  IsPlay : Boolean;
    // Разрешение / запрет кнопок
    Procedure OnOff(Value : Boolean);
  end;
var
  FormMain: TFormMain;

implementation

uses Wind,UnitStr;

{$R *.dfm}

function MillisecondsToTimeStr(TimeSec: Cardinal): String;
var
  H,M,S  : Integer;
  HStr,MStr,SStr : String[2];
begin
  TimeSec := TimeSec div 1000; // в секунды
  // Кол-во часов
  H  := (TimeSec div 60) div 60;
  // минуты - (кол-во часов *  60)
  M  := (TimeSec div 60) - (60*H);
  // Cек - общее кол-во секунд + (кол-во мин. *  60))
  S  := TimeSec  - ((TimeSec div 60) * 60);
  HStr := IntToStr(H);
  IF Length(HStr)=1 then HStr := '0' + HStr;
  MStr := IntToStr(M);
  IF Length(MStr)=1 then MStr := '0' + MStr;
  SStr := IntToStr(S);
  IF Length(SStr)=1 then SStr := '0' + SStr;

  Result := Format('%S:%S:%S',[HStr,MStr,SStr]);
end;

procedure TFormMain.FormCreate(Sender: TObject);
begin
 OnOff(False);
end;

procedure TFormMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  IF FlgOpen then
  begin
     CloseMCIDevice;
     FlgOpen      := False;
  end;
end;

// Закрываем устройство

procedure TFormMain.CloseMCIDevice;
begin
  Stop; // Остановить на всякий сучай

  // Закрыть
  CommandStr   := Format('Close video',[]);
  ErrorID := mciSendString(PChar(CommandStr),nil, 0, 0);
  IF ErrorID <> 0 then
  begin
     ShowMCIError; Exit;
  end;

  OnOff(False);
end;

// Загрузить

procedure TFormMain.BitBtnLoadFileClick(Sender: TObject);
begin
  IF FlgOpen Then
  begin
     CloseMCIDevice;
  end;
  IF OpenDialog.Execute then
  begin
    OpenFile(OpenDialog.FileName);
  end;
end;

// Открыть MCI устройство и загрузить файл

procedure TFormMain.OpenFile(FileName: String);
var
  Coord : TSepRec;
begin
  // Загружаем файл
  CommandStr   := Format('Open "%S" type avivideo alias video Parent %D style child',[FileName, Window.Handle]);
  ErrorID := mciSendString(PChar(CommandStr),nil, 0, 0);
  IF ErrorID <> 0 then
  begin
     ShowMCIError; Exit;
  end;

  // Устанавливаем формат времени

  CommandStr   := Format('Set video time format milliseconds',[]);
  ErrorID := mciSendString(PChar(CommandStr),nil, 0, 0);
  IF ErrorID <> 0 then
  begin
     ShowMCIError; Exit;
  end;

  // Получаем длину проигрываемого файла в

  CommandStr   := Format('Status video length',[]);
  ErrorID := mciSendString(PChar(CommandStr),ReturnStr, Length(ReturnStr), 0);
  IF ErrorID <> 0 then
  begin
     ShowMCIError; Exit;
  end;
  SetString(Ret, ReturnStr, StrLen(ReturnStr));

  // Получить длину
  AVILength := StrToInt(Ret);
  ScrollBar.Min := 0;
  ScrollBar.Max := AVILength;
  ScrollBar.Position := ScrollBar.Min;

  StaticTextTime.Caption := MillisecondsToTimeStr(AVILength);
  StatusBar.SimpleText := FileName;
  FlgOpen      := True;

  // Определяем высоту и ширину выводимого изображения
  CommandStr   := Format('Where video destination',[]);
  ErrorID := mciSendString(PChar(CommandStr),ReturnStr, Length(ReturnStr), 0);
  IF ErrorID <> 0 then
  begin
     ShowMCIError; Exit;
  end;
  SetString(Ret, ReturnStr, StrLen(ReturnStr));

  // Разбиваем строку на элементы
  Coord := GetSeparatorRec(Ret,' ');

  // Нестраиваем окно проигрыватель
  Window.Width  := StrToInt(Coord.Rec[3]) + 7;  // поправки
  Window.Height := StrToInt(Coord.Rec[4]) + 24;
  Window.Left   := (Left + (Width div 2)) - (Window.Width Div 2);
  Window.Top    := top - Window.Height;

  Window.Show;
  // Обновляем окно видео
  CommandStr   := Format('put video window at %S',[Ret]);
  ErrorID := mciSendString(PChar(CommandStr),nil, 0, 0);
  IF ErrorID <> 0 then
  begin
     ShowMCIError; Exit;
  end;

  OnOff(True);
end;

// Проиграть

procedure TFormMain.BitBtnPlayClick(Sender: TObject);
begin
 Play(ScrollBar.Position);
end;

procedure TFormMain.Play(Position: Cardinal);
begin
  // Загружаем файл
 CommandStr   := Format('Play video from %D',[Position]);
 ErrorID := mciSendString(PChar(CommandStr),nil, 0, 0);
 IF ErrorID <> 0 then
 begin
    ShowMCIError; Exit;
 end;
 Timer.Enabled:= True;
end;

// Стоп

procedure TFormMain.Stop;
begin
 CommandStr   := Format('Stop video',[]);
 ErrorID := mciSendString(PChar(CommandStr),nil, 0, 0);
 Timer.Enabled := False;
end;

procedure TFormMain.BitBtnStopClick(Sender: TObject);
begin
  Stop;
end;

// ОПРЕДЕЛЕНИЕ ТЕКУЩЕЙ ПОЗИЦИИ В МЕДИА-ДАННЫХ

procedure TFormMain.TimerTimer(Sender: TObject);
begin
  // Получаем текущею позицию в медиа-данных
  CommandStr   := Format('Status video Position',[]);
  ErrorID := mciSendString(PChar(CommandStr),ReturnStr, Length(ReturnStr), 0);
  IF ErrorID <> 0 then
  begin
     ShowMCIError; Exit;
  end;
  SetString(Ret, ReturnStr, StrLen(ReturnStr));
  ScrollBar.Position := StrToInt(Ret);
  StaticTextPos.Caption := MillisecondsToTimeStr(ScrollBar.Position);
end;

// ПОКАЗ ОШИБОК

procedure TFormMain.ShowMCIError;
begin
  mciGetErrorString(ErrorID, ErrMsg, SizeOf(ErrMsg));
  SetString(ErrMsgStr, ErrMsg, StrLen(ErrMsg));
  ShowMessage('Ошибка MCI!' + #10#13 +  ErrMsgStr);
end;

/ Проигрыватель играет (ДА/НЕТ)

function TFormMain.IsPlay: Boolean;
begin
  Result := False;

  CommandStr   := Format('Status video Mode',[]);
  ErrorID := mciSendString(PChar(CommandStr),ReturnStr, Length(ReturnStr), 0);
  IF ErrorID <> 0 then
  begin
     ShowMCIError; Exit;
  end;
  SetString(Ret, ReturnStr, StrLen(ReturnStr));
  Result := Trim(Ret) = 'playing';
end;

// СМЕНА ПОЗИЦИИ

procedure TFormMain.ScrollBarScroll(Sender: TObject;
          ScrollCode: TScrollCode; var ScrollPos: Integer);
begin
  // Конец перетаскивания бегунка
  IF ScrollCode = scEndScroll then
  Begin
     // Если проигрыватель играет то продолжить игру с позиции бегунка
     // иначе
     //   Просто позиционирование на выбранное время
     IF IsPlay then
     begin
        Play(ScrollBar.Position)
     end
     else
     begin
        CommandStr   := 'seek video to ' + IntToStr(ScrollBar.Position);
        ErrorID := mciSendString(PChar(CommandStr),nil, 0, 0);
        IF ErrorID <> 0 then
        begin
           ShowMCIError; Exit;
        end;

    end;
  end
  else
    Timer.Enabled := False;
end;

procedure TFormMain.OnOff(Value: Boolean);
begin
 BitBtnPlay.Enabled := Value;
 BitBtnStop.Enabled := Value;
 ScrollBar.Enabled  := Value;
end;

end.