{

Программа демонстрации DirectDraw и DirectShow.
Демонстрируется:
  Создание обьекта IDirectDraw4
  Создание  Surface'ов
  Загруска изображения из файла на Surface
  Загрузка палитры
  Blitting c использованием цветового ключа
  Спрайт
  Спрайтовая анимация
  Вывод видео-потока DirectShow из avi-файла на Surface

Автор: JINX (Elchin Aziz Ali OglI)
EMail: aziz@telebot.com, error@softhome.net
CopyLeft 2000.

}

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls,{не забыть DirectDraw}
  DShow, DDraw, ActiveX, ComObj, ExtCtrls;


type
  TForm1 = class(TForm)
    Timer1: TTimer;
    procedure FormDestroy(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormPaint(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
    FDirectDraw: IDirectDraw;           // обьект DirectDraw4
    FPrimarySurface: IDirectDrawSurface; // первый DirectDraw surface
    FSpriteSurface: IDirectDrawSurface;    // DirectDraw surface для хранения изображения Спрайта
    FPictureSurface: IDirectDrawSurface;    // DirectDraw surface для хранения фоновой картинки
    Palitra : IDirectDrawPalette;            //палитра
    MMStream : IMultiMediaStream;
    SpritePosX : integer; ///координата X
    SpritePosY : integer; /// и Y спрайта на экране
    AnimFrameN : integer; /// номер кадра "анимации" спрайта
    SpriteWidth : Integer; ///ширина картинки спрайта (одного кадра)
    SpriteHeight : Integer; ///высота картинки спрайта
    OldKvadrat : Trect;
  public
    { Public declarations }
    procedure DirecDrawZapusk;
    procedure PodgotovkaSuface;
    procedure RenderStreamToSurface(Surface : IDirectDrawSurface; MMStream : IMultiMediaStream);
    procedure RenderFileToMMStream(FileName : WideString; var MMStream :   IMultiMediaStream ; DDraw : IDirectDraw);
end;

{$DEFINE DIRECTX5}

var
  Form1: TForm1;
  DDStarted : boolean = False;
  PrimaryVidStream : IMediaStream;
  DDStream  :  IDirectDrawMediaStream;
  Sample : IDirectDrawStreamSample;


implementation

{$R *.DFM}


procedure TForm1.RenderStreamToSurface(Surface : IDirectDrawSurface; MMStream : IMultiMediaStream);
var
RECT : TRect;
ddsd :  TDDSURFACEDESC;
Z1 : DWORD;

begin
    MMStream.GetMediaStream(MSPID_PrimaryVideo, PrimaryVidStream);
    PrimaryVidStream.QueryInterface(IID_IDirectDrawMediaStream, DDStream);
    ddsd.dwSize := sizeof(ddsd);
    DDStream.GetFormat(ddsd, Palitra, ddsd, Z1);
    rect.top:=(480-ddsd.dwHeight)div 2; rect.left:=(640 - ddsd.dwWidth) div 2;
    rect.bottom := rect.top+ddsd.dwHeight;    rect.right := rect.left+ddsd.dwWidth;
    DDStream.CreateSample(Surface, Rect, 0, Sample);
    MMStream.SetState(STREAMSTATE_RUN);
end;



procedure TForm1.RenderFileToMMStream(FileName : WideString; var MMStream :   IMultiMediaStream ; DDraw : IDirectDraw);
var
AMStream : IAMMultiMediaStream;
NewMediaStremVideo, NewMediaStremAudio : IMediaStream;

begin
    CoCreateInstance(CLSID_AMMultiMediaStream, nil, CLSCTX_INPROC_SERVER,
        IID_IAMMultiMediaStream, AMStream);

    AMStream.Initialize(STREAMTYPE_READ, AMMSF_NOGRAPHTHREAD, nil);
    AMStream.AddMediaStream(DDraw, MSPID_PrimaryVideo, 0, NewMediaStremVideo);
    AMStream.AddMediaStream(nil, MSPID_PrimaryAudio, AMMSF_ADDDEFAULTRENDERER, NewMediaStremAudio);
    AMStream.OpenFile(PWideChar(FileName), 0);
    MMStream := AMStream;

end;



procedure TForm1.FormCreate(Sender: TObject);
begin
  {присвоим начальные значения}
    SpritePosX :=0; ///координата X
    SpritePosY :=100; /// и Y спрайта на экране
    AnimFrameN :=0; /// номер кадра "анимации" спрайта
    SpriteWidth :=47; ///ширина картинки спрайта (одного кадра)
    SpriteHeight :=23; ///высота картинки спрайта
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
if Key=VK_ESCAPE then ///закругляемся по Escape
 begin
 MMStream.SetState(STREAMSTATE_STOP);
 Timer1.Enabled:=False;
 Close; exit
 end;

if Key<>VK_SPACE then exit;
if not DDStarted then begin ///если мы еще не начали, то...
  ///  ...начнем, помолясь
  DirecDrawZapusk;
  PodgotovkaSuface;
 RenderFileToMMStream('cool.avi', MMStream, FDirectDraw);
 RenderStreamToSurface(FPrimarySurface, MMStream);

  DDStarted:=True;
  Timer1.Enabled:=True;
  exit;
end;

end;

procedure TForm1.DirecDrawZapusk;
var
  hr: HRESULT;
  SurfaceDesc: TDDSurfaceDesc;// TDDSURFACEDESC2;
  DDSCaps: TDDSCAPS2;
begin
///  ...начнем, помолясь
   hr := DirectDrawCreate(nil, FDirectDraw, nil); ///создали DirectDraw
  if(hr = DD_OK) then begin
    // Получим интерфейс IDirectDraw
    // Установим эксклюзивный уровень кооперации и полноэкранный режим
    hr := FDirectDraw.SetCooperativeLevel(Handle, DDSCL_EXCLUSIVE or DDSCL_FULLSCREEN {DDSCL_NORMAL});
    if(hr = DD_OK) then begin
      hr := FDirectDraw.SetDisplayMode(640, 480, 16);  ///переключаем видеорежим на 640X480X8
      if(hr = DD_OK) then begin
        // Создаем главный surface с одним back buffer'ом
        FillChar(SurfaceDesc,SizeOf(SurfaceDesc),0);
        SurfaceDesc.dwSize := SizeOf(SurfaceDesc);
        SurfaceDesc.dwFlags := DDSD_CAPS {or DDSD_BACKBUFFERCOUNT} ; ///говорим что нам нужны back buffer'ы
        SurfaceDesc.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE ////говорим что создаем первый Surface
                                     { or DDSCAPS_FLIP        //// во Flip-цепочке
                                      or DDSCAPS_COMPLEX};    //// а вообще будут и дополнительные Surface'ы
        SurfaceDesc.dwBackBufferCount := 1;                  //// число этих самых дополнительных - 1
        hr := FDirectDraw.CreateSurface(SurfaceDesc, FPrimarySurface, nil); ///все готово, создаем Surface'ы и запоминаем главный в FPrimarySurface
        if(hr = DD_OK) then begin
        FillChar(SurfaceDesc,SizeOf(SurfaceDesc),0);
        SurfaceDesc.dwSize := SizeOf(SurfaceDesc);
        SurfaceDesc.dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH;
        SurfaceDesc.dwHeight:=24;
        SurfaceDesc.dwWidth:=144;
        SurfaceDesc.ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
        hr := FDirectDraw.CreateSurface(SurfaceDesc,FSpriteSurface, nil); ///создаем Surface для хранения изображения спрайта
          if(hr = DD_OK) then begin
          FillChar(SurfaceDesc,SizeOf(SurfaceDesc),0);
          SurfaceDesc.dwSize := SizeOf(SurfaceDesc);
          SurfaceDesc.dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH;
          SurfaceDesc.dwHeight:=480;
          SurfaceDesc.dwWidth:=640;
          SurfaceDesc.ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
          hr := FDirectDraw.CreateSurface(SurfaceDesc,FPictureSurface, nil); ///создаем Surface для хранения фонового изображения
          if(hr = DD_OK) then begin
//            RenderFileToMMStream('C:\Program Files\Borland\Delphi5\Demos\Coolstuf\cool.avi', MMStream, DD);
//            RenderStreamToSurface(DDSurface, MMStream);
          {Все нормально - Surface'ы созданны - выходим}
            exit;
           end;
           end;
          end;
        end;
      end;
    end;
   {где-то была ошибка - сообщаем об этом неприятном факте}
  MessageBox(Self.Handle, PChar('Не удалось инициализировать DirectDraw! '+ ErrorString(Hr)),'ERROR', MB_OK);
  Close();
end;

procedure TForm1.PodgotovkaSuface;
var
  DC: HDC;
  i,j  : integer;
  AdresVideo : PByteArray;
  SurfaceDesc: TDDSURFACEDESC2;
  HR : HResult;
  Bitmap : TBItmap;
  PalEntries : Array[0..255] of TPaletteEntry; ///палитра
  ColorKey : TDDColorKey;  ///цветовой ключ

begin
{загружаем картинку на видимый  Surface и на Surface фона
и устанавливаем соответствующую палитру}
Bitmap:=TBitmap.Create;
Bitmap.LoadFromFile('Picture.bmp');
GetPaletteEntries(Bitmap.Palette,0,256,PalEntries);

FDirectDraw.CreatePalette(DDPCAPS_8BIT,@PalEntries,Palitra,nil);

if Palitra<> nil then begin
FPrimarySurface.SetPalette(Palitra);
FPictureSurface.SetPalette(Palitra);
end;

  if (FPrimarySurface.GetDC(DC) = DD_OK) then begin
  BitBlt(DC,0,0,640,480,Bitmap.Canvas.Handle,0,0,SRCCOPY);
  SetTextColor(DC,RGB(250,250,250));
  SetBkColor(DC,RGB(205,205,205));
  TextOut(DC,10,10,'Esc - выход',Length('Esc - выход'));
  FPrimarySurface.ReleaseDC(DC);
  end;

  if (FPictureSurface.GetDC(DC) = DD_OK) then begin
  BitBlt(DC,0,0,640,480,Bitmap.Canvas.Handle,0,0,SRCCOPY);
  SetTextColor(DC,RGB(250,250,250));
  SetBkColor(DC,RGB(205,205,205));
  TextOut(DC,10,10,'Пробел - спрайтовая анимация, Esc - выход',Length('Пробел - палитровая анимация, Esc - выход'));
  FPictureSurface.ReleaseDC(DC);
  end;
{фоновая картинка загружена}

{загружаем картинку из файла на Surface спрайта}

Bitmap.LoadFromFile('Sprite.bmp');

  if (FSpriteSurface.GetDC(DC) = DD_OK) then begin
  BitBlt(DC,0,0,Bitmap.Width,Bitmap.Height,Bitmap.Canvas.Handle,0,0,SRCCOPY);
  FSpriteSurface.ReleaseDC(DC);
  end;
 {устанавливаем цветовой ключ для нашего спрайта}
ColorKey.dwColorSpaceLowValue:=Bitmap.Canvas.Pixels[0,0];
ColorKey.dwColorSpaceHighValue:=Bitmap.Canvas.Pixels[0,0];
FSpriteSurface.SetColorKey(DDCKEY_SRCBLT, @ColorKey);
Bitmap.Free;
{спрайтовая картинка загружена}

end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if(FDirectDraw <> nil) then begin
  MMStream.SetState(STREAMSTATE_STOP);
    FDirectDraw.FlipToGDISurface;  ///переключаемся на тот Surface который использует GDI
    FDirectDraw.SetCooperativeLevel(Handle, DDSCL_NORMAL);
    if FSpriteSurface <> nil then 
      FSpriteSurface := nil;
    if FPrimarySurface <> nil then
      FPrimarySurface := nil;
    FDirectDraw := nil;
    MMStream:=nil;
  end;

end;


procedure TForm1.FormPaint(Sender: TObject);
begin
if not DDStarted then begin
Self.Canvas.Font.Color:=clAqua;
Self.Canvas.Font.Size:=18;
Self.Canvas.TextOut(25,25,'Нажмите пробел')
end;
end;


procedure TForm1.Timer1Timer(Sender: TObject);

var
hr : HResult;
Kvadrat : TRect;
MyDDBltFx :  TDDBltFX;

begin
 if not DDStarted then exit;

  {куда был выведен спрайт в предыдущей итерации}
OldKvadrat.Left:=SpritePosX;
OldKvadrat.Top:=SpritePosY;
OldKvadrat.Right:=OldKvadrat.Left+SpriteWidth;
OldKvadrat.Bottom:=OldKvadrat.Top+SpriteHeight;


{выводим на видимый Surface картинку (тем самым стирая находящийся на нем спрайт) (цветовой ключ не нужен) }
//hr:=FPrimarySurface.BltFast(SpritePosX,SpritePosY,FPictureSurface,@OldKvadrat,DDBLTFAST_NOCOLORKEY or DDBLTFAST_WAIT);
FillChar(MyDDBltFx,SizeOf(MyDDBltFx),0);
MyDDBltFx.dwSize:=SizeOf(MyDDBltFx);

hr:=FPrimarySurface.Blt(@OldKvadrat,FPictureSurface,@OldKvadrat,DDBLT_WAIT,@MyDDBltFx);

if (Hr=DD_OK) then begin
  INC(SpritePosX,5); /// спрайт при каждой итерации смещается вправо на 5 пикселов

{вычисляем координаты на Surface'e спрайта изображения очередного кадра }
  Kvadrat.Left:=AnimFrameN*SpriteWidth; Kvadrat.Top:=0; Kvadrat.Right:=(AnimFrameN+1)*SpriteWidth-1; Kvadrat.Bottom:=SpriteHeight;
 {меняем счетчик AnimFrameN -чтобы в следующей итерации взять другой кадр}
   INC(AnimFrameN); if AnimFrameN=3 then AnimFrameN:=0;

 {выводим на видимый Surface картинку спрайта с использованием цветового ключа }
  hr:=FPrimarySurface.BltFast(SpritePosX,SpritePosY,FSpriteSurface,@Kvadrat,DDBLTFAST_SRCCOLORKEY or DDBLTFAST_WAIT);

   {если спрайт добрался до правого края экрана снова переместим его влево,
   на случайную позицию по вертикали и на ноль по горизонтали}
  if SpritePosX>590 then begin SpritePosX:=0; Randomize; SpritePosY:=Random(43)*10+25; end;

    if (hr = DDERR_SURFACELOST) then ///пользователь уходил, нажав Alt+Tab - а теперь вернулся
    begin
      {восстановим Surface'ы}
//      FDirectDraw.RestoreAllSurfaces;
      PodgotovkaSuface;
    end;
  end;

   hr:=Sample.Update(0 , 0, nil, 0);

   if hr = $40003 {MS_S_ENDOFSTREAM} then
     MMStream.Seek(0);

end;

end.