delphi 控制台贪吃蛇

最新推荐文章于 2020-11-29 03:52:34 发布

weixin_30916125

最新推荐文章于 2020-11-29 03:52:34 发布

阅读量118

点赞数

原文链接：http://www.cnblogs.com/qkhhxkj/archive/2013/01/05/2846380.html

版权

游戏的界面

主要的功能实现

1 键盘消息

program Project1;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  windows,
  uConsoleClass in 'uConsoleClass.pas',
  uSnake in 'uSnake.pas';

// 参考
/// http://blog.csdn.net/haiou327/article/details/5695237
var
  MyMsg   : TMsg;
begin
  while windows.GetMessage(MyMsg, 0, 0, 0) do
  begin
    DispatchMessage(MyMsg);
  end;
end.

2 定时器

这里用的是API

procedure TimerProc(window : Hwnd ; message,idEvent :UInt; dwTime: dword);stdcall;
begin
  if Snake.StartSnake then
    Snake.MoveSnake();
end;


FTimer := SetTimer(0, 0, TIMERINTERVAL, @TimerProc);

3 蛇控制单元

unit uSnake;

interface

uses
  Windows, classes, uConsoleClass, ExtCtrls;

const
  GAMEROW = 16;
  GAMECOL = 54;

  TIMERINTERVAL = 300;
type

  TMoveDir   = (MD_Right, MD_Left, MD_Up, MD_Down);
  TPointType = (PT_Head, PT_Body, PT_Tail, PT_Food);


  TGamePoint = record
    Row        : byte;
    Col        : byte;
    PointType  : TPointType;
  end;
  PGamePoint = ^TGamePoint;


  TReadKeyThread = Class(TThread)
  private
    FMoveDir        : TMoveDir;
    FStartRead      : boolean;
    FPause          : boolean;

    procedure SetStartRead(const Value: boolean);
  public

    property Pause            : boolean read FPause write FPause;
    property StartRead        : boolean read FStartRead write SetStartRead;
    property MoveDir          : TMoveDir read FMoveDir write FMoveDir;
  protected
    procedure Execute; override;
  end;

  TSnake = class
  private
    //FGameMap        : array[0..GAMEROW - 1, 0..GAMECOL - 1] of byte;
    FFoodPoint      : PGamePoint;

    FSnakePointList : TList;
    FLastPoint      : PGamePoint;
    FMyConsole      : TConsoleControl;

    FStartSnake     : boolean;
    FReadKeyThread  : TReadKeyThread;

    FEatFoodCount   : integer;
//    FScores         : integer;

    procedure InitGameMap();
    procedure FreeSnakeList();
    function CheckInSnake(Row, Col: integer): boolean;

    procedure PrintSnake();



    function GetSnakeBodyType(bodyType: TPointType): PGamePoint;
    procedure GetFood();

    procedure ShowScores(add: boolean = false);

    procedure Start();
    function CheckGameOver(): boolean;
    procedure GameOver();
    function EatFood(): boolean;

    function GetMoveDir(): TMoveDir;

    property Dir: TMoveDir read GetMoveDir;
    property StartSnake: boolean read FStartSnake write FStartSnake;

  public
    constructor Create();
    destructor Destroy;override;

    procedure StartGame();
    procedure MoveSnake();
    function ThreadPause(): boolean;
  end;


implementation

uses SysUtils;

var
  Snake   : TSnake;
  FTimer  : Integer;

procedure TimerProc(window : Hwnd ; message,idEvent :UInt; dwTime: dword);stdcall;
begin
  if Snake.StartSnake then
    Snake.MoveSnake();
end;

{ TSnake }

function TSnake.CheckGameOver: boolean;
var
  Head: PGamePoint;
  I: integer;
  P: PGamePoint;
begin
  Result  := false;
  Head    := GetSnakeBodyType(PT_Head);
