QQ連連看 for Delphi 源碼

kbhook.DLL

library kbhook;

{ Important note about DLL memory management: ShareMem must be the
first unit in your library's USES clause AND your project's (select
Project-View Source) USES clause if your DLL exports any procedures or
functions that pass strings as parameters or function results. This
applies to all strings passed to and from your DLL--even those that
are nested in records and classes. ShareMem is the interface unit to
the BORLNDMM.DLL shared memory manager, which must be deployed along
with your DLL. To avoid using BORLNDMM.DLL, pass string information
using PChar or ShortString parameters. }

uses
  windows;
var
  hHk: HHOOK;
  BFirst:Boolean=True;
  //{$R *.res}
procedure ModMemData();
var
  pData: pointer;
  dwOldProtect: DWORD;
  mbi_thunk: TMemoryBasicInformation;
begin
  pData := pointer($00403296);
  //查詢頁信息。
  VirtualQuery(pData, mbi_thunk, sizeof(MEMORY_BASIC_INFORMATION));
  //改變頁保護屬性爲讀寫。
  VirtualProtect(mbi_thunk.BaseAddress, mbi_thunk.RegionSize,
    PAGE_READWRITE, mbi_thunk.Protect);
  //清零。
  PByte(pData)^ := 0;
  //恢復頁的原保護屬性。
  VirtualProtect(mbi_thunk.BaseAddress, mbi_thunk.RegionSize,
    mbi_thunk.Protect, dwOldProtect);
end;

function keyHookProc(nCode: Integer; WParam: WPARAM; LParam: LPARAM): LRESULT;
  stdcall;
const
  _KeyPressMask = $80000000;
begin
  Result := 0;
  if nCode < 0 then
  begin
    Result := CallNextHookEx(hhk, nCode, wParam, lParam);

    Exit;
  end
  else
  begin
    if BFirst then
    // 偵測 Ctrl + B 組合鍵
    //if ((lParam and _KeyPressMask) = 0) and (GetKeyState(vk_Control) < 0) and
     // (wParam = VK_F2) then
      //(GetKeyState(vk_Control) < 0) and (wParam = Ord('B')) then
    begin
      Result := 1;
      ModMemData;
      BFirst:=False;

      //MessageBox(0, 'ok','',MB_OK);
     // MessageBox(0, pchar(GetModuleName(GetModuleHandle(nil))),
      // pchar(inttostr(GetCurrentThread)), 0);
    end;
  end;

end;

function SetKbHook(threadid: DWORD): boolean; stdcall; export; //外部調用
begin
  if threadid <> 0 then
  begin
    hHk := SetWindowsHookEx(WH_GETMESSAGE, @keyHookProc, HInstance, threadid);
    result := hhk <> 0;
  end
  else
  begin
    Result := UnHookWindowsHookEx(hHk);
  end;
  BFirst:=True;
end;

exports
  SetKbHook;
end.

 

LineGame.pas

...{*******************************************************************************
  Copyright (C), 2004, 風月工作室.
  作者: 追風逐月
  版本: 1.0
  日期: 2005年12月28日
  描述: QQ連連看遊戲控制類
  修改歷史:
    徐明     2005/12/28      1.0        創建該文件
    ...
********************************************************************************}

unit LineGame;

interface
uses
  Windows,
  Messages,
  ShellAPI,
  Classes;
const
  MAP_HLENGTH = 19;
  MAP_VLENGTH = 11;
  MAPCOUNT = 100;
  gLeft = 16;
  gTop = 184;
  hwidth = 31;
  vWidth = 35;
type
  TLineGame = class
  private
    Maps: array[0..MAP_VLENGTH - 1, 0..MAP_HLENGTH - 1] of integer;
    gh: THandle;
    RectA: TRect;
    LineMap: TStringList;
    ptLines: array[1..MAPCOUNT] of Tlist;
    FGameThreadID:integer;
    procedure SetPtLines;
    function CanConnect(P1, P2: TPoint): boolean;
    function CanLine(P1, P2: TPoint): Boolean;
    function isEmptyPt(pt: TPoint): boolean;
    function GetMapIndex(Color: integer): integer;
    function LeftMapCount: integer;
    procedure GetColor(x, y: Integer; var col: Cardinal);
    function GetColorMx(i, j: integer): Cardinal;
    function isBackGround(Color: Integer): boolean;
    procedure SendMouse(x1, y1, x2, y2: Integer);
    function GetMapPos(i, j: integer): Tpoint;
    function Search(var P1, P2: TPoint): boolean;
    function isSameMap(Color1, Color2: integer): boolean;
    procedure GetBox;
    procedure SetMemData(hnd:THandle);
  public
    constructor Create;
    destructor Destroy; override;
    procedure AutoStart;
    procedure RunStep;
    procedure KillAll;

  end;
function SetKbHook(threadid:DWORD):bool;stdcall; external 'kbhook.dll' ;
implementation

function StrToInt(const S: string): Integer;
var
  E: Integer;
begin
  Val(S, Result, E);
  //if E <> 0 then ConvertErrorFmt(@SInvalidInteger, [S]);
end;


...{ TLineGame }
...{*************************************************
  函數名: TLineGame.GetColor
  描  述: 獲取指定位置（屏幕座標）的顏色值
  參  數: x, y: Integer; var col: Cardinal
  返回值: None
 *************************************************}
procedure TLineGame.GetColor(x, y: Integer; var col: Cardinal);
var
  WindowDC: THandle;
begin
  WindowDC := GetWindowDC(gh);
  col := GetPixel(WindowDC, x, y);
  ReleaseDC(gh, WindowDC);
end;

