Текущий архив: 2004.02.06;
Скачать: CL | DM;

Вниз

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

← →
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 © (22.01.04 10:43) [44]
Хм, странно.

---

← →
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. Хотя и слабо в это верится, но чем черт не шутит...

---

Страницы: 1 2 вся ветка

Текущий архив: 2004.02.06;
Скачать: CL | DM;

Наверх

Память: 0.57 MB
Время: 0.021 c