//  FMyConsole.SetCursorTo(0, 16);
//  FMyConsole.WriteText('Row: ' + inttostr(Head^.Row) + ' Col: ' + inttostr(Head^.Col));

  if Dir = MD_Up then
  begin
    if Head^.Row = 1 then
      Result := true;
  end;

  // 判断撞到上下的墙
  if (Head^.Row < 1) or (Head^.Row > GAMEROW - 3) then
    Result := true;

  // 判断撞到左右的墙
  if (Head^.Col < 3) or (Head^.Col > GAMECOL - 6) then
    Result := true;

  // 判断是否撞到自己

  for I := 2 to FSnakePointList.Count - 1 do
  begin
    P := FSnakePointList.Items[I];
    case Dir of
    MD_Right:
      begin
        if (Head^.Col + 1 = P^.Col) and (Head^.Row = P^.Row) then
          Result := true;
      end;
    MD_Left:
      begin
        if (Head^.Col - 1 = P^.Col) and (Head^.Row = P^.Row) then
          Result := true;
      end;
    MD_Up:
      begin
        if (Head^.Row - 1 = P^.Row) and (Head^.Col = P^.Col) then
          Result := true;
      end;
    MD_Down:
      begin
        if (Head^.Row + 1 = P^.Row) and (Head^.Col = P^.Col) then
          Result := true;
      end;
    end;
  end;
end;

function TSnake.CheckInSnake(Row, Col: integer): boolean;
var
  P: PGamePoint;
  I: integer;
begin
  Result := false;
  for I := 0 to FSnakePointList.Count - 1 do
  begin
    P := FSnakePointList.Items[I];
    if (P^.Row = Row) and (P^.Col= Col) then
    begin
      Result := true;
      break;
    end;
  end;
end;

constructor TSnake.Create();
begin
  FReadKeyThread  := TReadKeyThread.Create(true);
  FSnakePointList := TList.Create();
  New(FFoodPoint);
  New(FLastPoint);
  FMyConsole:= TConsoleControl.Create;
  FMyConsole.SetWindowTitle('【贪吃蛇】 V1.0');
  InitGameMap();
end;

destructor TSnake.Destroy;
begin
  Dispose(FFoodPoint);
  Dispose(FLastPoint);
  FreeAndNil(FSnakePointList);
  FMyConsole.Free;
  FReadKeyThread.Free();
  inherited;
end;

function TSnake.EatFood: boolean;
var
  Head : PGamePoint;
begin
  Result := false;
  Head := GetSnakeBodyType(PT_Head);
  if (Head^.Row = FFoodPoint^.Row) and (Head^.Col = FFoodPoint^.Col) then
  begin
    ShowScores(true);
    Result := true;
  end;
  ShowScores();
end;

procedure TSnake.FreeSnakeList;
var
  P: PGamePoint;
  Index: integer;
begin
  if FSnakePointList.Count > 0 then
  begin
    repeat
      Index := FSnakePointList.Count - 1;
      P     := FSnakePointList.Items[Index];
      FSnakePointList.Delete(Index);
      Dispose(P);
    until FSnakePointList.Count = 0;
  end;
end;

procedure TSnake.GameOver;
var
  S: string;
begin
  StartSnake               := false;
  FReadKeyThread.StartRead := false;
//
  FMyConsole.SetCursorTo(0, 16);
  FMyConsole.WriteText('                                                      ');
  FMyConsole.SetCursorTo(0, 16);
  FMyConsole.WriteText('游戏结束重新开始吗? (y/n):');
  Readln(S);
  if LowerCase(S) = 'y' then
  begin
    //FMyConsole.SetCursorTo(0, 16);
    //FMyConsole.WriteText('游戏开始                      ');
    InitGameMap();
    Start();
  end;
end;

procedure TSnake.GetFood;
begin
  Randomize;
  repeat
    FFoodPoint^.Row := Random(GAMEROW - 7) + 5;
    FFoodPoint^.Col := Random(GAMECOL - 10) + 5;
  until not CheckInSnake(FFoodPoint^.Row, FFoodPoint^.Col);
  FMyConsole.SetForegroundColor(true, false, true, false);
  FMyConsole.SetCursorTo(FFoodPoint^.Col, FFoodPoint^.Row);
  FMyConsole.WriteText('O');
end;

function TSnake.GetMoveDir: TMoveDir;
begin
  Result := FReadKeyThread.MoveDir;
end;