...{*************************************************
  函數名: TLineGame.GetColorMx
  描  述: 獲取指定位置（對子矩陣座標）的評估值
  參  數: i, j: integer
  返回值: Cardinal  - 評估值
 *************************************************}
function TLineGame.GetColorMx(i, j: integer): Cardinal;
var
  x, y: integer;
  col1, col2: Cardinal;
begin
  x := gLeft + 14 + hwidth * i;
  y := gTop + 18 + vwidth * j;
  GetColor(x, y, col1);
  x := x - 6;
  GetColor(x, y, col2);
  result := col1 + col2;
end;

...{*************************************************
  函數名: TLineGame.Search
  描  述: 搜索可以消除的對子的位置
  參  數: var P1, P2: TPoint  可以消除的對子座標
  返回值: boolean
 *************************************************}
function TLineGame.Search(var P1, P2: TPoint): boolean;
var
  i, j, k: integer;
  LineList: TList;
begin
  result := false;
  for i := Low(ptlines) to High(ptlines) do
  begin
    LineList := ptLines[i];
    for j := 0 to LineList.Count - 1 do
      for k := j + 1 to LineList.Count - 1 do
      begin
        p1 := pPoint(LineList.Items[j])^;
        p2 := pPoint(LineList.Items[k])^;
        if CanConnect(p1, p2) then
        begin
          result := true;
          Dispose(LineList.Items[k]);
          LineList.Delete(k);
          Maps[p1.X, p1.Y] := -2;
          Dispose(LineList.Items[j]);
          LineList.Delete(j);
          Maps[p2.X, p2.Y] := -2;

          exit;
        end;
      end;
  end;

end;
...{*************************************************
  函數名: TLineGame.CanConnect
  描  述: 判斷兩點是否連通
  參  數: P1, P2: TPoint
  返回值: boolean
 *************************************************}
function TLineGame.CanConnect(P1, P2: TPoint): boolean;
var
  mpt1, mpt2: TPoint;
begin
  result := false;
  if (p1.x = p2.X) and (p1.y = p2.Y) then
    exit;

  //可以直線相連
  Result := Canline(P1, p2);
  if result then
    exit;

  //一個拐點
  mpt1.X := p1.X;
  mpt1.Y := p2.Y;
  Result := (isEmptyPt(mpt1)) and Canline(P1, mpt1) and Canline(mpt1, P2);
  if result then
    exit;

  mpt1.X := p2.X;
  mpt1.Y := p1.Y;
  Result := (isEmptyPt(mpt1)) and Canline(P1, mpt1) and Canline(mpt1, P2);
  if result then
    exit;

  //兩個拐點
  //以p1爲基準
  //獲取y座標方向的空點
  mpt1.y := p1.Y;
  mpt2.Y := p2.Y;

  mpt1.X := p1.X - 1;
  while (mpt1.x > -1) and (isEmptyPt(mpt1)) do
  begin
    mpt2.X := mpt1.X;
    if isEmptyPt(mpt2) then
      result := CanLine(mpt1, mpt2) and CanLine(mpt2, p2);
    if result then
      exit;
    dec(mpt1.X);
  end;

  mpt1.X := p1.X + 1;
  while (mpt1.x < MAP_VLENGTH) and (isEmptyPt(mpt1)) do
  begin
    mpt2.X := mpt1.X;
    if isEmptyPt(mpt2) then
      result := CanLine(mpt1, mpt2) and CanLine(mpt2, p2);
    if result then
      exit;
    inc(mpt1.X);
  end;

  //獲取x座標方向的空點
  mpt1.x := p1.x;
  mpt2.x := p2.x;

  mpt1.y := p1.y - 1;
  while (mpt1.y > -1) and (isEmptyPt(mpt1)) do
  begin
    mpt2.y := mpt1.y;
    if isEmptyPt(mpt2) then
      result := CanLine(mpt1, mpt2) and CanLine(mpt2, p2);
    if result then
      exit;
    dec(mpt1.y);
  end;

  mpt1.y := p1.y + 1;
  while (mpt1.y < MAP_HLENGTH) and (isEmptyPt(mpt1)) do
  begin
    mpt2.y := mpt1.y;
    if isEmptyPt(mpt2) then
      result := CanLine(mpt1, mpt2) and CanLine(mpt2, p2);
    if result then
      exit;
    inc(mpt1.y);
  end;

end;
...{*************************************************
  函數名: TLineGame.CanLine
  描  述: 判斷兩點是否可以直線相連
  參  數: P1, P2: TPoint
  返回值: Boolean
 *************************************************}
function TLineGame.CanLine(P1, P2: TPoint): Boolean;
var
  i: integer;
begin
  result := false;

  // 橫1....1
  if (p1.y = p2.Y) then
  begin
    if p1.x > p2.X then
    begin
      result := CanLine(P2, P1);
    end
    else
    begin
      result := true;
      for i := p1.X + 1 to p2.X - 1 do
      begin
        result := Maps[i, p1.Y] = -2;
        if not result then
          exit;
      end;
    end;
  end
  else if (p1.x = p2.x) then // 豎
  begin
    if p1.y > p2.y then
    begin
      result := CanLine(P2, P1);
    end
    else
    begin
      result := true;
      for i := p1.y + 1 to p2.y - 1 do
      begin
        result := Maps[p1.x, i] = -2;
        if not result then
          exit;
      end;
    end;
  end;

end;

...{*************************************************
  函數名: TLineGame.isEmptyPt
  描  述: 是否空白點
  參  數: pt: TPoint
  返回值: boolean
 *************************************************}
function TLineGame.isEmptyPt(pt: TPoint): boolean;
begin
  result := Maps[pt.X, pt.Y] = -2;
end;



