gameclass.pas

很多人想要研究的真彩传奇2客户端,一般来说传奇2的客户端是256色的,现在出了个飞尔真彩传奇,想必很吸引大家的眼球.现在把我收藏的拿出来一起共享

  Result := FPrimarySurface.Blt(@FClientRect, FBufferSurface, nil, DDBLT_WAIT, nil);  //画到表面

  if Result = DDERR_SURFACELOST then
  begin
    // 重新生成主表面和缓冲表面
    if FDirectDraw.RestoreAllSurfaces <> DD_OK then Exit;
    // 重新载入所有表面图像(由用户处理)
    if not ReloadAllSurfaceImages then Exit;
  end;

  // 应该可以不需要(注:原来此句在 while (True) 循环中
  //    if Result <> DDERR_WASSTILLDRAWING then Break;
end;

procedure TGame.Init;
begin
  InitDirectDraw;
end;

procedure TGame.OnIdle;
begin
  FBackDxFastBlt.Fill(clBlack); //清空背景
  // 处理下一Frame(由用户设计)
  if ProcessNextFrame then begin
    Flip; // 刷新至主表面
  end;
end;

procedure TGame.Run;
var
  AMsg: MSG;
begin
  while True do
  begin
    if PeekMessage(AMsg, 0, 0, 0, PM_REMOVE) then
    begin
      if AMsg.message = WM_QUIT then
        Break
      else begin
        TranslateMessage(AMsg);
        DispatchMessage(AMsg);
      end;
    end
    else OnIdle;
  end;
end;

procedure TGame.SetCaption(const Value: string);
begin
  FCaption := Value;
end;

function TGame.WndProc(HWND: HWND; uMsg: UINT; wParam: wParam;
  lParam: lParam): LResult;
begin
  case uMsg of

    // 不需要处理的消息列表:
    // WM_CREATE
    // WM_GETMINMAXINFO   :
    // WM_SIZE            : 如果创建固定大小的窗口, 则不会产生 WM_SIZE 消息
    // WM_SETCURSOR       : 需要隐藏鼠标时

    WM_MOUSEMOVE:
      begin
        Result := WMMouseMove(HWND, uMsg, wParam, lParam);
        Exit;
      end;

    WM_LBUTTONDOWN:
      begin
        Result := WMLButtonDown(HWND, uMsg, wParam, lParam);
        Exit;
      end;

    WM_LBUTTONUP:
      begin
        Result := WMLButtonUp(HWND, uMsg, wParam, lParam);
        Exit;
      end;

    WM_RBUTTONDOWN:
      begin
        Result := WMRButtonDown(HWND, uMsg, wParam, lParam);
        Exit;
      end;

    WM_RBUTTONUP:
      begin
        Result := WMRButtonUp(HWND, uMsg, wParam, lParam);
        Exit;
      end;

    WM_SIZE:
      begin
        UpdateBounds;
      end;

    WM_MOVE:
      begin
        // 窗口移动后重新找回窗口位置
        UpdateBounds;
        Result := 0;
        Exit;
      end;

    WM_ACTIVATE:
      begin
        // 设置窗口的激活状态
        // TODO: 是否需要处理 WM_ACTIVATEAPP
        FActive := LoWord(wParam) <> WA_INACTIVE;
        Result := 0;
        Exit;
      end;

    WM_QUERYNEWPALETTE:
      begin
        // TODO: WM_QUERYNEWPALETTE

        {if ( g_pDisplay <> nil ) and ( g_pDisplay.GetFrontBuffer <> nil ) then
        begin
        // If we are in windowed mode with a desktop resolution in 8 bit
        // color, then the palette we created during init has changed
        // since then.  So get the palette back from the primary
        // DirectDraw surface, and set it again so that DirectDraw
        // realises the palette, then release it again.
          pDDPal := nil;
          g_pDisplay.GetFrontBuffer.GetPalette( pDDPal );
          g_pDisplay.GetFrontBuffer.SetPalette( pDDPal );
          pDDPal := nil;
        end;}
      end;

    WM_EXITMENULOOP:
      begin
        // TODO: Ignore time spent in menu
        // g_dwLastTick := GetTickCount;
      end;

    WM_EXITSIZEMOVE:
      begin
        // TODO: Ignore time spent resizing
        // g_dwLastTick := GetTickCount;
      end;

{    WM_SYSCOMMAND:
      begin
        // 在全屏模式下禁止移动/调整大小/显示器节能
        // TODO: 是不是要加入更多控制？
        if FFullScreen then
          case wParam of
            SC_MOVE, SC_SIZE, SC_MAXIMIZE, SC_MONITORPOWER:
            begin
              // 也许不需要设置为 1
              Result := 1;
              Exit;
            end;
          end;
      end;}

    WM_CLOSE:
      begin
        FTerminated := True; // 设置终止标志
        DestroyWindow(FMainWindow); // 删除窗口
        Result := 0;
        Exit;
      end;

    WM_DESTROY:
      begin
        if FTerminated then // 如果应用程序终止标志设置
        begin
          PostQuitMessage(0); // 终止消息循环
          Self.Free; // 清除自己
        end
        else FreeDirectDraw; // 否则仅清除 DirectDraw 对象

        Result := 0;
        Exit;
      end;
  end;
  Result := DefWindowProc(HWND, uMsg, wParam, lParam);