function TSnake.GetSnakeBodyType(bodyType: TPointType): PGamePoint;
var
  I: integer;
begin
  Result := nil;
  for I := 0 to FSnakePointList.Count - 1 do
  begin
    Result := FSnakePointList.Items[I];
    if Result.PointType = bodyType then break;
  end;
end;

procedure TSnake.InitGameMap;
var
//  I, J: integer;
  P: PGamePoint;
begin
  FMyConsole.ClearScreen;
//  for I := 0 to GAMEROW - 1 do
//  begin
//    for J := 0 to GAMECOL - 1 do
//    begin
//      if (I = 0) or (I = GAMEROW - 1) then
//        FGameMap[I][J] := 1
//      else
//        FGameMap[I][J] := 0;
//
//      if (J = 0) or (J = 1) or (J = GAMECOL - 1 ) or (J = GAMECOL - 2 ) then
//        FGameMap[I][J] := 1
//      else
//        FGameMap[I][J] := 0;
//    end;
//  end;

  FreeSnakeList();

  // 头 先添加
  New(P);
  P^.Row := 2;
  P^.Col := 7;
  P^.PointType := PT_Head;
  FSnakePointList.Add(P);

  // 身体
  New(P);
  P^.Row := 2;
  P^.Col := 6;
  P^.PointType := PT_Body;
  FSnakePointList.Add(P);
  New(P);
  P^.Row := 2;
  P^.Col := 5;
  P^.PointType := PT_Body;
  FSnakePointList.Add(P);
  New(P);
  P^.Row := 2;
  P^.Col := 4;
  P^.PointType := PT_Body;
  FSnakePointList.Add(P);
  New(P);
  P^.Row := 2;
  P^.Col := 3;
  P^.PointType := PT_Tail;
  FSnakePointList.Add(P);

//  // 蛇的初始位置
//  for J := 1 to 5 do
//    FGameMap[1][J] := 1;

  // 食物初始位置
//  FFoodPoint^.Row := 10;
//  FFoodPoint^.Col := 30;
//  FFoodPoint^.PointType := PT_Food;

//  FGameMap[10][30] := 1; 
  FMyConsole.SetCursorTo(0, 0);
  FMyConsole.SetForegroundColor(true, false, false, false);
  FMyConsole.WriteTextLine('┏━━━━━━━━━━━━━━━━━━━━━━━━┓');
  FMyConsole.WriteTextLine('┃                                                ┃');
  FMyConsole.WriteTextLine('┃                                                ┃');
  FMyConsole.WriteTextLine('┃                                                ┃');
  FMyConsole.WriteTextLine('┃                                                ┃');
  FMyConsole.WriteTextLine('┃                                                ┃');
  FMyConsole.WriteTextLine('┃                                                ┃');
  FMyConsole.WriteTextLine('┃                                                ┃');
  FMyConsole.WriteTextLine('┃                                                ┃');
  FMyConsole.WriteTextLine('┃                                                ┃');
  FMyConsole.WriteTextLine('┃                                                ┃');
  FMyConsole.WriteTextLine('┃                                                ┃');
  FMyConsole.WriteTextLine('┃                                                ┃');
  FMyConsole.WriteTextLine('┃                                                ┃');
  FMyConsole.WriteTextLine('┃                                                ┃');
  FMyConsole.WriteTextLine('┗━━━━━━━━━━━━━━━━━━━━━━━━┛');

  GetFood();
end;

procedure TSnake.MoveSnake;
var
  Head  : PGamePoint;
  Tail  : PGamePoint;
  P1, P2: PGamePoint;
  I     : integer;
  NewBody: PGamePoint;
  eat: boolean;