...{*************************************************
  函數名: TLineGame.Create
  描  述: 創建TlineGame類
  參  數: None
  返回值: None
 *************************************************}
constructor TLineGame.Create;
var
  i: integer;
  Res: TResourceStream;
begin
  LineMap := TStringList.Create;
  Res := TResourceStream.Create(HInstance,'SRC1', PChar('FILE1'));
  LineMap.LoadFromStream(res);
  Res.Free;
  for i := 1 to MAPCOUNT do
  begin
    ptLines[i] := TList.Create;
  end;
end;

...{*************************************************
  函數名: TLineGame.Destroy
  描  述: 消耗TLineGame類
  參  數: None
  返回值: None
 *************************************************}
destructor TLineGame.Destroy;
var
  i: integer;
begin
  LineMap.Free;
  for i := MAPCOUNT downto 1 do
  begin
    ptLines[i].Free;
  end;
  SetKbHook(0);
end;

...{*************************************************
  函數名: TLineGame.SetPtLines
  描  述:  根據矩陣設置對子隊列
  參  數: None
  返回值: None
 *************************************************}
procedure TLineGame.SetPtLines;
var
  i, j: integer;
  pt: pPoint;
  mapValue: integer;
begin
  try
    for i := 1 to MAPCOUNT do
      for j := ptLines[i].Count - 1 downto 0 do
      begin
        Dispose(ptLines[i].Items[j]);
        ptLines[i].Delete(j);

      end;

    for i := 0 to MAP_VLENGTH - 1 do
      for j := 0 to MAP_HLENGTH - 1 do
      begin
        new(pt);
        pt.X := i;
        pt.Y := j;
        mapValue := Maps[i, j];
        if mapValue <> -2 then
        begin
          ptLines[mapValue].Add(pt);
        end;
      end;
  except

  end;
end;
...{*************************************************
  函數名: TLineGame.isSameMap
  描  述: 判斷兩點是否相似，如相似則認爲是同一類型的點
  參  數: Color1, Color2: integer
  返回值: boolean
 *************************************************}
function TLineGame.isSameMap(Color1, Color2: integer): boolean;
var
  r1, g1, b1: Integer;
  r2, g2, b2: Integer;
begin
  r1 := GetRValue(Color1);
  g1 := GetGValue(Color1);
  b1 := GetBValue(Color1);

  r2 := GetRValue(Color2);
  g2 := GetGValue(Color2);
  b2 := GetBValue(Color2);

  Result := (abs(r1 - r2) < 5) and (abs(g1 - g2) < 5) and (abs(b1 - b2) < 5)
end;

...{*************************************************
  函數名: TLineGame.GetMapIndex
  描  述:  根據顏色值，判斷其所屬的類型隊列的位置
  參  數: Color: integer
  返回值: integer
 *************************************************}
function TLineGame.GetMapIndex(Color: integer): integer;
var
  i: integer;
  Color1: integer;
begin
  result := -2;
  for i := 0 to LineMap.Count - 1 do
  begin
    Color1 := StrToInt(LineMap.Names[i]);
    if isSameMap(Color, Color1) then
    begin
      result := strtoint(LineMap.ValueFromIndex[i]);
      exit;
    end;
  end;
end;
...{*************************************************
  函數名: TLineGame.LeftMapCount
  描  述:  計算ptLine中剩餘的點數
  參  數: None
  返回值: integer
 *************************************************}
function TLineGame.LeftMapCount: integer;
var
  i: integer;
begin
  Result := 0;
  for i := 1 to MAPCOUNT do
  begin
    inc(Result, ptLines[i].Count);
  end;
end;

...{*************************************************
  函數名: TLineGame.GetBox
  描  述:  獲取遊戲界面佈局數據
  參  數: None
  返回值: None
 *************************************************}
procedure TLineGame.GetBox;
var
  i, j: Integer;
  color1: Cardinal;
begin
  gh := FindWindow(nil, PChar('QQ連連看'));
  //生成數組
  GetWindowRect(gh, Recta);
  for i := 0 to MAP_VLENGTH - 1 do
    for j := 0 to MAP_HLENGTH - 1 do
    begin
      color1 := GetColorMx(j, i);

      if isBackGround(color1) then
        maps[i, j] := -2
      else
        maps[i, j] := GetMapIndex(color1);
    end;
end;
...{*************************************************
  函數名: TLineGame.isBackGround
  描  述:  判斷是否遊戲中的背景
  參  數: Color: Integer
  返回值: boolean
 *************************************************}
function TLineGame.isBackGround(Color: Integer): boolean;
var
  r, g, b: Integer;
begin
  r := GetRValue(Color);
  g := GetGValue(Color);
  b := GetBValue(Color);
  Result := (Abs(110 - r) < 20) and (abs(154 - g) < 20) and (abs(236 - b) < 20);

end;
...{*************************************************
  函數名: TLineGame.GetMapPos
  描  述: 獲取對子矩陣中點在遊戲中的位置
  參  數: i, j: integer
  返回值: Tpoint
 *************************************************}
function TLineGame.GetMapPos(i, j: integer): Tpoint;
begin
  result.x := Recta.Left + gLeft + 16 + hwidth * j;
  result.y := recta.Top + gTop + 18 + vwidth * i;
end;

...{*************************************************
  函數名: TLineGame.SendMouse
  描  述: 模擬發送消除對子的消息
  參  數: x1, y1, x2, y2: Integer
  返回值: None
 *************************************************}
procedure TLineGame.SendMouse(x1, y1, x2, y2: Integer);
var
    pos1, pos2: TPoint;
  Recta: TRect;