end;

procedure TGame.SetHeight(const Value: Integer);
begin
  FHeight := Value;
end;

procedure TGame.SetWidth(const Value: Integer);
begin
  FWidth := Value;
end;

procedure TGame.SetFullScreen(const Value: Boolean);
begin
  FFullScreen := Value;
end;

function TGame.ClearBufferSurface: Boolean;
var
  BltFx: TDDBltFX;
begin
  FillChar(BltFx, SizeOf(BltFx), #0);
  BltFx.dwSize := SizeOf(BltFx);
  BltFx.dwFillColor := FBackgroundColor;

  Result := BufferSurface.Blt(nil, nil, nil, DDBLT_COLORFILL, @BltFx) = DD_OK;
end;

procedure TGame.SetBackgroundColor(const Value: TColorRef);
begin
  FBackgroundColor := Value;
end;

procedure TGame.FreeDirectDraw;
begin
  FBufferSurface := nil;
  FPrimarySurface := nil;
  FDirectDraw := nil;
end;

procedure TGame.UpdateBounds;
begin
  // 全屏模式下, 主窗口坐标和客户区坐标同为屏幕大小
  if FFullScreen then
  begin
    SetRect(FClientRect, 0, 0, GetSystemMetrics(SM_CXSCREEN),
      GetSystemMetrics(SM_CYSCREEN));
  end
  // 窗口模式下, 主窗口坐标
  else begin
    GetClientRect(FMainWindow, FClientRect);
    ClientToScreen(FMainWindow, FClientRect.TopLeft);
    ClientToScreen(FMainWindow, FClientRect.BottomRight);
  end;
end;

function TGame.CreateSurfaceFromText(const AText: string;
  AFont: HFont): IDirectDrawSurface7;
var
  TextSize: TSize;
  TextLen: Integer;
  DDSD: TDDSurfaceDesc2;
  DC: HDC;
begin
  if (FDirectDraw = nil) or (AText = '') then Exit;

  TextLen := Length(AText);

  DC := GetDC(0);
  if AFont <> 0 then SelectObject(DC, AFont);
  GetTextExtentPoint32(DC, PChar(AText), TextLen, TextSize);
  ReleaseDC(0, DC);

  FillChar(DDSD, SizeOf(DDSD), #0);
  DDSD.dwSize := SizeOf(DDSD);
  DDSD.dwFlags := DDSD_CAPS or DDSD_WIDTH or DDSD_HEIGHT;
  DDSD.ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
  DDSD.dwWidth := TextSize.cx;
  DDSD.dwHeight := TextSize.cy;

  if FDirectDraw.CreateSurface(DDSD, Result, nil) <> DD_OK then Exit;
  if Result.GetDC(DC) <> DD_OK then Exit;

  if AFont <> 0 then SelectObject(DC, AFont);

  TextOut(DC, 0, 0, PChar(AText), TextLen);

  Result.ReleaseDC(DC);
end;

function TGame.CreateSurfaceFromBitmap(const ABitmapName: string;
  AColorKey: TColorRef): IDirectDrawSurface7;
var
  Bmp: BITMAP;
  hBmp: HBITMAP;
  DDSD: TDDSurfaceDesc2;
  DC, MemDC: HDC;
begin
  if FDirectDraw = nil then Exit;
  if ABitmapName = '' then Exit;

  hBmp := LoadImage(0, PChar(ABitmapName), IMAGE_BITMAP, 0, 0,
    LR_LOADFROMFILE or LR_CREATEDIBSECTION);

  if hBmp = 0 then Exit;

  GetObject(hBmp, SizeOf(Bmp), @Bmp);

  FillChar(DDSD, SizeOf(DDSD), #0);
  DDSD.dwSize := SizeOf(DDSD);
  DDSD.dwFlags := DDSD_CAPS or DDSD_WIDTH or DDSD_HEIGHT;
  DDSD.ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
  DDSD.dwWidth := Bmp.bmWidth;
  DDSD.dwHeight := Bmp.bmHeight;

  if FDirectDraw.CreateSurface(DDSD, Result, nil) <> DD_OK then Exit;

  if Result.GetDC(DC) <> DD_OK then Exit;

  MemDC := CreateCompatibleDC(DC);
  if MemDC = 0 then Exit;

  SelectObject(MemDC, hBmp);

  BitBlt(DC, 0, 0, Bmp.bmWidth, Bmp.bmHeight, MemDC, 0, 0, SRCCOPY);

  DeleteObject(hBmp);

  Result.ReleaseDC(DC);

  DeleteDC(MemDC);
end;

end.