begin

  if ThreadPause then
  begin
    FMyConsole.SetCursorTo(0, 16);
    FMyConsole.WriteText('游戏已暂停请按空格键继续...                    ');
  end
  else
  begin
    if CheckGameOver() then
    begin
      GameOver();
    end
    else
    begin
      eat := EatFood();

      //保存最后一个要擦除的点
      Tail := GetSnakeBodyType(PT_Tail);
      FLastPoint^.Row := Tail^.Row;
      FLastPoint^.Col := Tail^.Col;

      if eat then
      begin
        New(NewBody);
        NewBody^.Row := Tail^.Row;
        NewBody^.Col := Tail^.Col;
        NewBody^.PointType := PT_Tail;
        FSnakePointList.add(NewBody);

        Tail^.PointType := PT_Body;

        GetFood();
      end;

      // 移动蛇的位置
      for I := FSnakePointList.Count - 1 downto 1 do
      begin
        P1 := FSnakePointList.Items[I];
        P2 := FSnakePointList.Items[I - 1];

        P1^.Row := P2^.Row;
        P1^.Col := P2^.Col;
      end;

      Head := GetSnakeBodyType(PT_Head);
      case Dir of
        MD_Right: Inc(Head^.Col);
        MD_Left : Dec(Head^.Col);
        MD_Up   : Dec(Head^.Row);
        MD_Down : Inc(Head^.Row);
      end;

      PrintSnake();

        // 清空蛇尾
      if FStartSnake and not eat then
      begin
        FMyConsole.SetCursorTo(FLastPoint^.Col, FLastPoint^.Row);
        FMyConsole.WriteText(' ');
      end;
    end;
  end;

end;

procedure TSnake.PrintSnake;
var
  P: PGamePoint;
  I: integer;
begin
  FMyConsole.SetForegroundColor(false, true, false, false);
  for I := 0 to FSnakePointList.Count - 1 do
  begin
    P := FSnakePointList.Items[I];
    FMyConsole.SetCursorTo(P^.Col, P^.Row);
    case P^.PointType of
      PT_Head: FMyConsole.WriteText('#');
      PT_Body: FMyConsole.WriteText('*');
      PT_Tail: FMyConsole.WriteText('*');
    end;
  end;

//  FMyConsole.WriteTextLine('┏━━━━━━━━━━━━━━━━━━━━━━━━┓');
//  FMyConsole.WriteTextLine('┃****#                                           ┃');
//  FMyConsole.WriteTextLine('┃                                                ┃');
//  FMyConsole.WriteTextLine('┃                                                ┃');
//  FMyConsole.WriteTextLine('┃                                                ┃');
//  FMyConsole.WriteTextLine('┃                                                ┃');
//  FMyConsole.WriteTextLine('┃                                                ┃');
//  FMyConsole.WriteTextLine('┃                                                ┃');
//  FMyConsole.WriteTextLine('┃                                                ┃');
//  FMyConsole.WriteTextLine('┃                                                ┃');
//  FMyConsole.WriteTextLine('┃                                         O      ┃');
//  FMyConsole.WriteTextLine('┃                                                ┃');
//  FMyConsole.WriteTextLine('┃                                                ┃');
//  FMyConsole.WriteTextLine('┃                                                ┃');
//  FMyConsole.WriteTextLine('┃                                                ┃');
//  FMyConsole.WriteTextLine('┗━━━━━━━━━━━━━━━━━━━━━━━━┛');
  // 14 行 48 列
end;

procedure TSnake.ShowScores(add: boolean = false);
var
  S: string;
begin
//    FEatFoodCount   : integer;
//    FScores         : integer;
  if add then
  begin
    Inc(FEatFoodCount);
  end;
  S := Format('完成食物个数: %d     得分数: %d    ', [FEatFoodCount, 10 * FEatFoodCount]);
  FMyConsole.SetCursorTo(0, 16);
  FMyConsole.WriteText(S);
end;

procedure TSnake.Start;
begin
  FEatFoodCount   := 0;
  //FScores         := 0;
  StartSnake := true;
  FReadKeyThread.StartRead := true;
end;

procedure TSnake.StartGame;
var
  S: string;
begin
  PrintSnake();

  FMyConsole.SetCursorTo(0, 16);
  FMyConsole.WriteText('现在开始游戏吗? (y/n):');
  Readln(S);
  if LowerCase(S) = 'y' then
  begin
//    FMyConsole.SetCursorTo(0, 16);
//    FMyConsole.WriteText('开始游戏                          ');
    Start();
  end;
end;

function TSnake.ThreadPause: boolean;
begin
  Result := FReadKeyThread.Pause;
end;

{ TReadKeyThread }