begin
  GetWindowRect(gh, Recta);
  pos1 := GetMapPos(x1, y1);
  PostMessage(gh, WM_LBUTTONDOWN, 0, MakeLong(pos1.X - Recta.Left, pos1.y -
    Recta.Top));

  Pos2 := GetMapPos(x2, y2);
  PostMessage(gh, WM_LBUTTONDOWN, 0, MakeLong(pos2.X - Recta.Left, pos2.y -
    Recta.Top));

end;

...{*************************************************
  函數名: TLineGame.RunStep
  描  述: 消除一組對子
  參  數:
  返回值: None
 *************************************************}
procedure TLineGame.RunStep();
var
  p1, p2: TPoint;
begin
  gh := FindWindow(nil, PChar('QQ連連看'));
  SetMemData(gh);
  GetBox;
  SetPtLines;
  if Search(p1, p2) then
  begin
     SendMouse(p1.X, p1.Y, p2.X, p2.Y);
  end;
end;

...{*************************************************
  函數名: TLineGame.KillAll
  描  述:  消除所有對子
  參  數:
  返回值: None
 *************************************************}
procedure TLineGame.KillAll();
var
  p1, p2: TPoint;
  SearchFail: Boolean;
begin
  gh := FindWindow(nil, PChar('QQ連連看'));
  SetMemData(gh);
  GetBox;
  SetPtLines;
  repeat
    SearchFail := true;
    while Search(p1, p2) do
    begin
      SearchFail := False;
      SendMouse(p1.X, p1.Y, p2.X, p2.Y);
    end;
  until (LeftMapCount = 0) or SearchFail;

end;

...{*************************************************
  函數名: TLineGame.AutoStart
  描  述: 自動開始遊戲
  參  數: None
  返回值: None
 *************************************************}
procedure TLineGame.AutoStart;
begin
  gh := FindWindow(nil, PChar('QQ連連看'));
  PostMessage(gh, WM_LBUTTONDOWN, 0, MakeLong(684, 532));
  PostMessage(gh, WM_LBUTTONUP, 0, MakeLong(684, 532));
end;

procedure TLineGame.SetMemData(hnd: THandle);
var ThreadProcessID:integer;
begin
  ThreadProcessID:=GetWindowThreadProcessId(hnd,nil);
  if ThreadProcessID=FGameThreadID then exit;

  FGameThreadID:=ThreadProcessID ;

  SetKbHook(FGameThreadID);
end;

end.

 

QQLLK.dpr

...{*************************************************
  Copyright (C), 2004, 風月工作室.
  作者: 追風逐月
  版本: 1.0
  日期: 2005年02月01日
  描述:
  修改歷史:
    徐明     2005/02/01      1.0        創建該文件
    ...
*************************************************}
...{$J+}
program QQLLK;
uses
  Windows,
  Messages,
  SysUtils,
  ShellAPI,
  LineGame in 'LineGame.pas';

...{$R qqllk.res}
const
  ////////////////
  //資源常量定義//    ;不要修改！
  ////////////////
  MAINICON = 'MAINICON';
  IDD_MAINDLG = 1000;
  MAIN_SINGLE = 1002;
  MAIN_ALL = 1003;
  MAIN_OPTION = 1006;
  MAIN_ABOUT = 1001;
  MAIN_EXIT = 1004;

  IDD_ABOUTDLG = 3000;
  ABOUT_OK = 3001;
  ABOUT_CLOSE = 3002;
  ABOUT_FILE = 3003;
  ABOUT_AUTHOR = 3004;
  ABOUT_MEMO = 3005;

  IDD_OPTIONDLG = 2000;
  OPTION_OK = 2001;
  OPTION_CANCEL = 2002;
  OPTION_ABOUT = 2003;
  OPTION_CLOSE = 2004;
  OPTION_AUTOSTART = 1000;
  OPTION_AUTOTOOLS = 1001;
  OPTION_RANDOM = 1006;
  OPTION_COMPUTER = 1007;
  OPTION_TIMER = 1008;

const
  ////////////////
  //常量數據聲明//
  ////////////////
  (*顏色設定*)
  //clBackground = $8B190B; //背景顏色
  clBackground = $87D34; //背景顏色
  clText = $E4E4E4; //文字顏色
  //clFrom = $871200; //標題欄漸變起始顏色
  //clTo = $808080; //標題欄漸變結束顏色
  clFrom = $87D34; //標題欄漸變起始顏色
  clTo = $808080; //標題欄漸變結束顏色
  ID_HOTKEYF2 = 200;   //熱鍵F2
  ID_HOTKEYF3 = 300;   //熱鍵F3
  ID_HOTKEYCTRLF4 = 400;  //熱鍵CTRL+F4
  szMainCaption = 'QQ連連看外掛';
  ...{*選項對話框*}
  szOptionCaption = '選項'; //關於對話框標題

  (*關於對話框*)
  szAboutCaption = '關於 QQ連連看外掛'; //關於對話框標題
  szFile = '版本 1.1.0.0'; //註冊機說明
  szAuthor = '『由[追風逐月]編寫』'; //註冊機作者
  szGreet = //字幕內容每行不要超過32個字符(16個漢字)
  '本軟件由風月工作室出品'#10#10 + '〖聯繫方式〗'#10#10'[email protected]'#10#10+
     '〖快捷鍵〗'#10#10+'F2:消除一組對子'#10'F3:消除所有對子'#10'CTRL+F4:顯示/隱藏窗口'#10#10+
     '〖特別感謝〗'#10#10+
    '各位QQ遊戲愛好者'#10'我的哥們'#10'以及所有曾幫助過我的人'#10#10 +
    '〖免責聲明〗'#10#10'本軟件屬於免費軟件'#10'可以自由使用'#10'由此造成的一切後果（如QQ號被封）'#10'均與作者無關'#10#10 +
    '〖版本信息〗'#10#10'[1.0.0.0]'#10'實現外掛程序基本功能'#10'[1.1.0.0]'#10'使用內存補丁的方法，'#10'去掉了原程序包中的連連看替換文件.'#10' ' ;
