Почему не работает следующий код...

← →
WED (2004-01-20 10:14) [0]

Задача: Узнать заголовок любого видимого сворачиваемого/разворачиваемого/перемещаемого окна.

Когда этот код запускается из под Дельфи, то при попытке переместить окно, всё молча закрывается (и прога и сам Дельфи). При запуске без Дельфи - ошибка: Access violation.

вот код:

function HookProc(Code: integer; WParam: word; LParam: Longint): Longint; stdcall;
var
msg: PEVENTMSG;
buff: ARRAY [0..127] OF Char;
wnd: HWND;
begin
if Code <> HCBT_MOVESIZE then
begin
result := CallNextHookEx(HookHandle, code, WParam, LParam);
Exit;
end;

MSG := Pointer(Wparam);
WND:=Msg.hwnd;
IF (Wnd <> Application.Handle) AND
IsWindowVisible(Wnd) AND
(GetWindow(Wnd, gw_Owner) = 0) AND
(GetWindowText(Wnd, buff, sizeof(buff)) <> 0) THEN
BEGIN
GetWindowText(Wnd, buff, sizeof(buff));
end;
End;

Просветите, спецы!

← →
AKul (2004-01-20 10:37) [1]

А Hook то у тебя глобальный!
Надеюсь ты догадался, что его надо в отдельнуюю DLL выносить!?!?!

← →
AKul (2004-01-20 12:25) [2]

Судя по всему - не догадался.

← →
Юрий Зотов (2004-01-20 12:43) [3]

И не просто в отдельную DLL. В этой DLL переменную HookHandle надо еще сделать глобальной на уровне всей системы. И CallNextHookEx надо вызывать всегда, без всяких условий.

Читайте статью Алексея Павлова на этом сайте.

← →
AKul (2004-01-20 13:05) [4]

И Application.Handle тоже не подойдет......

В общем, перед тем как использовать что-то новое, следует это новое хоть немного изучить, а потом задавать вопросы, подобные " Просветите, спецы!".

← →
WED (2004-01-20 15:30) [5]

Всем спасибо, что ткнули носом ;) Статью уже нашел. Ошибку свою понял. Нашел пример глоб.хука на клавиши... Переделал под себя, вроде получилось.. - идет перехват HCBT_MINMAX, получение заголовка окна (которое изменяется) и занесение его в список. Всё работает. Только иногда ошибка вылетает из-за эксплорера. Происходит это так: запускаю свою прогу, ставлю хук (это взято из примера), разворачиваю, сворачиваю разные окна. Всё нормально - заголовки попадают в список. Потом нетрогаю комп несколько минут - и вылетает ошибка.. В заголовке ошибки эксплорер...

← →
AKul (2004-01-20 15:33) [6]

Какая инменно ошибка?

← →
WED (2004-01-20 16:00) [7]

Ошибка: память не может быть read и т.д....

← →
Юрий Зотов (2004-01-20 16:13) [8]

> WED

Похоже, что-то не то с указателями. Если Вы передаете из хука в основную программу (или наоборот) какие-то адреса, то учли, что эти адреса будут в РАЗНЫХ адресных пространствах?

← →
WED (2004-01-20 16:16) [9]

Блин, ентер нажал...
На этой ошибке жмем ОК и получаем новое окно с ошибкой там уже:
EAccess Violation....DTHook.dll....

← →
AKul (2004-01-20 16:30) [10]

Покажи код

← →
WED (2004-01-20 16:39) [11]

Сама программа:

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ImgList, ComCtrls, ToolWin, StdCtrls, ExtCtrls, Menus;

type
TForm1 = class(TForm)
StatusBar1: TStatusBar;
Bevel1: TBevel;
GroupBox1: TGroupBox;
Button2: TButton;
Button1: TButton;
Memo1: TMemo;
ImageList1: TImageList;
MainMenu1: TMainMenu;
File1: TMenuItem;
Save1: TMenuItem;
N1: TMenuItem;
Exit1: TMenuItem;
N2: TMenuItem;
Startloging1: TMenuItem;
StopLoging1: TMenuItem;
H1: TMenuItem;
Programmhelp1: TMenuItem;
N3: TMenuItem;
About1: TMenuItem;
SaveDialog1: TSaveDialog;
Button3: TButton;
procedure Exit1Click(Sender: TObject);
procedure ToolButton1Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Startloging1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure StopLoging1Click(Sender: TObject);
procedure Save1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{перезаписываем процедуру окна - подробнее см. ниже}
procedure WndProc(var Msg: TMessage); override;
public
{ Public declarations }
end;