procedure TReadKeyThread.Execute;
var
  arrInputRecs   : array[0..9] of TInputRecord;
  dwCur, dwCount : DWORD;
  hInput         : THandle;
begin
  hInput   := GetStdHandle(STD_INPUT_HANDLE);
  while TRUE do
  begin
    ReadConsoleInput(hInput, arrInputRecs[0], 10, dwCount);

    for dwCur := 0 to 10 - 1 do
    begin
      if self.Terminated then break;
      case arrInputRecs[dwCur].EventType of
        KEY_EVENT:
          begin
            with arrInputRecs[dwCur].Event.KeyEvent do
            begin
              if bKeyDown = true then
              begin
                case wVirtualKeyCode of
                  VK_Space:
                    begin
                      Pause := not Pause;
                    end;
                  VK_Left:
                    begin
                      if (MoveDir <> MD_Left) and (MoveDir <> MD_Right) then
                      begin
                        if not FPause then
                          MoveDir := MD_Left;
                      end;
                    end;
                  VK_Right:
                    begin
                      if (MoveDir <> MD_Right) and (MoveDir <> MD_Left) then
                      begin
                        if not  FPause then
                          MoveDir := MD_Right;
                      end;
                    end;
                  VK_Up:
                    begin
                      if (MoveDir <> MD_Up) and (MoveDir <> MD_Down) then
                      begin
                        if not  FPause then
                          MoveDir := MD_Up;
                      end;
                    end;
                  VK_Down:
                    begin
                      if (MoveDir <> MD_Up) and (MoveDir <> MD_Down) then
                      begin
                        if not  FPause then
                          MoveDir := MD_Down;
                      end;
                    end;
                end;
              end;
            end;
          end;
      end;
    end;
  end;
end;

procedure TReadKeyThread.SetStartRead(const Value: boolean);
begin
  FStartRead := Value;
  if FStartRead then
  begin
    MoveDir := MD_Right;
    FPause  := false;
    Resume;
  end
  else
    Suspend;
end;

initialization
  Snake := TSnake.Create;
  Snake.StartGame();
  FTimer := SetTimer(0, 0, TIMERINTERVAL, @TimerProc);
  
finalization
  KillTimer(0, FTimer);
  Snake.Free();

end.

4 控制台单元这个单元是网上的

unit uConsoleClass;

interface

uses Windows;

type
  TConsoleControl = Class
  private
    FhStdIn            : THandle;  // Handle to the standard input
    FhStdOut           : THandle;  // Handle to the standard output
    FhStdErr           : THandle;  // Handle to the standard error (Output)
    FbConsoleAllocated : Boolean;  // Creation Flag
    FBgAttrib          : Cardinal; // Currently set BackGround Attribs.
    FFgAttrib          : Cardinal; // Currently set ForeGround Attribs.

  public
    (* Creates a new consolewindow, or connects the current window *)
    constructor Create;
    destructor Destroy;override;

    (* Cleanup of the class structures *)
    (* Color properties:
       The console window does not handle the colors like known form delphi
       components. Each color will be created from a red,green,blue and a
       intensity part. In fact the resulting colors are the same as the well
       known 16 base colors (clwhite .. clBlack).
       Black ist if all flags are false, white if all flag are true.
       The following two functions will change the color for followingwrites *)
    procedure SetForegroundColor(bRed,bGreen,bBlue,bIntensity : Boolean);
    procedure SetBackgroundColor(bRed,bGreen,bBlue,bIntensity : Boolean);

    (* Writing functions : simple wrapper around WriteConsole*)
    procedure WriteText (const s : string);
    procedure WriteTextLine( const s : string);

    (* Change the Windowtitle of the command window. If the program has been
       executed from a CMD-box the title change is only active while the
       programs execution time *)
    procedure SetWindowTitle (const sTitle : string);

    (* some Cursor manipulation functions *)
    procedure ShowCursor (iSize : Integer);
    procedure HideCursor;
    procedure GetCursorPos(var x, y : integer);
    procedure SetCursorTo(x, y : integer);

    (* screen operations:
       the screen ist the visible part of a cmd window. Behind the windowthere
       is a screenbuffer. The screenbuffer may be larger than the visible window *)
    procedure ClearScreen;
    function GetScreenLeft   : integer;
    function GetScreenTop    : Integer;
    function GetScreenHeight : integer;
    function GetScreenWidth  : integer;

    (* screenbuffer operations *)
    procedure ClearBuffer;
    function GetBufferHeight : integer;
    function GetBufferWidth  : integer;

    (* sample to read characters from then screenbuffer *)
    procedure GetCharAtPos(x, y : Integer; var rCharInfo : Char);
  end;