var
  BKC: HBRUSH; //背景畫刷
  //h_Cur: HCURSOR; //鼠標指針句柄
  h_Inst: HINST; //程序圖標句柄
  h_Icon: HICON; //實例句柄
  h_mainDlg: HWND;

  g_AutoStart: boolean = false; //自動開始
  g_AutoTools: boolean = false; //自動使用工具
  g_Random: boolean = false; //隱藏窗口
  g_Computer: boolean = false; //電腦託管

  g_timer: array[0..254] of char = '1000'; //消除頻率
  g_internal:integer=1000;                 //定時間隔
  LineGames: TLineGame;                    //遊戲類
function LinesInStr(srcStr: string): smallint;
var
  i: integer;
begin
  Result := 1;
  for i := 0 to Length(srcStr) - 1 do
    if srcStr[i] = #10 then
      Result := Result + 1;
  if Result > 1 then
    Result := Result - 1;
end;
//////////////////////////////////////////////////////////////////
//動態顯示窗體函數
procedure AnimateShow(hDlg: HWND);
var
  Rt: TRECT;
  x, y, i: smallint;
  h_Rgn: HRGN;
begin
  ShowWindow(hDlg, SW_HIDE);
  GetWindowRect(hDlg, Rt);
  x := (Rt.right - Rt.left) div 2;
  y := (Rt.bottom - Rt.top) div 2;
  for i := 0 to (Rt.Right div 2) do
  begin
    h_Rgn := CreateRectRgn(x - i, y - i, x + i, y + i);
    SetWindowRgn(hDlg, h_Rgn, True);
    ShowWindow(hDlg, SW_SHOW);

    DeleteObject(h_Rgn);
  end;
  SetWindowPos(hDlg, HWND_TOPMOST, rt.Left, rt.Top, rt.Right - rt.Left, rt.Bottom
    - rt.Top, 0);

end;

//////////////////////////////////////////////////////////////
//繪製標題欄函數
//hDC:            繪製窗體的設備環境句柄
//hIco:            標題欄圖標句柄
//szCaption:    標題欄標題
//rect:            標題欄矩形區域
//clBegin:        標題欄漸變起始顏色
//clEnd:        標題欄漸變結束顏色
procedure PaintCaption(h_DC: HDC; h_Ico: HICON; const szCaption: string; rect:
  TRECT;
  clBegin: COLORREF; clEnd: COLORREF);
var
  brush: HBRUSH;
  _logbrush: LOGBRUSH; //上色畫刷
  colorrect: TRECT; //上色矩形區域
  h_font: HFONT; //標題欄字體
  Haf, i: smallint;
  R, G, B, fr, fg, fb, dr, dg, db: smallint;
begin
  fr := GetRValue(clFrom); //分解顏色
  fg := GetGValue(clFrom);
  fb := GetBValue(clFrom);
  dr := GetRValue(clTo);
  dg := GetGValue(clTo);
  db := GetBValue(clTo);

  Haf := (rect.right - rect.left) div 2; //計算標題欄矩形區域中心
  //設定上色矩形區域高度
  colorrect.top := 0;
  colorrect.bottom := rect.bottom - rect.top;

  //建立漸變上色畫刷
  _logbrush.lbStyle := BS_SOLID;
  _logbrush.lbHatch := 0;
  for i := 0 to Haf do
  begin
    //設定左半上色矩形區域一次填充位置
    colorrect.left := MulDiv(i, Haf, Haf);
    colorrect.right := MulDiv(i + 1, Haf, Haf);
    //顏色漸變
    R := fr + MulDiv(i, dr, Haf);
    G := fg + MulDiv(i, dg, Haf);
    B := fb + MulDiv(i, db, Haf);
    if (R > 255) then
      R := 255;
    if (G > 255) then
      G := 255;
    if (B > 255) then
      B := 255;
    _logbrush.lbColor := RGB(R, G, B);
    brush := CreateBrushIndirect(_logbrush);
    FillRect(h_DC, colorrect, brush); //填充左半區域
    //設定右半上色矩形區域一次填充位置
    colorrect.left := (rect.right - rect.left) - (MulDiv(i, Haf, Haf));
    colorrect.right := (rect.right - rect.left) - (MulDiv(i + 1, Haf, Haf));
    FillRect(h_DC, colorrect, brush); //填充右半區域
    DeleteObject(brush);
  end;

  _logbrush.lbColor := $9E6A54;
  brush := CreateBrushIndirect(_logbrush);
  FrameRect(h_DC, rect, brush); //繪製標題欄邊框
  DeleteObject(brush);

  SetTextColor(h_DC, $FFFFFF);
  SetBkMode(h_DC, TRANSPARENT); //設定標題欄字體屬性
  rect.left := 2;
  rect.top := 2;
  rect.bottom := rect.Bottom - 2;
  h_font := CreateFont(-12, 0, 0, 0, 700, 0, 0, 0, DEFAULT_CHARSET,
    OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,
    DEFAULT_PITCH or FF_DONTCARE, '宋體');
  //(宋體9號粗體字)
  SelectObject(h_DC, h_font);
  if h_Ico <> 0 then //若有圖標則會製圖標
  begin
    DrawIconEx(h_DC, 2, 2, h_Ico, 16, 16, 0, 0, DI_NORMAL);
    rect.left := 20;
  end;
  //繪製標題欄標題
  DrawText(h_DC, PChar(szCaption), -1, rect, DT_SINGLELINE or DT_VCENTER);
  DeleteObject(h_font);