var
Form1: TForm1;
WndFlag: HWND; // дескриптор последнего окна
hDLL: THandle; // дескриптор загружаемой библиотеки
WM_MYWINHOOK: Cardinal; // моё сообщение

implementation

{$R *.dfm}

function GetWndText(WndH: HWND): string;
var
s: string;
Len: integer;
begin
Len:= GetWindowTextLength(WndH)+1; // получаю размер текста
if Len > 1 then
begin
SetLength(s, Len);
GetWindowText(WndH, @s[1], Len); // получаю сам текст, который записывается в s
Result:= s;
end
else
Result:= "caption not detected";
end;

procedure TForm1.Exit1Click(Sender: TObject);
begin
Close;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
Close;
end;

procedure TForm1.Startloging1Click(Sender: TObject);
begin
Button1.Click;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
Hook: procedure (switch : Boolean; hMainProg: HWND) stdcall;
begin
@hook:= nil; // инициализируем переменную hook
hDLL:= LoadLibrary(PChar("DThook.dll")); { загрузка DLL }
if hDLL > HINSTANCE_ERROR then
begin { если всё без ошибок, то }
@hook:=GetProcAddress(Hdll, "hook"); { получаем указатель на необходимую процедуру}
Button2.Enabled:=True;
Button1.Enabled:=False;
StatusBar1.SimpleText:= "Status: DLL loaded...";
hook(true, Form1.Handle);
StatusBar1.SimpleText:= "Status: loging in progress...";
end
else
begin
ShowMessage("Ошибка при загрузке DLL !");
Exit;
end;

end;

procedure TForm1.Button2Click(Sender: TObject);
var
Hook: procedure (switch : Boolean; hMainProg: HWND) stdcall;
begin
@hook:= nil; // инициализируем переменную hook
if hDLL > HINSTANCE_ERROR then
begin { если всё без ошибок, то }
@hook:=GetProcAddress(Hdll, "hook"); { получаем указатель на необходимую процедуру}
Button1.Enabled:=True;
Button2.Enabled:=False;
hook(false, Form1.Handle);
if FreeLibrary(hDLL) then
begin
StatusBar1.SimpleText:= "Status: DLL unloaded.";
sleep(1000)
end
else
begin
StatusBar1.SimpleText:= "Status: ERROR while unloading DLL";
Exit;
end;
StatusBar1.SimpleText:= "Status: Stoped";
end;

end;

procedure TForm1.StopLoging1Click(Sender: TObject);
begin
Button2.Click;
end;

procedure TForm1.Save1Click(Sender: TObject);
begin
ToolButton1.Click;
end;

{
подмена процедуры окна - необходимо для обработки сообщений, поступивших из
DLL (см. исходный код DLL)
}
procedure TForm1.WndProc(var Msg: TMessage);
begin
inherited ; // выполняем всё то, что должно происходить при поступлении сообщеня окну
{Но если пришло моё сообщение - выполняем следующий код}
if Msg.Msg = WM_MYWINHOOK then
begin
Memo1.Lines.Add(GetWndText(Msg.lParam));
WndFlag:= HWND(Msg.lParam)
end;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
if OpenMutex(MUTEX_ALL_ACCESS, TRUE, "SmallDeskTop") <> 0 then
begin
ShowMessage("Only one instance can be run !");
Close;
end;
CreateMutex(0, TRUE, "SmallDeskTop");
end;

initialization

WndFlag:=0;
{ регистрирую своё сообщение в системе - точно так же надо сделать и в теле DLL
что бы DLL могла посылать главному приложению это сообщение.
}
WM_MYWINHOOK:= RegisterWindowMessage("WM_MYWINHOOK");
end.