implementation
{ TConsoleControl }

procedure TConsoleControl.ClearBuffer;
var
  SBInfo         : TConsoleScreenBufferInfo;
  ulWrittenChars : Cardinal;
  TopLeft        : TCoord;
begin
  TopLeft.X := 0;
  TopLeft.Y := 0;
  GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
  FillConsoleOutputCharacter(FhStdOut,' ', SBInfo.dwSize.X * SBInfo.dwSize.Y, TopLeft, ulWrittenChars);
  FillConsoleOutputAttribute(FhStdOut, FOREGROUND_RED or FOREGROUND_BLUE or FOREGROUND_GREEN,
                              (SBInfo.srWindow.Right - SBInfo.srWindow.Left) *
                              (SBInfo.srWindow.Bottom - SBInfo.srWindow.Top),
                              TopLeft, ulWrittenChars);
end;

procedure TConsoleControl.ClearScreen;
var
  SBInfo         : TConsoleScreenBufferInfo;
  ulWrittenChars : Cardinal;
  TopLeft        : TCoord;
begin
  GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
  TopLeft.X := SBInfo.srWindow.Left;
  TopLeft.Y := SBInfo.srWindow.Top;

  FillConsoleOutputCharacter(FhStdOut,' ',
                             (SBInfo.srWindow.Right - SBInfo.srWindow.Left)*
                             (SBInfo.srWindow.Bottom - SBInfo.srWindow.Top),
                             TopLeft,
                             ulWrittenChars);
  FillConsoleOutputAttribute(FhStdOut,FOREGROUND_RED or FOREGROUND_BLUE or FOREGROUND_GREEN,
                             (SBInfo.srWindow.Right - SBInfo.srWindow.Left)*
                             (SBInfo.srWindow.Bottom - SBInfo.srWindow.Top),
                             TopLeft,
                             ulWrittenChars);
end;

constructor TConsoleControl.Create;
begin
  inherited Create;
// A process can be associated with only one console, so the AllocConsole
// function fails if the calling process already has a console.
  FbConsoleAllocated := AllocConsole;
// initializing the needed handles
  FhStdOut := GetStdHandle(STD_OUTPUT_HANDLE);
  FhStdErr := GetStdHandle(STD_ERROR_HANDLE);
  FhStdIn  := GetStdHandle(STD_INPUT_HANDLE);
end;

destructor TConsoleControl.Destroy;
begin
  if FbConsoleAllocated then FreeConsole;
  inherited;
end;

function TConsoleControl.GetBufferHeight: integer;
var
  SBInfo : TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
  Result := SBInfo.dwSize.Y;
end;

function TConsoleControl.GetBufferWidth: integer;
var
  SBInfo : TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
  Result := SBInfo.dwSize.X;
end;

procedure TConsoleControl.GetCharAtPos(x, y: Integer; var rCharInfo : Char);
var
  CharInfo : array [0..10] of Char;
  TopLeft  : TCoord;
  CharsRead : Cardinal;
begin
  TopLeft.x := X;
  TopLeft.Y := Y;
  ReadConsoleOutputCharacter(FhStdOut,CharInfo,10,TopLeft,CharsRead);
  rCharInfo   := CharInfo[0];
end;

procedure TConsoleControl.GetCursorPos(var x, y: integer);
var
  SBInfo : TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
  x := SBInfo.dwCursorPosition.X;
  y := SBInfo.dwCursorPosition.Y;
end;

function TConsoleControl.GetScreenHeight: integer;
var
  SBInfo : TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
  Result := SBInfo.srWindow.Bottom -SBInfo.srWindow.Top;
end;