end;

//////////////////////////////////////////////////////////////
//繪製按鈕函數
//pdis:            繪製內容結構指針
procedure DrawButton(pdis: PDRAWITEMSTRUCT);
var
  szText: array[0..9] of char; //按鈕文字
begin
  FillRect(pdis.hDC, pdis.rcItem, BKC); //以背景色填充按鈕

  SetTextColor(pdis.hDC, clText);
  SetBkMode(pdis.hDC, TRANSPARENT);

  //尚未點擊，繪製按鈕邊框-突起狀態
  DrawEdge(pdis.hDC, pdis.rcItem, BDR_RAISEDOUTER, BF_RECT);
  GetWindowText(pdis.hwndItem, szText, sizeof(szText));
  DrawText(pdis.hDC, szText, -1, pdis.rcItem, DT_SINGLELINE or DT_CENTER or
    DT_VCENTER);

  //已被按下，繪製按鈕邊框-凹陷狀態
  //if (pdis.itemState and ODS_SELECTED)=ODS_SELECTED then

  if (pdis.itemState and ODS_SELECTED) <> 0 then
  begin
    SetTextColor(pdis.hDC, $00DDFF);
    DrawText(pdis.hDC, szText, -1, pdis.rcItem, DT_SINGLELINE or DT_CENTER or
      DT_VCENTER);
    DrawEdge(pdis.hDC, pdis.rcItem, BDR_SUNKENOUTER, BF_RECT);
  end;
end;

function ScrollProc(h_Wnd: HWND; Msg, wParam, lParam: DWORD): LRESULT; stdcall;
var
  h_DC: HDC;
  ps: TPAINTSTRUCT;
  rc: TRECT;
  h_font: HFONT;

begin
  case Msg of
    WM_PAINT:
      begin
        //繪製字幕內容
        h_DC := BeginPaint(h_Wnd, ps);
        GetClientRect(h_Wnd, rc);
        SetTextColor(h_DC, clText);
        SetBkMode(h_DC, TRANSPARENT);
        h_font := CreateFont(-12, 0, 0, 0, 0, 0, 0, 0, DEFAULT_CHARSET,
          OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH
          or FF_DONTCARE, '宋體');
        SelectObject(h_DC, h_font);
        DrawText(h_DC, szGreet, -1, rc, DT_CENTER);
        EndPaint(h_Wnd, ps);
        DeleteObject(h_font);
      end;
  else
    begin
      //l:=GetWindowLong(h_Wnd,GWL_USERDATA);
      //CallWindowProc(@l,h_Wnd,Msg,wParam,lParam);
    end;
  end;
  result := 1;
end;
function AboutProc(hDlg: HWND; Msg, wParam, lParam: DWORD): LRESULT; stdcall;
const
  rcCaption: TRECT = ();
  i: smallint = 0;
  w: smallint = 0;
  h: smallint = 0;
  h_Memo: HWND = 0;
  memo: HWND = 0;
  lines: smallint = 1; //字幕行數
var
  h_dc: HDC;
  ps: TPAINTSTRUCT;
  pdis: PDRAWITEMSTRUCT;
  pt: TPOINT;
  rcMemo: TRECT;
  lUser: integer;
  h_Font: HFONT;
  h_File: HWND;
begin
  case Msg of
    WM_INITDIALOG:
      begin
        GetClientRect(hDlg, rcCaption);
        rcCaption.bottom := rcCaption.top + 20;

        h_Memo := GetDlgItem(hDlg, ABOUT_MEMO);
        h_File := GetDlgItem(hDlg, ABOUT_FILE);
        h_Font := CreateFont(-12, 0, 0, 0, 700, 0, 0, 0, DEFAULT_CHARSET,
          OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH
          or FF_DONTCARE, '宋體');
        SendMessage(h_File, WM_SETFONT, h_Font, 0);

        SetDlgItemText(hDlg, ABOUT_FILE, szFile);
        SetDlgItemText(hDlg, ABOUT_AUTHOR, szAuthor);
        SetWindowText(hDlg, szAboutCaption);

        GetClientRect(h_Memo, rcMemo); //得到字幕顯示區域大小
        w := rcMemo.right - rcMemo.left;
        h := rcMemo.bottom - rcMemo.top;
        i := h;
        lines := LinesInStr(szGreet); //計算字幕行數

        //建立顯示字幕子窗體
        memo := CreateWindow('Static', '', WS_VISIBLE or WS_CHILD or SS_CENTER,
          0, h, w, 12 * lines, h_Memo, 0, h_Inst, nil);
        //設定子窗體消息處理函數
        lUser := SetWindowLong(memo, GWL_WNDPROC, integer(@ScrollProc));
        SetWindowLong(memo, GWL_USERDATA, lUser);

        AnimateShow(hDlg);
        SetTimer(hDlg, 168, 80, nil); //設定定時器每80毫秒觸發一次
        result := 1;
      end;
    WM_TIMER:
      begin
        //定時器觸發時移動子窗體，形成字幕
        Sleep(20);
        i := i - 1;
        SetWindowPos(memo, 0, 0, i, w, 12 * lines, 0);
        if (-(i + (12 * lines)) > 0) then
          i := h; //字幕到達尾部時，重新開始循環
      end;

    WM_LBUTTONDOWN:
      begin
        pt.x := LOWORD(lParam);
        pt.y := HIWORD(lParam);
        if (PtInRect(rcCaption, pt)) then
          PostMessage(hDlg, WM_NCLBUTTONDOWN, HTCAPTION, 0);
      end;

    WM_PAINT:
      begin
        h_dc := BeginPaint(hDlg, ps);
        PaintCaption(h_dc, h_Icon, szAboutCaption, rcCaption, clFrom, clTo);
        EndPaint(hDlg, ps);
      end;

    WM_COMMAND:
      begin
        case wParam of
          ABOUT_OK:
            begin
              KillTimer(hDlg, 168); //銷燬定時器
              EndDialog(hDlg, 0);
            end;
          ABOUT_CLOSE:
            begin
              KillTimer(hDlg, 168); //銷燬定時器
              EndDialog(hDlg, 0);
            end;
        end;
        result := 0;
      end;

    WM_DRAWITEM:
      begin
        pdis := PDRAWITEMSTRUCT(lParam);
        DrawButton(pdis);
        Result := 0;
      end;
    ///////////////////////////////////////////////////
    //響應繪製窗體內容消息
    WM_CTLCOLORDLG:
      begin
        SetTextColor(wParam, clText);
        SetBkMode(wParam, TRANSPARENT);
        Result := BKC;
      end;
    WM_CTLCOLORSTATIC:
      begin
        SetTextColor(wParam, clText);
        SetBkMode(wParam, TRANSPARENT);
        Result := BKC;
      end;
  else
    Result := 0;
  end;
