///////////////////////////////////////////////////////////////////////////////
// ddex1_api.dpr
///////////////////////////////////////////////////////////////////////////////
// Delphi conversion of the ddex1 example contained in Microsoft's DirectX sdk.
// Based on Eric Unger's conversions of the DirectX headers. They're available
// at _http://www.delphi-jedi.org. Bug reports to meyerhoff@earthling.net.
//
// FPC Port by Thomas Schatzl (tom_at_work@yline.com)
///////////////////////////////////////////////////////////////////////////////
// Description:
// Direct Draw example program 1. Creates a Direct Draw object and then a
// primary surface with a back buffer. Slowly flips between the primary surface
// and the back buffer. Press F12 or Escape to terminate the program.
///////////////////////////////////////////////////////////////////////////////
program ddex1_api;
//-----------------------------------------------------------------------------
// Include files
//-----------------------------------------------------------------------------
uses
Windows, DirectDraw, SysUtils, directdrawfpc;
const
//---------------------------------------------------------------------------
// Local definitions
//---------------------------------------------------------------------------
NAME : PChar = 'DDExample1';
TITLE : PChar = 'Direct Draw Example 1';
//---------------------------------------------------------------------------
// Default settings
//---------------------------------------------------------------------------
TIMER_ID = 1;
TIMER_RATE = 500;
var
//---------------------------------------------------------------------------
// Global data
//---------------------------------------------------------------------------
g_pDD : IDirectDraw4; // DirectDraw object
g_pDDSPrimary : IDirectDrawSurface4; // DirectDraw primary surface
g_pDDSBack : IDirectDrawSurface4; // DirectDraw back surface
g_bActive : Boolean = False; // Is application active?
//---------------------------------------------------------------------------
// Local data
//---------------------------------------------------------------------------
szMsg : PChar = 'Page Flipping Test: Press F12 to exit';
szFrontMsg : PChar = 'Front buffer (F12 to quit)';
szBackMsg : PChar = 'Back buffer (F12 to quit)';
var x : longint = 0;
//-----------------------------------------------------------------------------
// Name: ReleaseAllObjects
// Desc: Finished with all objects we use; release them
//-----------------------------------------------------------------------------
procedure ReleaseAllObjects;
begin
if Assigned(g_pDD) then
begin
if Assigned(g_pDDSBack) then
begin
g_pDDSBack := nil;
end;
if Assigned(g_pDDSPrimary) then
begin
g_pDDSPrimary := nil;
end;
g_pDD := nil;
end;
end;
//-----------------------------------------------------------------------------
// Name: InitFail
// Desc: This function is called if an initialization function fails
//-----------------------------------------------------------------------------
function InitFail(h_Wnd : HWND; hRet : HRESULT; Text : string) : HRESULT;
begin
ReleaseAllObjects;
MessageBox(h_Wnd, PChar(Text + ': ' + DDErrorString(hRet)), TITLE, MB_OK);
DestroyWindow(h_Wnd);
Result := hRet;
end;
//-----------------------------------------------------------------------------
// Name: UpdateFrame
// Desc: Displays the proper text for the page
//-----------------------------------------------------------------------------
var
phase : Boolean = False;
procedure UpdateFrame(h_Wnd : HWND);
var
h_DC : HDC;
ddbltfx : TDDBltFx;
rc : TRect;
size : TSize;
begin
// Use the blter to do a color fill to clear the back buffer
FillChar(ddbltfx, SizeOf(ddbltfx), 0);
ddbltfx.dwSize := SizeOf(ddbltfx);
ddbltfx.dwFillColor := 0;
IDirectDrawSurface4_Blt(g_pDDSBack, nil, nil, nil,
DDBLT_COLORFILL or DDBLT_WAIT, @ddbltfx);
if IDirectDrawSurface4_GetDC(g_pDDSBack, h_DC) = DD_OK then
begin
SetBkColor(h_DC, RGB(0, 0, 255));
SetTextColor(h_DC, RGB(255, 255, 0));
if phase then
begin
GetClientRect(h_Wnd, @rc);
GetTextExtentPoint(h_DC, szMsg, StrLen(szMsg), size);
TextOut(h_DC, (rc.right - size.cx) div 2, (rc.bottom - size.cy) div 2,
szMsg, StrLen(szMsg));
TextOut(h_DC, 0, 0, szFrontMsg, StrLen(szFrontMsg));
phase := False;
end
else
begin
TextOut(h_DC, 0, 0, szBackMsg, StrLen(szBackMsg));
phase := True;
end;
IDirectDrawSurface4_ReleaseDC(g_pDDSBack, h_DC);
end;
end;
//-----------------------------------------------------------------------------
// Name: WindowProc
// Desc: The Main Window Procedure
//-----------------------------------------------------------------------------
function WindowProc(h_Wnd: HWND; aMSG: Cardinal; wParam: Cardinal;
Param: Integer) : Integer; stdcall;
var
hRet : HRESULT; s : string;
begin
case aMSG of
// Pause if minimized
WM_ACTIVATE:
begin
if HIWORD(wParam) = 0 then
g_bActive := True
else
g_bActive := False;
Result := 0;
Exit;
end;
// Clean up and close the app
WM_DESTROY:
begin
ReleaseAllObjects;
PostQuitMessage(0);
Result := 0;
Exit;
end;
// Handle any non-accelerated key commands
WM_KEYDOWN:
begin
case wParam of
VK_ESCAPE,
VK_F12:
begin
PostMessage(h_Wnd, WM_CLOSE, 0, 0);
Result := 0;
Exit;
end;
end;
end;
// Turn off the cursor since this is a full-screen app
WM_SETCURSOR:
begin
SetCursor(LoadIcon(0, IDC_ARROW));
Result := 1;
Exit;
end;
// Update and flip surfaces
WM_TIMER:
begin
if g_bActive and (TIMER_ID = wParam) then
begin
UpdateFrame(h_Wnd);
while True do
begin
hRet := IDirectDrawSurface4_Flip(g_pDDSPrimary, nil, 0);
if hRet = DD_OK then
Break;
if hRet = DDERR_SURFACELOST then
begin
hRet := IDirectDrawSurface4__Restore(g_pDDSPrimary);
if hRet <> DD_OK then
Break;
end;
if hRet <> DDERR_WASSTILLDRAWING then
Break;
end;
end;
end;
end;
Result := DefWindowProc(h_Wnd, aMSG, wParam, lParam);
end;
//-----------------------------------------------------------------------------
// Name: InitApp
// Desc: Do work required for every instance of the application:
// Create the window, initialize data
//-----------------------------------------------------------------------------
function InitApp(hInst : THANDLE; nCmdShow : Integer) : HRESULT;
var
h_Wnd : HWND;
wc : WNDCLASS;
ddsd : TDDSurfaceDesc2;
ddscaps : TDDSCaps2;
hRet : HRESULT;
pDDTemp : IDirectDraw;
begin
// Set up and register window class
wc.style := CS_HREDRAW or CS_VREDRAW;
wc.lpfnWndProc := @WindowProc;
wc.cbClsExtra := 0;
wc.cbWndExtra := 0;
wc.hInstance := hInst;
wc.hIcon := LoadIcon(hInst, 'MAINICON');
wc.hCursor := LoadCursor(0, IDC_ARROW);
wc.hbrBackground := GetStockObject(BLACK_BRUSH);
wc.lpszMenuName := NAME;
wc.lpszClassName := NAME;
RegisterClass(wc);
// Create a window
h_Wnd := CreateWindowEx(WS_EX_TOPMOST,
NAME,
TITLE,
WS_POPUP,
0,
0,
GetSystemMetrics(SM_CXSCREEN),
GetSystemMetrics(SM_CYSCREEN),
0,
0,
hInst,
nil);
if h_Wnd = 0 then
begin
Result := 0;
Exit;
end;
ShowWindow(h_Wnd, nCmdShow);
UpdateWindow(h_Wnd);
SetFocus(h_Wnd);
///////////////////////////////////////////////////////////////////////////
// Create the main DirectDraw object
///////////////////////////////////////////////////////////////////////////
hRet := DirectDrawCreate(nil, pDDTemp, nil);
if hRet <> DD_OK then
begin
Result := InitFail(h_Wnd, hRet, 'DirectDrawCreate FAILED');
Exit;
end;
hRet := IDirectDraw_QueryInterface(pDDTemp, IID_IDirectDraw4, g_pDD);
if hRet <> DD_OK then
begin
Result := InitFail(h_Wnd, hRet, 'QueryInterface FAILED');
Exit;
end;
pDDTemp := nil;
// Get exclusive mode
hRet := IDirectDraw4_SetCooperativeLevel(g_pDD,
h_Wnd, DDSCL_EXCLUSIVE or DDSCL_FULLSCREEN);
if hRet <> DD_OK then
begin
Result := InitFail(h_Wnd, hRet, 'SetCooperativeLevel FAILED');
Exit;
end;
// Set the video mode to 640x480x8
hRet := IDirectDraw4_SetDisplayMode(g_pDD, 640, 480, 8, 0, 0);
if hRet <> DD_OK then
begin
Result := InitFail(h_Wnd, hRet, 'SetDisplayMode FAILED');
Exit;
end;
// Create the primary surface with 1 back buffer
FillChar(ddsd, SizeOf(ddsd), 0);
ddsd.dwSize := SizeOf(ddsd);
ddsd.dwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
ddsd.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE or
DDSCAPS_FLIP or DDSCAPS_COMPLEX;
ddsd.dwBackBufferCount := 1;
hRet := IDirectDraw4_CreateSurface(g_pDD, ddsd, g_pDDSPrimary, nil);
if hRet <> DD_OK then
begin
Result := InitFail(h_Wnd, hRet, 'CreateSurface FAILED');
Exit;
end;
// Get a pointer to the back buffer
FillChar(ddscaps, SizeOf(ddscaps), 0);
ddscaps.dwCaps := DDSCAPS_BACKBUFFER;
hRet := IDirectDrawSurface4_GetAttachedSurface(g_pDDSPrimary,
ddscaps, g_pDDSBack);
if hRet <> DD_OK then
begin
Result := InitFail(h_Wnd, hRet, 'GetAttachedSurface FAILED');
Exit;
end;
// Create a timer to flip the pages
if TIMER_ID <> SetTimer(h_Wnd, TIMER_ID, TIMER_RATE, nil) then
begin
Result := InitFail(h_Wnd, hRet, 'SetTimer FAILED');
Exit;
end;
Result := DD_OK;
end;
//-----------------------------------------------------------------------------
// Name: WinMain
// Desc: Initialization, message loop
//-----------------------------------------------------------------------------
var
aMSG : MSG;
begin
if InitApp(GetModuleHandle(nil), SW_SHOW) <> DD_OK then
begin
Exit;
end;
while GetMessage(@aMSG, 0, 0, 0) do
begin
TranslateMessage(aMSG);
DispatchMessage(aMSG);
end;
end.
вроде написанно правильно, а он не компилирует ( компилятор дельфи 7.0)