function TConsoleControl.GetScreenLeft: integer;
var
  SBInfo : TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
  Result := SBInfo.srWindow.Left;
end;

function TConsoleControl.GetScreenTop: Integer;
var
  SBInfo : TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
  Result := SBInfo.srWindow.Top;
end;

function TConsoleControl.GetScreenWidth: integer;
var
  SBInfo : TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
  Result := SBInfo.srWindow.Right - SBInfo.srWindow.Left;
end;

procedure TConsoleControl.HideCursor;
var
  ConsoleCursorInfo : TConsoleCursorInfo;
begin
  GetConsoleCursorInfo(FhStdOut,ConsoleCursorInfo);
  if ConsoleCursorInfo.bVisible then begin
    ConsoleCursorInfo.bVisible := False;
    SetConsoleCursorInfo(FhStdOut,ConsoleCursorInfo);
  end;
end;

procedure TConsoleControl.SetBackgroundColor(bRed, bGreen, bBlue,
  bIntensity: Boolean);
begin
  FBgAttrib := 0;
  if bRed       then FBgAttrib := FBgAttrib or BACKGROUND_RED;
  if bGreen     then FBgAttrib := FBgAttrib or BACKGROUND_GREEN;
  if bBlue      then FBgAttrib := FBgAttrib or BACKGROUND_BLUE;
  if bIntensity then FBgAttrib := FBgAttrib or BACKGROUND_INTENSITY;
  SetConsoleTextAttribute(FhStdOut, FBgAttrib or FFgAttrib);
end;

procedure TConsoleControl.SetCursorTo(x, y: integer);
var
  Coords : TCoord;
  SBInfo : TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
  if x < 0 then Exit;
  if y < 0 then Exit;
  if x > SbInfo.dwSize.X then Exit;
  if y > SbInfo.dwSize.Y then Exit;
  Coords.X := x;
  Coords.Y := y;
  SetConsoleCursorPosition(FhStdOut,Coords);
end;

procedure TConsoleControl.SetForegroundColor(bRed, bGreen, bBlue,
  bIntensity: Boolean);
begin
  FFgAttrib := 0;
  if bRed       then FFgAttrib := FFgAttrib or FOREGROUND_RED;
  if bGreen     then FFgAttrib := FFgAttrib or FOREGROUND_GREEN;
  if bBlue      then FFgAttrib := FFgAttrib or FOREGROUND_BLUE;
  if bIntensity then FFgAttrib := FFgAttrib or FOREGROUND_INTENSITY;
  SetConsoleTextAttribute(FhStdOut,FBgAttrib or FFgAttrib);
end;

procedure TConsoleControl.SetWindowTitle(const sTitle: string);
begin
  SetConsoleTitle(PChar(sTitle));
end;

procedure TConsoleControl.ShowCursor(iSize: Integer);
var
  ConsoleCursorInfo : TConsoleCursorInfo;
begin
  GetConsoleCursorInfo(FhStdOut,ConsoleCursorInfo);
  if (not ConsoleCursorInfo.bVisible) or (ConsoleCursorInfo.dwSize <> iSize) then
  begin
    ConsoleCursorInfo.bVisible := True;
    ConsoleCursorInfo.dwSize   := iSize;
    SetConsoleCursorInfo(FhStdOut,ConsoleCursorInfo);
  end;
end;

procedure TConsoleControl.WriteText(const s: string);
var
  ulLength : Cardinal;
begin
  WriteConsole(FhStdOut, PChar(s), Length(s), ulLength, NIL);
end;

procedure TConsoleControl.WriteTextLine(const s: string);
begin
  WriteText(s +#13#10);
end;

end.

转载于:https://www.cnblogs.com/qkhhxkj/archive/2013/01/05/2846380.html

weixin_30916125

关注

0
点赞
踩
0

收藏

觉得还不错? 一键收藏
0
评论
delphi 控制台贪吃蛇

游戏的界面主要的功能实现1 键盘消息program Project1;{$APPTYPE CONSOLE}uses SysUtils, windows, uConsoleClass in 'uConsoleClass.pas', uSnake in 'uSnake.pas';// 参考/// http://blog.cs...
复制链接

扫一扫