DirectDraw 程序退出时出现错误

竹子的叶子

练习使用DirectDraw的时候，最后退出的时候总是错误，而且通过追踪，发现是在最后PostQuitMessage的时候发生错误，“Runtime error at 004030CC”，很奇怪。
代码在下：

program DirectTest;

uses
  Windows,
  Messages,
  DirectDraw;

var
  hWnd:integer;
  MSG:TMsg;

  DD:IDirectDraw7;
  DDSPrimary:IDirectDrawSurface7;
  DDSBuffer:IDirectDrawSurface7;
  DDSBack:IDirectDrawSurface7;

procedure ShowMsg(S:String);
begin
  MessageBox(hWnd,PChar(S),'Test',MB_OK);
end;  

procedure FreeDDraw;
begin
  ShowMsg('FreeDDraw');
  if DD<>nil then
  begin
    DD.FlipToGDISurface;
    DD.SetCooperativeLevel(hWnd,DDSCL_NORMAL);
    DD.RestoreAllSurfaces;
    if DDSBack<>nil then DDSBack:=nil;
    if DDSPrimary<>nil then DDSPrimary:=nil;
    DD:=nil;
  end;
end;

procedure Destroy;
begin
  FreeDDraw;
end;

function InitDDraw:Boolean;
var
  ddsd:TDDSurfaceDesc2;
begin
  result:=false;

  if DirectDrawCreateEx(nil,DD,IDirectDraw7,nil)<>DD_OK then exit;
  if DD.SetCooperativeLevel(hWnd,DDSCL_EXCLUSIVE or DDSCL_FULLSCREEN)<>DD_OK then exit;
  if DD.SetDisplayMode(1024,768,32,0,DDSDM_STANDARDVGAMODE)<>DD_OK then exit;

  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;

  if DD.CreateSurface(ddsd,DDSPrimary,nil)<>DD_OK then exit;

  ddsd.ddsCaps.dwCaps:=DDSCAPS_BACKBUFFER;
  if DDSPrimary.GetAttachedSurface(ddsd.ddsCaps,DDSBuffer)<>DD_OK then exit;

  ddsd.dwSize:=sizeof(ddsd);
  ddsd.dwFlags:=DDSD_CAPS or DDSD_WIDTH or DDSD_HEIGHT;
  ddsd.ddsCaps.dwCaps:=DDSCAPS_OFFSCREENPLAIN;
  ddsd.dwHeight:=768;
  ddsd.dwWidth:=1024;
  if DD.CreateSurface(ddsd,DDSBack,nil)<>DD_OK then exit;

  result:=true;
end;

function WindowProc(hWnd:integer; uMsg:UINT;wParam:WPARAM; lParamPARAM):LRESULT; stdcall;
begin
  result:=0;
  case uMsg of
    WM_KEYDOWN:
    begin
      case wParam of
      VK_ESCAPE:begin
                MessageBox(hWnd,'ESC被按下了！确定后退出！','Keyboard',MB_OK);
                PostMessage(hWnd,WM_CLOSE,0,0);
                end;
      end;
      exit;
    end;

    {WM_CLOSE:
    begin
      ShowMsg('WM_CLOSE');
      DestroyWindow(hWnd);
      exit;
    end; }
    WM_RBUTTONDOWN:
    begin
      MessageBox(hWnd,'鼠标右键按下了！','Mouse',MB_OK);
      exit;
    end;
    WM_DESTROY:
    begin
      ShowMsg('WM_DESTROY');
      FreeDDraw;
      ShowMsg('FreeDDraw finished!');
      PostQuitMessage(0);
      //PostMessage(hWnd,WM_QUIT,0,0);
      showmsg('postQuitMessage finished!');
      exit;
    end;
  end;
  result:=DefWindowProc(hWnd,uMsg,wParam,lParam);
end;

function InitWindow(hInstance:HINST;nCmdShow:integer):boolean;
var
  wc:TWndClass;
begin
  result:=false;
  wc.style:=0;
  wc.lpfnWndProc:=@WindowProc;
  wc.cbClsExtra:=0;
  wc.cbWndExtra:=0;
  wc.hInstance:=hInstance;
  wc.hIcon := LoadIcon(0, IDI_APPLICATION);
  wc.hCursor := LoadCursor(0, IDC_ARROW);
  //wc.hIcon:=0;
  //wc.hCursor:=0;
  wc.hbrBackground :=CreateSolidBrush(RGB(100,0,0));
  wc.lpszMenuName:=nil;
  wc.lpszClassName:='DirectTest_1';

  if RegisterClass(wc)=0 then exit;

  hWnd:=CreateWindow(wc.lpszClassName,'DirectTestProgram',WS_POPUP{ or WS_MAXIMIZE},0,0,//100,100,0,0,hInstance,nil);
                     GetSystemMetrics(SM_CXSCREEN),GetSystemMetrics(SM_CYSCREEN),
                     0,0,hInstance,nil);

  if hwnd=0 then exit;
  ShowWindow(hWnd, nCmdShow);
  UpdateWindow(hWnd);

  result:=true;
end;

function InitBitmap:boolean;
begin
  result:=false;
  
end;

procedure WinMain;
begin
  if not InitWindow(hInstance,CmdShow) then exit;
  if not InitDDraw then
  begin
    FreeDDraw;
    DestroyWindow(hWnd);
    exit;
  end;
  //while GetMessage(MSG, 0, 0, 0) do begin
  while true do
  begin
    if PeekMessage(Msg,0,0,0,PM_REMOVE) then
    begin
      if (msg.message = WM_QUIT) then
      begin
        ExitCode:=msg.wParam;
        break;
      end;
      TranslateMessage(Msg);
      DispatchMessage(Msg);
    end;
  end;
  Halt(MSG.wParam);
end;

begin
  WinMain;
end.

testerHooK

我写的DX程序都是基于VCL的，没有任何问题。

mikesimb

你的借口都不释放啊