丛书上抄来的!~谁能帮我调通!~unit Unit1;interfaceuses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, DXClass, DXDraws, DirectX;type
TForm1 = class(TForm)
DXTimer1: TDXTimer;
procedure FormCreate(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure DXTimer1Activate(Sender: TObject);
private
FDirectDraw: IDirectDraw;
FPrimarySurface: IDirectDrawSurface;
FBackSurface: IDirectDrawSurface;
FActive: Boolean;
FPhase: Byte;
FFrontMsg,FBackMsg: String;
procedure Start;
{ Private declarations }
public
{ Public declarations }
end;const
AFileName: String = 'c:\debug.txt';var
Form1: TForm1;
DebugFile: TextFile;implementation{$R *.dfm}procedure TForm1.FormCreate(Sender: TObject);
begin
width := 800;
height := 600;
FdirectDraw := nil;
Fphase := 0;
FActive := False;
FFrontMsg := 'Front buffer (按F12或者Esc退出)';
FBackMsg := 'Back buffer (按F12或者Esc退出)';
end;procedure TForm1.Start;
var
hr: Hresult;
SurfaceDesc: TDDSurfaceDesc;
DDSCaps: TDDScaps;
DC: HDC;
begin
hr := DirectDrawCreate(nil,FDirectDraw,nil);
if(hr = DD_OK) then
begin
hr := FDirectDraw.SetCooperativeLevel(Handle,DDSCL_EXCLUSIVE or DDSCL_FULLSCREEN); if(hr = DD_OK) then
begin
hr := FDirectDraw.SetDisplayMode(640,480,8); if(hr = DD_OK) then
begin
SurfaceDesc.dwSize := sizeof(SurfaceDesc);
SurfaceDesc.dwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
SurfaceDesc.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE or DDSCAPS_FLIP or DDSCAPS_COMPLEX;
SurfaceDesc.dwBackBufferCount := 1;
hr := FDirectDraw.CreateSurface(SurfaceDesc,FPrimarySurface,nil); if(hr = DD_OK) then
begin
ddscaps.dwCaps := DDSCAPS_BACKBUFFER;
hr := FPrimarySurface.GetAttachedSurface(ddscaps,FBackSurface); if(hr = DD_OK) then
begin
if(FPrimarySurface.GetDC(DC) = DD_OK) then
begin
Setbkcolor(DC, RGB(0, 0, 255));
SetTextColor(DC, RGB(255, 255, 0));
TextOut(DC, 0, 0, Pchar(FFrontMsg), Length(FFrontMsg));
FPrimarySurface.ReleaseDC(DC);
end; if(FPrimarySurface.GetDC(DC) = DD_OK) then
begin
Setbkcolor(DC, RGB(0, 0, 255));
SetTextColor(DC, RGB(255, 255, 0));
TextOut(DC, 0, 0, Pchar(FBackMsg), Length(FBackMsg));
FPrimarySurface.ReleaseDC(DC);
end; FActive := True;
DXTimer1.Enabled := True;
Exit;
end;
end;
end;
end;
end;
//MessageBox(Handle, Pchar(ForMat('Direct Draw Init Failed %x')),'ERROR',MB_OK);
SHowMessage('Direct Draw Init Failed %X');
Close();
end;procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case Key of
VK_F3: Start();
VK_ESCAPE,VK_F12:
begin
DXTimer1.Enabled := False;
Close;
end;
end;
end;procedure TForm1.FormDestroy(Sender: TObject);
begin
if FDirectDraw <> nil then
begin
FDirectDraw.FlipToGDISurface;
FDirectDraw.SetCooperativeLevel(Handle,DDSCL_NORMAL);
if FbackSurface <> nil then
FBackSurface := nil;
if FPrimarySurface <> nil then
FprimarySurface := nil;
FdirectDraw := nil;
end;
end;procedure TForm1.FormPaint(Sender: TObject);
const
Msg = 'Page Flippiing Test: Press F3 to strt, F12 or Esc to Exit';
var
rc: TRect;
size: TSize;
DC: HDC;
begin
if not(FActive) then
begin
DC := GetDC(Handle);
rc := GetClientRect;
WriteLn(DebugFile, 'Left:', rc.Left, ' Top:', rc.Top, 'Right:', rc.Right, 'Bottom:', rc.Bottom);
GetTextExtentpoint(DC, Msg, Length(Msg), size);
SetBkcolor(DC, RGB(0, 0, 0));
settextcolor(DC,RGB(255, 255, 0));
TextOut(DC, (rc.Right - size.cx) div 2, (rc.Bottom - size.cy) div 2, Pchar(Msg), Length(Msg));
ReleaseDc(Handle, DC);
end;end;procedure TForm1.DXTimer1Activate(Sender: TObject);
var
Dc: HDC;
hr: HResult;
begin
if (FBackSurface.GetDC(DC) = DD_OK) then
begin
if FPhase <> 0 then
begin
SetBkColor(DC, RGB(0, 0, 255));
SetTextColor(DC, RGB(255, 255, 0));
TextOut(Dc, 0, 0, PChar(FFrontMsg), Length(FFrontMsg));
FPhase := 0;
end
else
begin
SetBkColor(DC, RGB(0, 0, 255));
SetTextColor(DC, RGB(0, 255, 255));
TextOut(Dc, 0, 0, PChar(FBackMsg), Length(FBackMsg));
FPhase := 1;
end;
FBackSurface.ReleaseDC(DC);
end; while (True) do
begin
hr := FprimarySurface.Flip(nil, 0); if (hr = DD_ok) then
break; if(hr = DDERR_SURFACELOST) then
begin
if(hr <> DD_OK) then
break;
end; if (hr <> DDERR_WASSTILLDRAWING) then
break;
end;end;initialization
AssignFile(DebugFile,AfileName);
ReWrite(DebugFile);
finalization
CloseFile(DebugFile);
end.
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, DXClass, DXDraws, DirectX;type
TForm1 = class(TForm)
DXTimer1: TDXTimer;
procedure FormCreate(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure DXTimer1Activate(Sender: TObject);
private
FDirectDraw: IDirectDraw;
FPrimarySurface: IDirectDrawSurface;
FBackSurface: IDirectDrawSurface;
FActive: Boolean;
FPhase: Byte;
FFrontMsg,FBackMsg: String;
procedure Start;
{ Private declarations }
public
{ Public declarations }
end;const
AFileName: String = 'c:\debug.txt';var
Form1: TForm1;
DebugFile: TextFile;implementation{$R *.dfm}procedure TForm1.FormCreate(Sender: TObject);
begin
width := 800;
height := 600;
FdirectDraw := nil;
Fphase := 0;
FActive := False;
FFrontMsg := 'Front buffer (按F12或者Esc退出)';
FBackMsg := 'Back buffer (按F12或者Esc退出)';
end;procedure TForm1.Start;
var
hr: Hresult;
SurfaceDesc: TDDSurfaceDesc;
DDSCaps: TDDScaps;
DC: HDC;
begin
hr := DirectDrawCreate(nil,FDirectDraw,nil);
if(hr = DD_OK) then
begin
hr := FDirectDraw.SetCooperativeLevel(Handle,DDSCL_EXCLUSIVE or DDSCL_FULLSCREEN); if(hr = DD_OK) then
begin
hr := FDirectDraw.SetDisplayMode(640,480,8); if(hr = DD_OK) then
begin
SurfaceDesc.dwSize := sizeof(SurfaceDesc);
SurfaceDesc.dwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
SurfaceDesc.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE or DDSCAPS_FLIP or DDSCAPS_COMPLEX;
SurfaceDesc.dwBackBufferCount := 1;
hr := FDirectDraw.CreateSurface(SurfaceDesc,FPrimarySurface,nil); if(hr = DD_OK) then
begin
ddscaps.dwCaps := DDSCAPS_BACKBUFFER;
hr := FPrimarySurface.GetAttachedSurface(ddscaps,FBackSurface); if(hr = DD_OK) then
begin
if(FPrimarySurface.GetDC(DC) = DD_OK) then
begin
Setbkcolor(DC, RGB(0, 0, 255));
SetTextColor(DC, RGB(255, 255, 0));
TextOut(DC, 0, 0, Pchar(FFrontMsg), Length(FFrontMsg));
FPrimarySurface.ReleaseDC(DC);
end; if(FPrimarySurface.GetDC(DC) = DD_OK) then
begin
Setbkcolor(DC, RGB(0, 0, 255));
SetTextColor(DC, RGB(255, 255, 0));
TextOut(DC, 0, 0, Pchar(FBackMsg), Length(FBackMsg));
FPrimarySurface.ReleaseDC(DC);
end; FActive := True;
DXTimer1.Enabled := True;
Exit;
end;
end;
end;
end;
end;
//MessageBox(Handle, Pchar(ForMat('Direct Draw Init Failed %x')),'ERROR',MB_OK);
SHowMessage('Direct Draw Init Failed %X');
Close();
end;procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case Key of
VK_F3: Start();
VK_ESCAPE,VK_F12:
begin
DXTimer1.Enabled := False;
Close;
end;
end;
end;procedure TForm1.FormDestroy(Sender: TObject);
begin
if FDirectDraw <> nil then
begin
FDirectDraw.FlipToGDISurface;
FDirectDraw.SetCooperativeLevel(Handle,DDSCL_NORMAL);
if FbackSurface <> nil then
FBackSurface := nil;
if FPrimarySurface <> nil then
FprimarySurface := nil;
FdirectDraw := nil;
end;
end;procedure TForm1.FormPaint(Sender: TObject);
const
Msg = 'Page Flippiing Test: Press F3 to strt, F12 or Esc to Exit';
var
rc: TRect;
size: TSize;
DC: HDC;
begin
if not(FActive) then
begin
DC := GetDC(Handle);
rc := GetClientRect;
WriteLn(DebugFile, 'Left:', rc.Left, ' Top:', rc.Top, 'Right:', rc.Right, 'Bottom:', rc.Bottom);
GetTextExtentpoint(DC, Msg, Length(Msg), size);
SetBkcolor(DC, RGB(0, 0, 0));
settextcolor(DC,RGB(255, 255, 0));
TextOut(DC, (rc.Right - size.cx) div 2, (rc.Bottom - size.cy) div 2, Pchar(Msg), Length(Msg));
ReleaseDc(Handle, DC);
end;end;procedure TForm1.DXTimer1Activate(Sender: TObject);
var
Dc: HDC;
hr: HResult;
begin
if (FBackSurface.GetDC(DC) = DD_OK) then
begin
if FPhase <> 0 then
begin
SetBkColor(DC, RGB(0, 0, 255));
SetTextColor(DC, RGB(255, 255, 0));
TextOut(Dc, 0, 0, PChar(FFrontMsg), Length(FFrontMsg));
FPhase := 0;
end
else
begin
SetBkColor(DC, RGB(0, 0, 255));
SetTextColor(DC, RGB(0, 255, 255));
TextOut(Dc, 0, 0, PChar(FBackMsg), Length(FBackMsg));
FPhase := 1;
end;
FBackSurface.ReleaseDC(DC);
end; while (True) do
begin
hr := FprimarySurface.Flip(nil, 0); if (hr = DD_ok) then
break; if(hr = DDERR_SURFACELOST) then
begin
if(hr <> DD_OK) then
break;
end; if (hr <> DDERR_WASSTILLDRAWING) then
break;
end;end;initialization
AssignFile(DebugFile,AfileName);
ReWrite(DebugFile);
finalization
CloseFile(DebugFile);
end.
解决方案 »
- 关于邮件客户端的问题
- 怎么样在主Exe和动态调用的Package中使用和共享全局变量参数?
- 请教小问题,谁知道这段代码中$的含义
- 主窗体form1调用子窗体form2时,怎么样使form1最小化时,form2还存在于屏幕上?
- 哪位记得调用系统日历\计算器的函数怎么用了?
- 急求一个控件,能够使页面自动缩放。(在线等待)
- 在C中的这样的语句在Pascal中怎么写????
- delphi6处理dbf数据库的初级问题
- 为何dbgrideh在使用时,常常会在行列之间出现不连贯线条,刷新无法去除,请有类似经历高手帮助解决该问题
- 又一个update的问题!
- 200分,求调通下边代码!有关(DirectX)的!
- 部分匹配的过滤条件如何写???在线等待!!!!
procedure TForm1.DXTimer1Activate(Sender: TObject);
begin
//里面的东西都去掉就可以了
end;
当然有,不然我的程序怎么执行!To pankun:
[email protected]
谢谢~收到就揭帖!~
另:这里还有100分!~
http://expert.csdn.net/Expert/topic/1883/1883426.xml?temp=.8868677