end;
function OptionProc(hDlg: HWND; Msg, wParam, lParam: DWORD): LRESULT; stdcall;
const
  rcCaption: TRECT = ();
  i: smallint = 0;
  w: smallint = 0;
  h: smallint = 0;
  h_Memo: HWND = 0;
  memo: HWND = 0;
  lines: smallint = 1; //字幕行數
var
  h_dc: HDC;
  ps: TPAINTSTRUCT;
  pdis: PDRAWITEMSTRUCT;
  pt: TPOINT;
  h_Font: HFONT;
  h_File: HWND;
  e: integer;
begin
  case Msg of
    WM_INITDIALOG:
      begin
        GetClientRect(hDlg, rcCaption);
        rcCaption.bottom := rcCaption.top + 20;

        h_Memo := GetDlgItem(hDlg, ABOUT_MEMO);
        h_File := GetDlgItem(hDlg, ABOUT_FILE);
        h_Font := CreateFont(-12, 0, 0, 0, 700, 0, 0, 0, DEFAULT_CHARSET,
          OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH
          or FF_DONTCARE, '宋體');
        SendMessage(h_File, WM_SETFONT, h_Font, 0);

        CheckDlgButton(hdlg, OPTION_AUTOSTART, ord(g_AutoStart));
        CheckDlgButton(hdlg, OPTION_AUTOTOOLS, ord(g_AutoTools));
        CheckDlgButton(hdlg, OPTION_RANDOM, ord(g_Random));
        CheckDlgButton(hdlg, OPTION_COMPUTER, ord(g_Computer));
        SetDlgItemText(hDlg, OPTION_TIMER, g_timer);

        result := 1;
      end;

    WM_LBUTTONDOWN:
      begin
        pt.x := LOWORD(lParam);
        pt.y := HIWORD(lParam);
        if (PtInRect(rcCaption, pt)) then
          PostMessage(hDlg, WM_NCLBUTTONDOWN, HTCAPTION, 0);
      end;

    WM_PAINT:
      begin
        h_dc := BeginPaint(hDlg, ps);
        PaintCaption(h_dc, h_Icon, szOptionCaption, rcCaption, clFrom, clTo);
        EndPaint(hDlg, ps);
      end;

    WM_COMMAND:
      begin
        case wParam of
          OPTION_OK:
            begin

              g_AutoStart := IsDlgButtonChecked(hDlg, OPTION_AUTOSTART) =
                BST_CHECKED;
              g_AutoTools := IsDlgButtonChecked(hDlg, OPTION_AUTOTOOLS) =
                BST_CHECKED;
              g_Random := IsDlgButtonChecked(hDlg, OPTION_RANDOM) =
                BST_CHECKED;
              g_Computer := IsDlgButtonChecked(hDlg, OPTION_COMPUTER) =
                BST_CHECKED;
              GetDlgItemText(hDlg, OPTION_TIMER, g_timer, 255);
              //LineGames.AutoStart;
              Val(g_timer, g_internal, E);
              if (E <> 0) or (g_internal < 500) or (g_internal > 10000) then
              begin
                g_internal := 1000;
                MessageBox(hDlg, pchar('請輸入一個有效的整數（500~10000）!'),
                  pchar('輸入錯誤'),
                  MB_ICONERROR);
                exit;
              end;
              if g_autostart or g_Computer then
                SetTimer(h_mainDlg, 169, g_internal, nil)
              else
                KillTimer(h_mainDlg, 169);
              //設定定時器每1000毫秒觸發一次
              EndDialog(hDlg, 0);
            end;
          OPTION_ABOUT: DialogBox(h_Inst, LPCTSTR(IDD_ABOUTDLG), hDlg,
              @AboutProc);

          OPTION_CANCEL, OPTION_CLOSE:
            begin
              EndDialog(hDlg, 0);
            end;
        end;
        result := 0;
      end;

    WM_DRAWITEM:
      begin
        pdis := PDRAWITEMSTRUCT(lParam);
        DrawButton(pdis);
        Result := 0;
      end;
    ///////////////////////////////////////////////////
    //響應繪製窗體內容消息
    WM_CTLCOLORDLG:
      begin
        SetTextColor(wParam, clText);
        SetBkMode(wParam, TRANSPARENT);
        Result := BKC;
      end;
    WM_CTLCOLORSTATIC:
      begin
        SetTextColor(wParam, clText);
        SetBkMode(wParam, TRANSPARENT);
        Result := BKC;
      end;
  else
    Result := 0;
  end;