← →
WED (2004-01-20 16:39) [12]

Это DLL:

library DTHook;

uses
SysUtils,
Windows,
Messages,
Forms;

const
MMFName: PChar = "DesktopMMF"; // имя объекта файлового отображения

{структура, поля которой будут отображены в файл подкачки}
type
PGlobalDLLData = ^TGlobalDLLData;
TGlobalDLLData = packed record
SysHook: HWND; // дескриптор установленной ловушки
MyAppWnd: HWND; // дескриптор нашего приложения
end;

var
GlobalData: PGlobalDLLData;
MMFHandle: THandle;
WM_MYWINHOOK: Cardinal;

function WinHookProc(code : integer; wParam : word; lParam : longint) : longint; stdcall;
var
AppWnd: HWND; // дескриптор приложения, окно которго изменили
begin

if code <> HCBT_MINMAX then //если это не свернуть/развернуть
begin
Result:= CallNextHookEx(GlobalData^.SysHook, Code, wParam, lParam); //стандартный обработчик
Exit;
end;

AppWnd:= GetForegroundWindow(); //получим хэндл верхнего окна
If AppWnd<>0 Then //если хэндл есть
begin
If IsWindowVisible(AppWnd) {AND //если окно видимо
{(AppWnd.Parent=0)} Then //и окно родительское
SendMessage(GlobalData^.MyAppWnd, WM_MYWINHOOK, wParam, AppWnd); //отправим мессадж нашей проге
end;

CallNextHookEx(GlobalData^.SysHook, Code, wParam, lParam); //и стандартный обработчик
Result:= 0;
end;

{Процедура установки HOOK-а}
procedure hook(switch : Boolean; hMainProg: HWND) export; stdcall;
begin
if switch=true then
begin
{Устанавливаю HOOK, если он не установлен (switch=true). }
GlobalData^.SysHook := SetWindowsHookEx(WH_CBT, @WinHookProc, HInstance, 0);
GlobalData^.MyAppWnd:= hMainProg;
if GlobalData^.SysHook <> 0 then
MessageBox(0, "KEYBOARD HOOK установлен !", "Message from DTHook.dll", 0)
else
MessageBox(0, "HOOK установить не удалось !", "Message from DTHook.dll", 0);

end
else
begin

{Удаляю функцию-фильтр, если она установлена (т.е. switch=false). }
if NOT UnhookWindowsHookEx(GlobalData^.SysHook) then MessageBox(0, "HOOK снять не удалось !", "Message from TDhook.dll", 0);

end;
end;

procedure OpenGlobalData();
begin
{регестрируем свой тип сообщения в системе}
WM_MYWINHOOK:= RegisterWindowMessage("WM_MYWINHOOK");

{получаем объект файлового отображения}
// MMFHandle:= CreateFileMapping(DWord(-1), nil, PAGE_READWRITE, 0, SizeOf(TGlobalDLLData), MMFName); // можно так, но лучше: см. след. строку
MMFHandle:= CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE, 0, SizeOf(TGlobalDLLData), MMFName);

if MMFHandle = 0 then
begin
MessageBox(0, "Can""t create FileMapping", "Message from DTHook.dll", 0);
Exit;
end;

{отображаем глобальные данные на АП вызывающего процесса и получаем указатель
на начало выделенного пространства}
GlobalData:= MapViewOfFile(MMFHandle, FILE_MAP_ALL_ACCESS, 0, 0, SizeOf(TGlobalDLLData));
if GlobalData = nil then
begin
CloseHandle(MMFHandle);
MessageBox(0, "Can""t make MapViewOfFile", "Message from DTHook.dll", 0);
Exit;
end;

end;

procedure CloseGlobalData();
begin
UnmapViewOfFile(GlobalData);
CloseHandle(MMFHandle);
end;

procedure DLLEntryPoint(dwReason: DWord); stdcall;
begin
case dwReason of
DLL_PROCESS_ATTACH: OpenGlobalData;
DLL_PROCESS_DETACH: CloseGlobalData;
end;
end;

