Subversion Repositories spacemission

Rev

Blame | Last modification | View Log | RSS feed

  1. {
  2.  SXMedia  Components - Beta 1
  3.  --------------------------------
  4.  Copyright 1999 Dean Ellis
  5.  http://www.sillex.freeserve.co.uk
  6.  
  7.  This unit is part of the SXMedia Component Set. This code is
  8.  supplied as is with no guarantees and must be used at your own
  9.  risk.
  10.  
  11.  No modifications to this code must be made without the express
  12.  permission of the author. Please report any problems to
  13.  support@sillex.freeserve.co.uk
  14.  
  15.  You may use these components to create any freeware/shareware
  16.  applications that you wish. If the components are to be used in
  17.  a commercail product then credit for developement of these components
  18.  should be given.
  19.  
  20.  Credits :
  21.  
  22.  Developer : Dean Ellis
  23.  Testers   : Dominique Louis
  24.              Ivan Blecic
  25. }
  26. unit SXMovie;
  27.  
  28. {$INCLUDE DelphiXcfg.inc}
  29.  
  30. interface
  31.  
  32. uses
  33.   Windows, Classes, SysUtils, ActiveX, Math, Dialogs,
  34.   DXSounds, DXDraws,
  35.   {$IFDEF StandardDX}
  36.   DirectDraw, DirectSound, DirectShow9,
  37.     {$IFDEF DX7}
  38.       {$IFDEF D3DRM}
  39.   Direct3DRM,
  40.       {$ENDIF}
  41.   Direct3D;
  42.     {$ENDIF}
  43.     {$IFDEF DX9}
  44.   Direct3D9, Direct3D, D3DX9, {Direct3D8,} DX7toDX8;
  45.     {$ENDIF}
  46.   {$ELSE}
  47.   DShow, DirectX;
  48.   {$ENDIF}
  49.  
  50. type
  51.   TMovieOptions = (VideoAndSound, VideoOnly);
  52.   TDisplay = (FullScreen, WideScreen, OriginalSize);
  53.  
  54.   TScreenRect = class(TPersistent)
  55.   private
  56.     FLeft: integer;
  57.     FRight: integer;
  58.     FTop: integer;
  59.     FBottom: integer;
  60.     procedure SetLeft(Value: integer);
  61.     procedure SetRight(Value: integer);
  62.     procedure SetTop(Value: integer);
  63.     procedure SetBottom(Value: integer);
  64.   protected
  65.   public
  66.     procedure Assign(Value: TScreenRect);
  67.   published
  68.     property Left: integer read FLeft write SetLeft;
  69.     property Right: integer read FRight write SetRight;
  70.     property Top: integer read FTop write SetTop;
  71.     property Bottom: integer read FBottom write SetBottom;
  72.   end;
  73.  
  74.  
  75.   TSXMovie = class;
  76.  
  77.   TMovieThread = class(TThread)
  78.   private
  79.     { Private declarations }
  80.     FSXMovie: TSXMovie;
  81.   protected
  82.     procedure Execute; override;
  83.   public
  84.     property SXMovie: TSXMovie read FSXMovie write FSXMovie;
  85.   end;
  86.  
  87.   TSXMovie = class(TComponent)
  88.   private
  89.     FMovieThread: TMovieThread;
  90.     FDXDraw: TDXDraw;
  91.     FDXSound: TDXSound;
  92.     FMMStream: IMultiMediaStream;
  93.     FPrimaryVidStream: IMediaStream;
  94.     FDDStream: IDirectDrawMediaStream;
  95.     FSample: IDirectDrawStreamSample;
  96.     FSurface: IDirectDrawSurface;
  97.     FDXSurface: TDirectDrawSurface;
  98.     FRect: TRect;
  99.     FDestRect: TRect;
  100.     FScreenRect: TScreenRect;
  101.     FFilename: TFilename;
  102.     FPlaying: Boolean;
  103.     FDoFlip: Boolean;
  104.     {Event}
  105.     FOnMovieEnd: TNotifyEvent;
  106.     FOnBeforeRender: TNotifyEvent;
  107.     FOnAfterRender: TNotifyEvent;
  108.     procedure SetFilename(Value: TFilename);
  109.     procedure SetScreenRect(Value: TScreenRect);
  110.     procedure DoMovieEnd;
  111.     procedure DoBeforeRender;
  112.     procedure DoAfterRender;
  113.   protected
  114.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  115.     procedure SetMovieStateRun;
  116.     procedure SetMovieStateStop;
  117.     procedure CreateMediaStream; virtual;
  118.     procedure SetupMediaSample; virtual;
  119.   public
  120.     constructor Create(AOwner: TComponent); override;
  121.     destructor Destroy; override;
  122.     procedure UpDate; virtual;
  123. //    function SetDisplay(Value:TDisplay):Boolean;
  124.     procedure DisplayRect(Top, Left, Right, Bottom: integer);
  125.     procedure Play;
  126.     procedure Stop;
  127.     {}
  128.   published
  129.     property DXDraw: TDXDraw read FDXDraw write FDXDraw;
  130.     property DXSound: TDXSound read FDXSound write FDXSound;
  131.     property Filename: TFilename read FFilename write SetFilename;
  132.     property Playing: Boolean read FPlaying;
  133.     property DoFlip: Boolean read FDoFlip write FDoFlip;
  134.     property DestinationRectangle: TScreenRect read FScreenRect write SetScreenRect;
  135.     property OnMovieEnd: TNotifyEvent read FOnMovieEnd write FOnMovieEnd;
  136.     property OnBeforeRender: TNotifyEvent read FOnBeforeRender write FOnBeforeRender;
  137.     property OnAfterRender: TNotifyEvent read FOnAfterRender write FOnAfterRender;
  138.   end;
  139.  
  140. implementation
  141.  
  142. uses Graphics;
  143.  
  144. procedure TScreenRect.SetLeft(Value: integer);
  145. begin
  146.   FLeft := Value;
  147. end;
  148.  
  149. procedure TScreenRect.SetRight(Value: integer);
  150. begin
  151.   FRight := Value;
  152. end;
  153.  
  154. procedure TScreenRect.SetTop(Value: integer);
  155. begin
  156.   FTop := Value;
  157. end;
  158.  
  159. procedure TScreenRect.SetBottom(Value: integer);
  160. begin
  161.   FBottom := Value;
  162. end;
  163.  
  164. procedure TScreenRect.Assign(Value: TScreenRect);
  165. begin
  166.   Left := Value.Left;
  167.   Right := Value.Right;
  168.   Top := Value.Top;
  169.   Bottom := Value.Bottom;
  170. end;
  171.  
  172. { Important: Methods and properties of objects in VCL can only be used in a
  173.   method called using Synchronize, for example,
  174.  
  175.       Synchronize(UpdateCaption);
  176.  
  177.   and UpdateCaption could look like,
  178.  
  179.     procedure TMovieThread.UpdateCaption;
  180.     begin
  181.       Form1.Caption := 'Updated in a thread';
  182.     end; }
  183.  
  184. { TMovieThread }
  185.  
  186. procedure TMovieThread.Execute;
  187. begin
  188.   { Place thread code here }
  189.   if Assigned(SXMovie) then
  190.     SXMovie.SetMovieStateRun;
  191.   while (not Terminated) and Assigned(SXMovie) do
  192.   begin
  193.     Synchronize(SXMovie.UpDate)
  194.   end;
  195.   if Assigned(SXMovie) then
  196.     SXMovie.SetMovieStateStop;
  197. end;
  198.  
  199. {SXMovie}
  200.  
  201. procedure TSXMovie.SetFilename(Value: TFilename);
  202. begin
  203.   if Value <> '' then
  204.     FFilename := Value;
  205. end;
  206.  
  207. procedure TSXMovie.SetScreenRect(Value: TScreenRect);
  208. begin
  209.   FScreenRect.Assign(Value);
  210. end;
  211.  
  212. procedure TSXMovie.DoMovieEnd;
  213. begin
  214.   if Assigned(FOnMovieEnd) then FOnMovieEnd(Self);
  215. end;
  216.  
  217. procedure TSXMovie.DoBeforeRender;
  218. begin
  219.   if Assigned(FOnBeforeRender) then FOnBeforeRender(Self);
  220. end;
  221.  
  222. procedure TSXMovie.DoAfterRender;
  223. begin
  224.   if Assigned(FOnAfterRender) then FOnAfterRender(Self);
  225. end;
  226.  
  227. procedure TSXMovie.Notification(AComponent: TComponent; Operation: TOperation);
  228. begin
  229.   if Operation = opRemove then
  230.   begin
  231.     if AComponent is TDXDraw then FDXDraw := nil;
  232.     if AComponent is TDXSound then FDXSound := nil;
  233.   end;
  234.   inherited;
  235. end;
  236.  
  237. procedure TSXMovie.SetMovieStateRun;
  238. begin
  239.   try
  240.     if FMMStream.SetState(STREAMSTATE_RUN) <> S_OK then
  241.       Exception.Create('Set Movie State Run Exception');
  242.   except
  243.   end;
  244. end;
  245.  
  246. procedure TSXMovie.SetMovieStateStop;
  247. begin
  248.   try
  249.     FMMStream.SetState(STREAMSTATE_STOP);
  250.   finally
  251.     FPlaying := False;
  252.   end;
  253. end;
  254.  
  255. procedure TSXMovie.CreateMediaStream;
  256. var
  257.   wPath:{$IFDEF UNICODE}array of Char{$ELSE}array[0..MAX_PATH] of WChar{$ELSE}{$ENDIF};
  258.   AMStream:IAMMultiMediaStream;
  259.   Media:IMediaStream;
  260. begin
  261.    Media := nil;
  262.    AMStream := nil;
  263.    try
  264.       CoCreateinstance(CLSID_AMMULTIMEDIASTREAM,nil,CLSCTX_INPROC_SERVER,IID_IAMMULTIMEDIASTREAM,AMStream);
  265.       {$IFDEF UNICODE}
  266.       SetLength(wPath, Length(Filename) + 1);
  267.       StrPCopy(@wPath, Filename);
  268.       {$ELSE}
  269.       MultiByteToWideChar(CP_ACP,0,PAnsiChar(Filename),-1,wPath,Sizeof(wPAth) div sizeof(wPath[0]));
  270.       {$ENDIF}
  271.       AMStream.Initialize(STREAMTYPE_READ,AMMSF_NOGRAPHTHREAD,nil);
  272.       if (DXSound <> nil) and (DXSound.DSound <> nil) and (DXSound.DSound.ISound <> nil) then
  273.          AMStream.AddMediaStream(DXSound.DSound.ISound,{$IFDEF UNICODE}@{$ENDIF}MSPID_PrimaryAudio,AMMSF_ADDDEFAULTRENDERER,IMediaStream(nil^));
  274.       AMStream.AddMediaStream(DXDraw.DDraw.IDraw,{$IFDEF UNICODE}@{$ENDIF}MSPID_PrimaryVideo,0,Media);
  275.       AMStream.OpenFile({$IFDEF UNICODE}@{$ENDIF}wPAth,0);
  276.       FMMStream := AMStream;
  277.    except
  278.       FMMStream := nil;
  279.    end;
  280. end;
  281.  
  282. procedure TSXMovie.SetupMediaSample;
  283. begin
  284.   try
  285.     FSample := nil;
  286.     FDDStream := nil;
  287.     FPrimaryVidStream := nil;
  288.     if FMMStream.GetMediaStream(MSPID_PrimaryVideo, FPrimaryVidStream) <> S_OK then Exit;
  289.     if FPrimaryVidStream.QueryInterface(IID_IDirectDrawMediaStream, FDDStream) <> S_OK then Exit;
  290.     if FDDStream.CreateSample(nil, PRect(nil)^, 0, FSample) <> S_OK then Exit;
  291.     FDXSurface := TDirectDrawSurface.Create(FDXDraw.DDraw);
  292.     if FSample.GetSurface(FSurface, FRect) <> S_OK then Exit;
  293.     FDXSurface.IDDSurface := FSurface;
  294.   except
  295.  
  296.   end;
  297. end;
  298.  
  299. procedure TSXMovie.UpDate;
  300.   function AspectRatio(SourceRect: TRect; var DestRect: TRect): Boolean;
  301.   var
  302.     SourceWidth, SourceHeight, DestWidth, DestHeight: Integer;
  303.     SourceRatio, DestRatio: Double;
  304.   begin
  305.     Result := False;
  306.     SourceWidth := SourceRect.Right - SourceRect.Left;
  307.     SourceHeight := SourceRect.Bottom - SourceRect.Top;
  308.     SourceRatio := SourceWidth/SourceHeight;
  309.  
  310.     DestWidth := DestRect.Right - DestRect.Left;
  311.     DestHeight := DestRect.Bottom - DestRect.Top;
  312.     DestRatio := DestWidth/DestHeight;
  313.     if SourceRatio <> DestRatio  then
  314.     begin
  315.       if DestWidth > DestHeight then
  316.         DestRect.Bottom := DestRect.Top + Round(DestWidth / SourceRatio)
  317.       else
  318.         DestRect.Right := DestRect.Left + Round(SourceRatio * DestHeight);
  319.       Result := True;
  320.     end;
  321.   end;
  322. var
  323.   R: TRect;
  324.   Q: HResult;
  325. begin
  326.   try
  327.     Q := FSample.Update(0, 0, nil, 0);
  328.     case Q of
  329.       HResult(MS_S_PENDING):;
  330.       HResult(MS_S_NOUPDATE):;
  331.       HResult(MS_S_ENDOFSTREAM):;
  332.     end;
  333.     if Q <> S_OK then
  334.     begin
  335.       FMovieThread.Terminate;
  336.       SetMovieStateStop;
  337.       FPlaying := False;
  338.       DoMovieEnd;
  339.       Exit;
  340.     end;
  341.     if (FSurface <> nil) and DXDraw.CanDraw then
  342.     begin
  343.       DoBeforeRender;
  344.       R := FDestRect;
  345.       if AspectRatio(FRect, R) then
  346.         FDestRect := R;
  347.       DXDraw.Surface.StretchDraw(FDestRect, FRect, FDXSurface, False);
  348.       with DXDraw.Surface.Canvas do
  349.       begin
  350.         Brush.Style := bsClear;
  351.         Font.Color := clWhite;
  352.         Font.Size := 8;
  353.         Textout(5, 5, 'SilleX Media - Beta 1');
  354.         Release;
  355.       end;
  356.       DoAfterRender;
  357.       if DoFlip then
  358.         DXDraw.Flip;
  359.     end;
  360.   except
  361.     on E: Exception do
  362.       ShowMessage(E.Message);
  363.   end;
  364. end;
  365.  
  366. procedure TSXMovie.DisplayRect(Top, Left, Right, Bottom: integer);
  367. begin
  368.   if not (csDesigning in ComponentState) then
  369.   begin
  370.     FScreenRect.Top := Top;
  371.     FSCreenRect.Left := Left;
  372.     FScreenRect.Right := Right;
  373.     FScreenRect.Bottom := Bottom;
  374.   end;
  375. end;
  376.  
  377. procedure TSXMovie.Play;
  378. begin
  379.   if not (csDesigning in ComponentState) then
  380.   begin
  381.     FDestRect.Left := FScreenRect.Left;
  382.     FDestRect.Right := FScreenRect.Right;
  383.     FDestRect.Top := FScreenRect.Top;
  384.     FDestRect.Bottom := FScreenRect.Bottom;
  385.     FPlaying := True;
  386.     CreateMediaStream;
  387.     SetupMediaSample;
  388.     if FSample <> nil then
  389.     begin
  390.       FMovieThread := TMovieThread.Create(True);
  391.       if Assigned(FMovieThread) then
  392.       begin
  393.         FMovieThread.FreeOnTerminate := False;
  394.         FMovieThread.SXMovie := Self;
  395.         FMovieThread.Resume;
  396.       end;
  397.     end;
  398.   end;
  399. end;
  400.  
  401. procedure TSXMovie.Stop;
  402. begin
  403.   if not (csDesigning in ComponentState) then
  404.   begin
  405.     FPlaying := False;
  406.     if Assigned(FMovieThread) then
  407.     begin
  408.       if not FMovieThread.Terminated then
  409.       begin
  410.         FMovieThread.Terminate;
  411.         DoMovieEnd;
  412.       end;
  413.       FMovieThread.Free;
  414.       FMovieThread := nil;
  415.     end;
  416.     if FDXSurface <> nil then
  417.     begin
  418.       FDXSurface.Free;
  419.       FSurface := nil;
  420.     end;
  421.   end;
  422. end;
  423.  
  424. constructor TSXMovie.Create(AOwner: TComponent);
  425. begin
  426.   inherited Create(AOwner);
  427.   FScreenRect := TScreenRect.Create;
  428.   CoInitialize(nil);
  429. end;
  430.  
  431. destructor TSXMovie.Destroy;
  432. begin
  433.   if not (csDesigning in ComponentState) then
  434.   begin
  435.     FPlaying := False;
  436.     if Assigned(FMovieThread) then
  437.     begin
  438.       if not FMovieThread.Terminated then
  439.         FMovieThread.Terminate;
  440.       FMovieThread.Free;
  441.       FMovieThread := nil;
  442.     end;
  443.     if Assigned(FSample) then
  444.       FSample := nil;
  445.     if Assigned(FDDStream) then
  446.       FDDStream := nil;
  447.     if Assigned(FPrimaryVidStream) then
  448.       FPrimaryVidStream := nil;
  449.     if Assigned(FMMStream) then
  450.       FMMStream := nil;
  451.     if Assigned(FSurface) then
  452.       FSurface := nil;
  453.   end;
  454.   FScreenRect.Free;
  455.   CoUnInitialize;
  456.   inherited;
  457. end;
  458.  
  459. end.
  460.  
  461.