end;

function MainProc(hDlg: HWND; Msg, wParam, lParam: DWORD): LRESULT; stdcall;
const
  rcCaption: TRECT = ();
var
  h_dc: HDC;
  ps: TPAINTSTRUCT;
  pdis: PDRAWITEMSTRUCT;
  pt: TPOINT;
begin
  case Msg of
    WM_INITDIALOG:
      begin
        h_mainDlg := hDlg;
        GetClientRect(hDlg, rcCaption);
        rcCaption.bottom := rcCaption.top + 20;
        SetWindowText(hDlg, szMainCaption);
        AnimateShow(hDlg);

        if (RegisterHotKey(hDlg, ID_HOTKEYF2, 0, VK_F2) = false) then
        begin
          //hotkey註冊
          //失敗了的話...
          MessageBox(hDlg, pchar('註冊熱鍵F2失敗!'), pchar('Error'),
            MB_ICONERROR);
          PostQuitMessage(0);
        end;
        if (RegisterHotKey(hDlg, ID_HOTKEYF3, 0, VK_F3) = false) then
        begin
          //hotkey註冊
          //失敗了的話...
          MessageBox(hDlg, pchar('註冊熱鍵F3失敗!'), pchar('Error'),
            MB_ICONERROR);
          PostQuitMessage(0);
        end;
        if (RegisterHotKey(hDlg, ID_HOTKEYCTRLF4, MOD_CONTROL, VK_F4) = false)
          then
        begin
          //hotkey註冊
          //失敗了的話...
          MessageBox(hDlg, pchar('註冊熱鍵CTRL+F4失敗!'), pchar('Error'),
            MB_ICONERROR);
          PostQuitMessage(0);
        end;
        result := 1;
      end;
    WM_HOTKEY: //處理WM_HOTKEY消息
      begin
        case HIWORD(lParam) of
          VK_F3: LineGames.KillAll;
          vk_F2: LineGames.RunStep;
          VK_F4:
            begin
              if IsWindowVisible(hDlg) then
                showWindow(hDlg, SW_HIDE)
              else
                showWindow(hDlg, SW_SHOW);

            end;
        end;
        result := 0;
      end;

    WM_LBUTTONDOWN:
      begin
        //響應鼠標左鍵按下消息，若在標題欄內則使窗體移動
        pt.x := LOWORD(lParam);
        pt.y := HIWORD(lParam);
        if PtInRect(rcCaption, pt) then
          PostMessage(hDlg, WM_NCLBUTTONDOWN, HTCAPTION, 0);
      end;
    WM_PAINT:
      begin
        //響應繪製消息，繪製標題欄
        h_DC := BeginPaint(hDlg, ps);
        PaintCaption(h_DC, h_Icon, szMainCaption, rcCaption, clFrom, clTo);
        EndPaint(hDlg, ps);
      end;

    WM_COMMAND:
      begin
        case wParam of
          MAIN_SINGLE:
            begin
              LineGames.RunStep;
            end;
          MAIN_ALL: LineGames.KillAll();
          MAIN_OPTION: DialogBox(h_Inst, LPCTSTR(IDD_OPTIONDLG), hDlg,
              @OptionProc);
          MAIN_ABOUT:
            DialogBox(h_Inst, LPCTSTR(IDD_ABOUTDLG), hDlg, @AboutProc);

          MAIN_EXIT: EndDialog(hDlg, 0);
        end;
        result := 0;
      end;
    WM_DRAWITEM:
      begin
        pdis := PDRAWITEMSTRUCT(lParam);
        DrawButton(pdis);
        Result := 0;
      end;
    WM_TIMER:
      begin
        //定時器觸發時移動子窗體，形成字幕
        if g_AutoStart then
          LineGames.AutoStart;
        if g_Computer then
          LineGames.RunStep;

        if g_Random then
        SetTimer(hDlg,169,500+Random(g_internal-500),nil);
      end;
    ///////////////////////////////////////////////////
    //響應繪製窗體內容消息
    WM_CTLCOLORDLG:
      begin
        SetTextColor(wParam, clText);
        SetBkMode(wParam, TRANSPARENT);
        Result := BKC;
      end;
    WM_CTLCOLORSTATIC:
      begin
        SetTextColor(wParam, clText);
        SetBkMode(wParam, TRANSPARENT);
        Result := BKC;
      end;
    WM_DESTROY:
      begin
        UnregisterHotKey(hDlg, ID_HOTKEYF2); //用完記得要收回
        UnregisterHotKey(hDlg, ID_HOTKEYF3); //用完記得要收回
        UnregisterHotKey(hDlg, ID_HOTKEYCTRLF4); //用完記得要收回
        KillTimer(hDlg, 169);
        PostQuitMessage(0);
      end;
  else
    Result := 0;
  end;
end;
//////////////////////////////////////////////////////////////////
//程序入口函數
//
begin
  h_Inst := GetModuleHandle(nil); //保存實例句柄
  BKC := CreateSolidBrush(clBackground); //建立背景畫刷
  //h_Cur := LoadCursor(h_Inst, LPCTSTR(IDC_HAND)); //載入鼠標指針
  h_Icon := LoadIcon(h_Inst, LPCTSTR(MAINICON)); //載入程序圖標


  //顯示協議對話框
  LineGames := TLineGame.Create;

  DialogBox(h_Inst, LPCTSTR(IDD_MAINDLG), 0, @MainProc);
  LineGames.Free;
  DeleteObject(BKC); //釋放背景畫刷
  //退出程序
  ExitProcess(0);
end.