admin管理员组文章数量:1577825
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 ' coolchyni@gmail ' # 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.
版权声明:本文标题:QQ连连看 for Delphi 源码 内容由热心网友自发贡献,该文观点仅代表作者本人, 转载请联系作者并注明出处:https://www.elefans.com/xitong/1726163732a1057997.html, 本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌抄袭侵权/违法违规的内容,一经查实,本站将立刻删除。
发表评论