exports hook;

begin
{назначим поцедуру переменной DLLProc}
DLLProc:= @DLLEntryPoint;
{вызываем назначенную процедуру для отражения факта присоединения данной
библиотеки к процессу}
DLLEntryPoint(DLL_PROCESS_ATTACH);
end.

← →
WED (2004-01-20 16:40) [13]

Вообще это взято из примера в одной статье. Там был клавиатурный хук. Я просто его урезал и слегка переделал. И хук не на клавиши, а на окна сделал. А в общем всё осталось как было.

← →
Юрий Зотов (2004-01-20 17:00) [14]

С виду, вроде, нормально. Можно попробовать прикрепить DLL к EXE и погонять под отладчиком ПРИ АКТИВНОМ EXE.

← →
WED (2004-01-20 17:02) [15]

Если ты еще объяснишь как это и что это....

← →
WED (2004-01-20 17:10) [16]

И еще вопрос: есть мысль - сделать, чтобы отслеживались только основные окна программ, а дочерние нет... Как это лучше сделать?

← →
WED (2004-01-20 17:44) [17]

эй! спецы! вы где?

← →
Юрий Зотов (2004-01-20 17:58) [18]

> WED © (20.01.04 17:02) [15]

Sorry, это очень долго. Чтобы разобрать этот код в разговоре нужен примерно час (да и то при условии, что имеется нужный уровень подготовки), а в форуме - слишком много писать придется.

> WED © (20.01.04 17:10) [16]

Обратил внимание, что у Вас wParam - word. Для Win32 это неверно и могут быть чудеса. Попробуйте вот такой код ловушки:
function WinHookProc(code, wParam, lParam: longint): longint; stdcall; begin if (code = HCBT_MINMAX) and (GetParent(wParam) = 0) then SendMessage(GlobalData^.MyAppWnd, WM_MYWINHOOK, wParam, lParam and $FFFF); // WParam - хэндл окна, lParam - константа SW_xxx Result := CallNextHookEx(GlobalData^.SysHook, Code, wParam, lParam) end;

← →
AKul (2004-01-20 17:59) [19]

Тебе же сказали, что на первый взгляд все нормально.
Кроме того, проверил твой код (только основные фрагменты) у себя на машине - никаких глюков не обнаружил (долго не тестировал).
Попробуй выловить свой глюк под SoftIce"ом.
Насчет остальных вопросов: В Help заглянуть слабо? или ты хочешь, чтобы мы это сделали?

← →
WED (2004-01-21 09:46) [20]

2 Akul: Да нет, не надо за меня делать... Достаточно было бы просто ткунть носом какой оператор использовать... Пробовал GetParent(AppWND) - не работает :(

← →
pasha_golub (2004-01-21 09:49) [21]

2WED
GetWindowLong+F1

← →
pasha_golub (2004-01-21 09:59) [22]

var WinStyle : LongInt; begin WinStyle := GetWindowLong(WindowHandle, GWL_STYLE); if (WinStyle AND WS_VISIBLE) <> 0) //видимое AND (WinStyle AND WS_CHILD = 0) //не дочернее then ...

← →
WED (2004-01-21 10:06) [23]

Понял.
Спасибо, Паша.

← →
pasha_golub (2004-01-21 10:14) [24]

2WED
Еще в догонку

var ExStyle: longint; begin ... ExStyle := GetWindowLong(WindowHandle, GWL_EXSTYLE); if ((ExStyle AND WS_EX_TOOLWINDOW) = 0) ..

← →
WED (2004-01-21 10:19) [25]

Гм. А не работает...
Сделал так:

function CheckStyle(AppWnd: HWND): Boolean;
var
WinStyle : LongInt;
begin
Result:=False;
WinStyle := GetWindowLong(AppWnd, GWL_STYLE);
if (WinStyle AND WS_VISIBLE) <> 0) AND ((WinStyle AND WS_CHILD) <> 0) then Result:=True;
end;

