可以用DirectDraw:
-------------------------------------
///////////////////////////////////////////////////////////////////////////////
// mytest_api.dpr
///////////////////////////////////////////////////////////////////////////////
// This is my test program;
///////////////////////////////////////////////////////////////////////////////
program mytest_api;
//-----------------------------------------------------------------------------
// Include files
//-----------------------------------------------------------------------------
uses
Windows, Messages, DirectDraw, SysUtils, DDUtil;
{$R *.res}
const
//---------------------------------------------------------------------------
// Local definitions
//---------------------------------------------------------------------------
NAME: PChar = 'DDExample2';
TITLE: PChar = 'Direct Draw Example 2';
szBitmap: PChar = 'Background.BMP';
Step: Integer = 100; //Fade In Step Count
var
//---------------------------------------------------------------------------
// Global data
//---------------------------------------------------------------------------
g_pDD: IDirectDraw7; // DirectDraw object
g_pDDSPrimary: IDirectDrawSurface7; // DirectDraw primary surface
g_pDDSBackGround: IDirectDrawSurface7; // DirectDraw back surface
g_pDDPal: IDIRECTDRAWPALETTE; // The primary surface palette
ddsd: TDDSurfaceDesc2;
AnimPalette, OrgPalette: array[0..255] of PALETTEENTRY; //调色板条目
g_bActive: Boolean = False; // Is application active?
//-----------------------------------------------------------------------------
// Name: ReleaseAllObjects
// Desc: Finished with all objects we use; release them
//-----------------------------------------------------------------------------
procedure ReleaseAllObjects;
begin
if Assigned(g_pDD) then
begin
if Assigned(g_pDDSPrimary) then
begin
g_pDDSPrimary := nil;
end;
if Assigned(g_pDDPal) then
begin
g_pDDPal := nil;
end;
if Assigned(g_pDDSBackGround) then
begin
g_pDDSBackGround := 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: FadeOut
// Desc: FadeOut
//-----------------------------------------------------------------------------
procedure FadeOut;
var
i, j: integer;
begin
for i := 0 to Step do
begin
for j := 0 to 255 do
begin
AnimPalette[j].peRed := OrgPalette[j].peRed - Trunc((OrgPalette[j].peRed * i) / Step);
AnimPalette[j].peGreen := OrgPalette[j].peGreen - Trunc((OrgPalette[j].peGreen * i) / Step);
AnimPalette[j].peBlue := OrgPalette[j].peBlue - Trunc((OrgPalette[j].peBlue * i) / Step);
AnimPalette[j].peFlags := PC_RESERVED;
end;
g_pDDPal.SetEntries(0, 0, 256, @AnimPalette);
Sleep(30);
end;
end;
//-----------------------------------------------------------------------------
// Name: FadeIn
// Desc: FadeIn
//-----------------------------------------------------------------------------
procedure FadeIn;
var
i, j: integer;
begin
for i := 0 to Step do
begin
for j := 0 to 255 do
begin
AnimPalette[j].peRed := Trunc((OrgPalette[j].peRed * i) / Step);
AnimPalette[j].peGreen := Trunc((OrgPalette[j].peGreen * i) / Step);
AnimPalette[j].peBlue := Trunc((OrgPalette[j].peBlue * i) / Step);
AnimPalette[j].peFlags := PC_RESERVED;
end;
g_pDDPal.SetEntries(0, 0, 256, @AnimPalette);
Sleep(30);
end;
end;
//-----------------------------------------------------------------------------
// Name: InitSurface
// Desc: Load a Bitmap into PrimarySurface.
//-----------------------------------------------------------------------------
procedure DrawSurface;
var
hRet: HRESULT;
begin
if g_pDDSBackGround = nil then exit;
hRet := g_pDDSPrimary.Blt(nil, g_pDDSBackGround, nil, DDBLT_WAIT, nil);
if hRet = DDERR_SURFACELOST then
begin
hRet := g_pDDSPrimary._Restore;
if hRet = DD_OK then
begin
hRet := g_pDDSBackGround._Restore;
if hRet = DD_OK then
begin
hRet := DDReLoadBitmap(g_pDDSBackGround, szBitmap);
if hRet = DD_OK then
g_pDDSPrimary.Blt(nil, g_pDDSBackGround, nil, DDBLT_WAIT, nil);
end;
end;
end;
end;
//-----------------------------------------------------------------------------
// Name: WindowProc
// Desc: The Main Window Procedure
//-----------------------------------------------------------------------------
function WindowProc(h_Wnd: HWND; aMSG: Cardinal; wParam: Cardinal; lParam: Integer): Integer; stdcall;
var
ps: PAINTSTRUCT;
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:
begin
FadeOut;
PostMessage(h_Wnd, WM_CLOSE, 0, 0);
Result := 0;
Exit;
end;
VK_F11:
begin
FadeIn;
Result := 0;
Exit;
end;
Vk_F12:
begin
FadeOut;
Result := 0;
Exit;
end;
end;
end;
// Turn off the cursor since this is a full-screen app
WM_SETCURSOR:
begin
SetCursor(0);
Result := 1;
Exit;
end;
WM_PAINT:
begin
BeginPaint(h_Wnd, ps);
DrawSurface;
EndPaint(h_wnd, ps);
Result := 0;
Exit;
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;
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 := pDDTemp.QueryInterface(IDirectDraw7, g_pDD);
if hRet <> DD_OK then
begin
Result := InitFail(h_Wnd, hRet, 'QueryInterface FAILED');
Exit;
end;
pDDTemp := nil;
// Get exclusive mode
hRet := g_pDD.SetCooperativeLevel(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 := g_pDD.SetDisplayMode(640, 480, 8, 0, 0);
if hRet <> DD_OK then
begin
Result := InitFail(h_Wnd, hRet, 'SetDisplayMode FAILED');
Exit;
end;
// Create the primary surface
FillChar(ddsd, SizeOf(ddsd), 0);
ddsd.dwSize := SizeOf(ddsd);
ddsd.dwFlags := DDSD_CAPS;
ddsd.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE;
hRet := g_pDD.CreateSurface(ddsd, g_pDDSPrimary, nil);
if hRet <> DD_OK then
begin
Result := InitFail(h_Wnd, hRet, 'CreateSurface FAILED');
Exit;
end;
// Create and set the palette
g_pDDPal := DDLoadPalette(g_pDD, szBitmap);
if g_pDDPal = nil then
begin
Result := InitFail(h_Wnd, hRet, 'DDLoadPalette FAILED');
Exit;
end;
//取得调色板条目
g_pDDpal.GetEntries(0, 0, 256, @OrgPalette);
hRet := g_pDDSPrimary.SetPalette(g_pDDPal);
if hRet <> DD_OK then
begin
Result := InitFail(h_Wnd, hRet, 'SetPalette FAILED');
Exit;
end;
// Create the offscreen surface, by loading our bitmap.
g_pDDSBackGround := DDLoadBitmap(g_pDD, szBitmap, 0, 0);
if g_pDDSBackGround = nil then
begin
Result := InitFail(h_Wnd, hRet, 'DDLoadBitmap FAILED');
Exit;
end;
DrawSurface;
SetCursor(0);
FadeIn;
Result := DD_OK;
end;
//-----------------------------------------------------------------------------
// Name: WinMain
// Desc: Initialization, message loop
//-----------------------------------------------------------------------------
type
Screen = array of Word;
var
aMSG: MSG;
begin
if InitApp(GetModuleHandle(nil), SW_SHOW) <> DD_OK then
begin
Exit;
end;
while True do
begin
if PeekMessage(aMsg, 0, 0, 0, PM_NOREMOVE) then
begin
if not GetMessage(aMsg, 0, 0, 0) then
Exit;
TranslateMessage(aMsg);
DispatchMessage(aMsg);
end
else
begin
// Make sure we go to sleep if we have nothing else to do
WaitMessage;
end;
end;
end.
