Инициализация и запуск DirectX

← →
romanus © (2004-07-04 14:04) [0]

Скажите, как правильно и чтоб работало без глюков, инициализировать и работать с DirectX в Delphi.
А то у меня с глюками (при работе просверкивает рабочий стол).

← →
Огромное Кулясищще © (2004-07-04 17:25) [1]

Стоп! Значит, что инициализировать? DirectDraw или Direct3D? Как инициализировтаь - оконный режим и полноэкранный?

← →
romanus © (2004-07-04 18:06) [2]

Требуется инициализировать DirectDraw в fullscreen режиме.

По Краснову. Инициализация, создание поверхностей, блиттинг. Выход по Alt+Tab и далее через Windows.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
AppEvnts,
DirectDraw;

type
TfrmDD = class(TForm)
ApplicationEvents1: TApplicationEvents;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure ApplicationEvents1Deactivate(Sender: TObject);
procedure ApplicationEvents1Restore(Sender: TObject);
private
{ Private declarations }
FDD : IDirectDraw7;
FDDSPrimary : IDirectDrawSurface7;
procedure ErrorOut(hRet : HRESULT; FuncName : string);
public
{ Public declarations }
end;

var
frmDD: TfrmDD;

implementation

{$R *.DFM}

procedure TfrmDD.ErrorOut(hRet : HRESULT; FuncName : string);
begin
MessageBox(0, PChar(FuncName + ": " + #13 + DDErrorString(hRet)),
PChar(Caption), MB_OK or MB_ICONSTOP);
end;

procedure TfrmDD.FormCreate(Sender: TObject);
var
hRet : HRESULT;
ddsd : TDDSurfaceDesc2;
begin
FDDSPrimary := nil;
FDD := nil;

hRet := DirectDrawCreateEx (nil, FDD, IDirectDraw7, nil);
if hRet <> DD_OK then begin
ErrorOut(hRet, "DirectDrawCreateEx");
Exit;
end;

hRet := FDD.SetCooperativeLevel(Handle, DDSCL_FULLSCREEN or DDSCL_EXCLUSIVE);
if hRet <> DD_OK then begin
ErrorOut(hRet, "SetCooperativeLevel");
Exit;
end;

FillChar (ddsd, SizeOf(ddsd), 0);
ddsd.dwSize := SizeOf(ddsd);
ddsd.dwFlags := DDSD_CAPS;
ddsd.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE;
hRet := FDD.CreateSurface(ddsd, FDDSPrimary, nil);
if hRet <> DD_OK then begin
ErrorOut(hRet, "Create Primary Surface");
Exit;
end;
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
if Assigned(FDD) then begin
if Assigned(FDDSPrimary) then FDDSPrimary := nil;
FDD := nil;
end;
end;

procedure TfrmDD.FormPaint(Sender: TObject);
var
DC : HDC;
wrkCanvas : TCanvas;
hRet : HRESULT;
ddbltfx : TDDBLTFX;
wrkBitmap : TBitmap;
begin
ZeroMemory(@ddbltfx, SizeOf(ddbltfx));
ddbltfx.dwSize := sizeof(ddbltfx);
ddbltfx.dwFillColor := 0;
while True do begin
hRet := FDDSPrimary.Blt(nil, nil, nil, DDBLT_COLORFILL or DDBLT_WAIT, @ddbltfx);
if hRet = DDERR_SURFACELOST then begin
hRet := FDDSPrimary._Restore;
if hRet <> DD_OK then Break;
end else Break;
end;
while True do begin
hRet := FDDSPrimary.GetDC(DC);
if Succeeded (hRet) then begin
wrkCanvas := TCanvas.Create;
wrkCanvas.Handle := DC;
wrkBitmap := TBitmap.Create;
wrkBitmap.LoadFromFile ("..\lake.bmp");
wrkCanvas.Draw(100, 100, wrkBitmap);
wrkBitmap.Free;
wrkCanvas.Free;
FDDSPrimary.ReleaseDC (DC);
Break;
end;
if hRet = DDERR_SURFACELOST then begin
hRet := FDDSPrimary._Restore;
if hRet <> DD_OK then Break;
end;
if hRet <> DDERR_WASSTILLDRAWING then Break;
end;
end;

procedure TfrmDD.ApplicationEvents1Deactivate(Sender: TObject);
begin
Application.Minimize;
end;

procedure TfrmDD.ApplicationEvents1Restore(Sender: TObject);
begin
WindowState := wsMaximized;
end;

end.

Инициализация и запуск DirectX Найти похожие ветки