Так вот: видимость отлавилвается нормально, а дочернее или нет абсолютно пофиг. Проверял на нескольких программах... На том же Дельфи самом с окном кода программы.... Ощущение, что WS_CHILD у всех окон = 0. :(

← →
WED (2004-01-21 10:42) [26]

2 Юрий Зотов

Попробовал такой код ловушки... Тоже самое... У меня есть подозрение, что происходи конфликт двух (а может больше ловушек)... т.е. моей и еще каких-то программ... Например тот же PuntoSwitcher тоже ведь хук использует.... но только для клавиш... наверное... мда.. блин.

← →
AKul (2004-01-21 10:47) [27]

> WED © (21.01.04 10:42) [26]

Ты писал, что происходит ошибка
EAccess Violation....DTHook.dll....,
т.е. адресс кода в твоей DLL, где происходит ошибка, тебе выдается.
Найди этот адрес в твоей DLL и сопоставь с исходным кодом.

← →
WED (2004-01-21 10:53) [28]

Еще прикол: попробовал на двух других компах (тоже WinXP):
1. Два раза сернуть+развернуть окно проводника и система висит несколько секунд. Рабочий стол (Explorer) после этого падает и перезагружается.
2. Без проблем сворачивание и разворачивание сколько угодно раз окна проводника, но при попытке закрыть окно - сообщение об ошибке...
Кому-нть такие симптомы что-нть говорят? Лично мне, что проблемы с памятью... а вот что именно :(

2AKul - Щас буду пробовать...

← →
WED (2004-01-21 11:03) [29]

2AKul: Не вышло нифига :( Виснет зараза... Так что не получается узнать, да и адрес каждый раз разный.... один раз был FF63F23F,а второй FF63F15B... Отладчик дельфовский запустился, там пытаюсь перейти на этот адрес, в ответ получаю мат. :(

← →
AKul (2004-01-21 11:58) [30]

> WED © (21.01.04 11:03) [29]
> адрес каждый раз разный.... один раз был FF63F23F,а
> второй FF63F15B...

Это не адреса в DLL. Эти адреса, если мне не изменяет память, находятся в диапазоне системных данных (не вытесняемая память).
Проанализируй внимательнее сообщение, скорее всего, по этим адресам происходит запись, а тебе нужен адрес кода, в котором возникла ошибка (если конечно она возникает в теле твоей DLL).
Sorry, если что-то подзабыл.

← →
WED (2004-01-21 12:06) [31]

Других адресов там нет...
Если интересно, то вот http://siam-cat.chat.ru/img/error.JPG
скриншот ошибки.

Еще момент: заметил, что ошибку вызывает не та программа окно которой сворачиваю/разворачиваю, а другая.

← →
WED (2004-01-21 12:15) [32]

Вобщем научился я вызывать ошибку. Открываю проводник и меняю путь. Всё. Ошибка обеспечена.

Сначала вылетает это окно
http://siam-cat.chat.ru/img/error2.JPG
, а следом
http://siam-cat.chat.ru/img/error.JPG

← →
AKul (2004-01-21 12:36) [33]

Что-то мне помнится, что по умолчанию во все процессы меппируется только секция кода DLL.
У тебя же в хуке есть обращение к переменной, расположенной в секции данных
Result:= CallNextHookEx( GlobalData^.SysHook, Code, wParam, lParam); //стандартный обработчик
Следовательно, переменная GlobalData "правильная" только в адресном пространстве процесса, который загрузил эту DLL.
Тебе нужно сделать так, чтобы секция данных тоже меппировалась во все процессы. Тогда отпадет необходимость меппирования файла.
Это все относится к NT.
Кстати, почему ты именно использовал меппирование файла? Ведь под NT меппированные файлы находятся уже не в разделяемой памяти.
Хотя я могу ошибаться!

← →
WED (2004-01-21 12:52) [34]

Почему использовал? Потому что в примере так было.... Я ж говорил: всё содрано из примера, просто сам хук переделан.

Если ты объяснишь или ткнешь носом куда-нть где объяснят, как отмеппировать секцию данных тоже, буду признателен.

← →
Юрий Зотов (2004-01-21 13:20) [35]

> AKul © (21.01.04 12:36) [33]

> Следовательно, переменная GlobalData "правильная" только в
> адресном пространстве процесса, который загрузил эту DLL.

Нет, не так. Во всех "экземплярах" данных DLL эта переменная инициализируется по DLL_PROCESS_ATTACH одним и тем же адресом из страничной памяти системы (то есть, памяти разделяемой на уровне всей системы). Обратите внимание на первый параметр CreateFileMapping.

> нужно сделать так, чтобы секция данных тоже меппировалась во
> все процессы. Тогда отпадет необходимость меппирования файла.

Компилятор Delphi не поддерживает описателей а-ля "pragma public", поэтому сделать данные разделяемыми так легко не получится. Именно поэтому здесь и нужем механизм File Mapping"а - как раз он и обеспечивает глобальность данных. Этот споособ не раз проверен и работает он вполне нормально (да и с чего бы ему не работать, если он вполне легален и документирован).

← →
WED (2004-01-21 13:48) [36]

2 Юрий Зотов, AKul:
Уважаемые! Вы меня уже запутали. ;)
просьба возмите приведенный код. Протестируйте. Быстро ошибку получить можно либо открыв проводник и поменять текущую папку.

← →
AKul (2004-01-21 14:02) [37]

> Юрий Зотов © (21.01.04 13:20) [35]

> Во всех "экземплярах" данных DLL эта переменная
> инициализируется по DLL_PROCESS_ATTACH одним и тем же адресом
> из страничной памяти системы

Так и есть, но я имел в виду другое:
Переменная GlobalData есть переменная, которая описана в разделе глобальных переменных и в EXE файле она будет содержаться в секции неинициализируемых данных (bss кажется), которая неразделяемая между процессами (непромеппирована в них).
А теперь представьте, что она находиться по адресу address (именно переменная, а не ее значение) и инициализируется действительно правильным адресом для любого процесса. Что по Вашему произойдет, когда Hook вызовется в адресном пространстве другого процесса? где в таком случае будет находится сама переменная GlobalData (не ее значение), если секция данных непромеппирована в этот процесс? Ведь компилятор заменит строку GlobalDFata^.SysHook на что-то типа
mov eax,[address]; Правилен ли здесь адрес переменной
; GlobalDataдля другого процесса?
mov eax,[eax+смещение поля SysHook]

Зачем здесь нужем механизм File Mapping"а я знаю.
Этим вопросом я пытался подчеркнуть то, что если сама переменная GlobalData (именно переменная, ее адрес, а не значение!!!) доступна во всех процессах (без меппирования секции данных), почему бы тогда вместо этого указателя не использвать саму запись?

← →
AKul (2004-01-21 14:15) [38]

> Юрий Зотов © (21.01.04 13:20) [35]

> Компилятор Delphi не поддерживает описателей а-ля "pragma
> public", поэтому сделать данные разделяемыми так легко не
> получится.

А что мешает модифицировать описание секций в EXE-файле?

← →
pasha_golub (2004-01-21 15:14) [39]

function CheckStyle(AppWnd: HWND): Boolean; var WinStyle, ExStyle : LongInt; WindowOwner : HWND; begin WinStyle := GetWindowLong(WindowHandle, GWL_STYLE); ExStyle := GetWindowLong(WindowHandle, GWL_EXSTYLE); WindowOwner := GetWindow(WindowHandle, GW_OWNER); Result:= (WinStyle AND WS_VISIBLE) <> 0) AND ((WinStyle AND WS_CHILD) <> 0) AND (WindowOwner = 0) end;
Но в данном варианте, мы получим TRUE только для тех окон, которые есть на Taskbar"е. Например, у IDE Делфи 6 4 окна. 1 - окно application, второе - главное с меню, третье окно - юнита с кодом (Имеется в виду что наша программа запущена.), а получим true только для одного, для первого. Потому что все остальные есть суть дети.

← →
pasha_golub (2004-01-21 15:18) [40]

В догонку, 4 окно - это окно формы в режиме дизайна.

← →
Юрий Зотов (2004-01-21 16:11) [41]

> AKul © (21.01.04 14:02) [37]

Конечно, сама переменная GlobalData будет для каждого процесса своя и будет располагаться в его АП по своему собственному адресу. Но это и не важно, а важно лишь то, чтобы общим для всех процессов было ее содержимое GlobalData ^ и чтобы именно оно адресовало к разделяемым данным.

> AKul © (21.01.04 14:15) [38]

Это уже, скорее, из области реинжеиринга (как сейчас почему-то стало модно говорить). Ломать собственную программу, конечно, можно, а иногда даже и нужно, но в данном случае - зачем? Разве в ней есть что-то такое, что требует именно таких технологий? Вроде как, ничего особенного в ней нет.

> WED

Короче говоря, привожу реально работающий пример Shell Hook. В нем нет проверки на повторный запуск, но ее несложно добавить.

Это полный код DLL (код EXE см. в следующем посте).
library DLL; uses Windows, Messages; const MapID = "Global Hook Demo"; type PData = ^TData; TData = record AppWnd: HWND; OldHook: HHOOK end; var HMap: THandle = 0; Data: PData = nil; procedure DLLEntryPoint(dwReason: DWORD); stdcall; begin case dwReason of DLL_PROCESS_ATTACH: begin HMap := CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE, 0, SizeOf(TData), MapID); Data := MapViewOfFile(HMap, FILE_MAP_ALL_ACCESS, 0, 0, SizeOf(TData)) end; DLL_PROCESS_DETACH: begin UnMapViewOfFile(Data); CloseHandle(HMap) end end end; function ShellHook(Code: Integer; ParamW: WPARAM; ParamL: LPARAM): LRESULT; stdcall; begin if Code in [HSHELL_WINDOWCREATED, HSHELL_WINDOWDESTROYED, HSHELL_REDRAW] then SendMessage(Data^.AppWnd, WM_USER + 100, ParamW, Code); Result := CallNextHookEx(Data^.OldHook, Code, ParamW, ParamL) end; function SetShellHook(Wnd: HWND): BOOL; stdcall; begin if Data <> nil then begin Data^.AppWnd := Wnd; Data^.OldHook := SetWindowsHookEx(WH_SHELL, @ShellHook, HInstance, 0); Result := Data^.OldHook <> 0 end else Result := False end; function RemoveShellHook: BOOL; stdcall; begin Result := UnhookWindowsHookEx(Data^.OldHook) end; exports SetShellHook, RemoveShellHook; begin if DLLProc = nil then DLLProc := @DLLEntryPoint; DLLEntryPoint(DLL_PROCESS_ATTACH) end.

← →
Юрий Зотов (2004-01-21 16:16) [42]

А это код главной формы EXE (код DPR - стандартный). Текст DFM к ней см. в следующем посте.
unit AppUnit; interface uses Windows, Messages, Classes, Controls, Forms, StdCtrls; type TAppMainForm = class(TForm) WndList: TListBox; ClearButton: TButton; procedure ClearButtonClick(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); private procedure WMUserPlus100(var Message: TMessage); message WM_USER + 100; protected procedure CreateWnd; override; end; var AppMainForm: TAppMainForm; implementation {$R *.DFM} const DLLName = "DLL.dll"; function SetShellHook(Wnd: HWND): BOOL; stdcall; external DLLName name "SetShellHook"; function RemoveShellHook: BOOL; stdcall; external DLLName name "RemoveShellHook"; function GetWndText(Wnd: HWND): string; var L: Integer; begin L := GetWindowTextLength(Wnd) + 1; if L > 1 then begin SetLength(Result, L); GetWindowText(Wnd, @Result[1], L); end else Result := "???" end; { TAppMainForm } procedure TAppMainForm.WMUserPlus100(var Message: TMessage); var I: Integer; begin case Message.LParam of HSHELL_WINDOWCREATED: WndList.Items.AddObject(GetWndText(Message.WParam), TObject(Message.WParam)); HSHELL_WINDOWDESTROYED: begin I := WndList.Items.IndexOfObject(TObject(Message.WParam)); if I >= 0 then WndList.Items.Delete(I) end; HSHELL_REDRAW: begin I := WndList.Items.IndexOfObject(TObject(Message.WParam)); if I >= 0 then WndList.Items[I] := GetWndText(Message.WParam) end end end; procedure TAppMainForm.ClearButtonClick(Sender: TObject); begin WndList.Clear end; procedure TAppMainForm.CreateWnd; begin inherited; if not SetShellHook(Handle) then MessageBox(Handle, "Unable to set hook", PChar(Application.Title), MB_OK or MB_ICONHAND) end; procedure TAppMainForm.FormClose(Sender: TObject; var Action: TCloseAction); begin if not RemoveShellHook then MessageBox(Handle, "Unable to remove hook", PChar(Application.Title), MB_OK or MB_ICONHAND) end; end.

← →
Юрий Зотов (2004-01-21 16:17) [43]

И, наконец, текст DFM.
object AppMainForm: TAppMainForm Left = 298 Top = 140 BorderIcons = [biSystemMenu, biMinimize] BorderStyle = bsSingle Caption = "AppMainForm" ClientHeight = 456 ClientWidth = 583 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -13 Font.Name = "MS Sans Serif" Font.Style = [] OldCreateOrder = False OnClose = FormClose PixelsPerInch = 120 TextHeight = 16 object WndList: TListBox Left = 9 Top = 8 Width = 565 Height = 405 ItemHeight = 16 TabOrder = 0 end object ClearButton: TButton Left = 254 Top = 424 Width = 75 Height = 25 Caption = "Clear" TabOrder = 1 OnClick = ClearButtonClick end end

← →
WED (2004-01-22 10:43) [44]

2 Юрий Зотов:

В твоем коде в DLL в строке
if DLLProc = nil then

ругается:

Not enough actual parameters

Вот так.

← →
pasha_golub (2004-01-22 10:46) [45]

← →
WED (2004-01-22 10:56) [46]

Попробовал убрать эту строку, т.е. сделать вот так:
begin
DLLProc := @DLLEntryPoint;
DLLEntryPoint(DLL_PROCESS_ATTACH);
end.

Результат: При открытие какого-нть окна всё ок. А при закрытии
RunTime Error

← →
WED (2004-01-22 10:58) [47]

гм. Ошибся - при создании окна (при запуске какой-нть проги) тоже ошибка...

← →
WED (2004-01-22 14:12) [48]

2 Юрий Зотов: Не могли бы Вы, уважаемый, глянуть в чем проблема?

← →
Юрий Зотов (2004-01-22 14:28) [49]

> WED © (22.01.04 10:43) [44]
> WED © (22.01.04 10:56) [46]
> WED © (22.01.04 10:58) [47]

Код писался уже давно, в D5, и там компилировался без проблем. Компилятор D7 (только что проверил) действительно ругается на строку if DLLProc = nil then. Посмотрел в исходники. Причина в том, что Borland изменила объявление переменной DLLProc - раньше она была просто Pointer, а теперь стала TDLLProc (объявления TDLLProc в исходниках нет, но и так ясно, что это процедурный тип для DLLEntryPoint). Кстати, интересно, что в справке D7 по-прежнему написано - Pointer.

Решение очевидно - операция взятия адреса. Всего один символ:
if @DLLProc = nil then
после чего все компилируется без проблем.

А также без проблем запускается, без проблем работает и без проблем завершается. Только что проверил (D7, W2K Server).

А до этого проверял при разработке этого примера (D5, W98, ME, NT4+SP6, W2K). А после его первой публикации (здесь же, года два назад) он проверялся уже не одним человеком (а может, и не одним десятком человек). И тоже без вопросов (правда, пара-тройка человек все же ругалась, но потом выяснилось, что они сначала изменили код, а потом начали говорить, что он не работает).

Поэтому очень похоже, что либо Вы тоже изменили код, либо что-то у Вас не так в системе.

> All

Просьба к тем, у кого установлена XP - проверьте код. Кто его знает, может быть, он и правда несовместим с XP. Хотя и слабо в это верится, но чем черт не шутит...

Почему не работает следующий код... Найти похожие ветки