Помощь - Поиск - Пользователи - Календарь
Полная версия: Как определить откуда был запущен процесс?
Форум «Всё о Паскале» > Современный Паскаль и другие языки > Делфи
Snake_B

type TModuleArray = array of TModuleEntry32;

.............

function GetModulesListByProcessId(ProcessId : Cardinal) : TModuleArray;
var
hSnapshot : THandle;
lpme : TModuleEntry32;
procedure AddModuleToList;
begin
SetLength(Result,High(Result)+2);
Result[high(Result)]:=lpme;
end;
begin
SetLength(Result,0);
hSnapshot:=CreateToolhelp32Snapshot(TH32CS_SNAPMODULE,ProcessId);
if hSnapshot=-1 then RaiseLastWin32Error;
lpme.dwSize:=SizeOf(lpme);
if Module32First(hSnapshot,lpme) then
begin
AddModuleToList;
while Module32Next(hSnapshot,lpme) do AddModuleToList;
end;
end;


function GetWindowPatch(Wnd: hWnd): string; // Нахождение пути к ехе по заголовку окна...
var
i: integer;
modarr : TModuleArray;
Pid: Cardinal;
begin
result:='Null';
GetWindowThreadProcessId(Wnd,@Pid);
modarr:=GetModulesListByProcessId(Pid); result:='Null';
for i:=0 to High(modarr) do
begin
if Integer(modarr[i].modBaseAddr)=$400000 then
begin
result:=modarr[i].szExePath; break;
end;
end;
end;


procedure TFormWinHide.SearchWindow; // Поиск окон...
VAR
searchTm: boolean;
searchTmInt, i, OldWC, OldWCH: integer;
name, TmpStr, Str: string;
Tmp: TMenuItem;
Wnd: hWnd;
buff: ARRAY [0..127] OF Char;
begin
OldWC:=WinCount;
WinCount:=0;
OldWCH:=WinCountH;
WinCountH:=0;
// Считаем количество окон..
Wnd:= GetWindow(Handle, gw_HWndFirst); WHILE Wnd <> 0 DO BEGIN IF (Wnd <> Application.Handle) THEN BEGIN
if IsWindowVisible(Wnd) then begin
GetWindowText(Wnd, buff, sizeof(buff)); TmpStr:=StrPas(buff);
if (GetWindowText(Wnd, buff, sizeof(buff)) = 0) then
begin name:=GetWindowPatch(Wnd); if (name<>'Null') then TmpStr:=name; end;

if (TmpStr<>'') and (TmpStr<>paramStr(0)) then begin WinCount:=WinCount+1; END;
end else begin
WinCountH:=WinCountH+1;
end; end; Wnd := GetWindow(Wnd, gw_hWndNext); END; }


1) вот... примерно так... procedure TFormWinHide.SearchWindow вызывается таймером каждые 100 мс...
идет утечка памяти... не могу разабраться откуда...

2) а можно не по таймеру окна искать, а по системному сообщению (изменилось общее количество окон или одно из окон изменило статус с "IsWindowVisible(Wnd)" и наоборот)?
если да, то как...

3) Ну это к другой теме, но спрошу здесь же... в контекстном меню задаю для пункта hint, ноль эмоций.. что надо сделать, чтобы он там отображался?
volvo
Цитата
идет утечка памяти... не могу разабраться откуда...
Вопрос на засыпку: с чего ты решил про утечку? Запустил приложение, оно отработало больше 7 минут, после первых 10 секунд работы максимальный объем используемой памяти не увеличился.

Цитата
а можно не по таймеру окна искать, а по системному сообщению
По таймеру гораздо проще, но можно ставить хук на CreateProcess/ZwCreateProcess, если хочешь - спроси у Гугля...

Цитата
в контекстном меню задаю для пункта hint, ноль эмоций.. что надо сделать, чтобы он там отображался?
Читать здесь: http://delphi.about.com/od/vclusing/a/menuitemhints.htm
Snake_B
Цитата(volvo @ 8.08.2008 3:30) *

Вопрос на засыпку: с чего ты решил про утечку? Запустил приложение, оно отработало больше 7 минут, после первых 10 секунд работы максимальный объем используемой памяти не увеличился.

По таймеру гораздо проще, но можно ставить хук на CreateProcess/ZwCreateProcess, если хочешь - спроси у Гугля...

Читать здесь: http://delphi.about.com/od/vclusing/a/menuitemhints.htm


про утечку... диспечер задач, до запуска - выделение памяти - 842 мб
через 10 секунд - 890 мб
через 20 - 920
ну и так далее (в первый раз, пока сообразил, 1700 мб было )...
но в процессах память не растет ни у bds, ни у программы...
при запуске не из делфи, а просто программы таже фигня...
при закрытии программы память падает до значения перед запуском...
// name:=GetWindowPatch(Wnd);

отключаю эту строку, всё нормально...
Win XP sp2, delphi 2005...

проще, так проще...

англицкий будем учить :-)
Snake_B
Цитата(Snake_B @ 8.08.2008 4:31) *

англицкий будем учить :-)


там про главное меню... сделела не много по другому... может кому пригодится...
ну и за одно может кто скажет де ошибки =)

unit main;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Menus, StdCtrls;

type
TForm1 = class(TForm)
PopupMenu1: TPopupMenu;
nmuThis: TMenuItem;
mnuIs: TMenuItem;
mnuA: TMenuItem;
mnuTest: TMenuItem;
procedure FormCreate(Sender: TObject);
private
procedure ActivateHintNOW( x,y: Integer);
procedure AppHint(Sender: TObject);
public
end;

var
Form1: TForm1; var hintWnd: THintWindow;

implementation

{$R *.dfm}

procedure TForm1.ActivateHintNOW( x,y: Integer);
var
rect: TRect;
Hintlnfo: THintInfo;
begin
hintWnd.Color:=Application.HintColor;
rect := hintWnd.CalcHintRect( Screen.Width, Application.Hint, nil);
rect.Left := rect.Left+x;
rect.Right := rect.Right+x;
rect.Top := rect.Top + y;
rect.Bottom := rect.Bottom + y;
hintWnd.ActivateHint( rect, Application.Hint);
end;


procedure TForm1.AppHint(Sender: TObject);
begin
if Application.Hint = '' then
begin
hintwnd.releasehandle;
exit;
end;
ActivateHintNOW(Mouse.CursorPos.X + 16, Mouse.CursorPos.Y + 16);
end;


procedure TForm1.FormCreate(Sender: TObject);
begin
hintwnd:= THintWindow.create(self);
Application.OnHint := AppHint;
self.PopupMenu := PopupMenu1;
end;

end.


ну вопрос про память в силе..
volvo
Хэндлы освобождать не пробовал?

function GetModulesListByProcessId(ProcessId : Cardinal) : TModuleArray;
var
hSnapshot : THandle;
lpme : TModuleEntry32;
procedure AddModuleToList;
begin
SetLength(Result,High(Result)+2);
Result[high(Result)]:=lpme;
end;
begin
SetLength(Result,0);
hSnapshot:=CreateToolhelp32Snapshot(TH32CS_SNAPMODULE,ProcessId);

if hSnapshot=-1 then RaiseLastWin32Error;
lpme.dwSize:=SizeOf(lpme);
if Module32First(hSnapshot,lpme) then begin
AddModuleToList;
while Module32Next(hSnapshot,lpme) do AddModuleToList;
end;

CloseHandle(hSnapshot); // <--- Вот так, например ...
end;


?

Кстати, в конце GetWindowPatch() можно было бы и SetLength(modarr, 0) добавить, на всякий случай.
Snake_B
Цитата(volvo @ 8.08.2008 21:06) *

Хэндлы освобождать не пробовал?

Кстати, в конце GetWindowPatch() можно было бы и SetLength(modarr, 0) добавить, на всякий случай.


спасиба... ввиду того что самоучка - не которые простые моменты для меня неизвестны...

а вот сама функция GetModulesListByProcessId(ProcessId : Cardinal) целиком скопирована из DRKB...
там про хэндлы тоже видать не знали wacko.gif
volvo
Цитата
а вот сама функция GetModulesListByProcessId(ProcessId : Cardinal) целиком скопирована из DRKB...
А в DRKB она была включена с одного из программерских форумов, там написано с какого... А запостил ее туда один из участников, который по какой-то причине пропустил эту строчку... А автор вопроса, на который он отвечал, не посмотрел сразу, что приложение "забирает" память, и не спросил, "почему", вот тебе и недочет... Все люди, все ошибаются...
Snake_B
Цитата(volvo @ 9.08.2008 3:46) *

А в DRKB она была включена с одного из программерских форумов, там написано с какого... А запостил ее туда один из участников, который по какой-то причине пропустил эту строчку... А автор вопроса, на который он отвечал, не посмотрел сразу, что приложение "забирает" память, и не спросил, "почему", вот тебе и недочет... Все люди, все ошибаются...


извиняюсь конечно за оффтоп...
но в принципе я их понимаю... уже в парочке программ эту функцию использовал..
но там она один раз вызывалась...
Snake_B
вот тут парочку вопросов появилось... по теме где то близко...

procedure WinExeToBMP(patch: string; Image: TbitMap); // Извлечение иконки из ехе файла...
Var
Icon:HICON;
Begin
if fileexists(patch) then begin
Icon:=ExtractIcon(hInstance, pchar(patch), 0);
If ICON > 0 then With Image do Begin
Height:=32;
Width:=32;
Canvas.Brush.Color:=clBtnFace;
Canvas.FillRect(Rect(0,0,32,32));
DrawIcon(Canvas.Handle, 0, 0, Icon);
End;
end;
End;


вот примерно такая функция... иногда выдает ошибку "EOutOfResources" и сообщение - "Не хватает ресурсов для выполнения операции" (примерно, точно не помню)....
через try except не ловится... т.е. он отрабатывает, но уже после системного сообщения...
куда тут копать хоть?
volvo
Цитата
куда тут копать хоть?
В MSDN: ExtractIcon Function

Цитата
Remarks
This function is not supported for icons in 16-bit executables and DLLs.
You must destroy the icon handle returned by ExtractIcon by calling the DestroyIcon function.
У тебя этого не делается, вот тебе и утечка.
Snake_B
Цитата(volvo @ 21.08.2008 5:52) *

В MSDN: ExtractIcon Function

У тебя этого не делается, вот тебе и утечка.


точно... из-за этого... спасибо...
Гость
Как пользоваться этой функцией????

Цитата
function GetModulesListByProcessId(ProcessId : Cardinal) : TModuleArray; var hSnapshot : THandle; lpme : TModuleEntry32; procedure AddModuleToList; begin SetLength(Result,High(Result)+2); Result[high(Result)]:=lpme; end; begin SetLength(Result,0); hSnapshot:=CreateToolhelp32Snapshot(TH32CS_SNAPMODULE,ProcessId); if hSnapshot=-1 then RaiseLastWin32Error; lpme.dwSize:=SizeOf(lpme); if Module32First(hSnapshot,lpme) then begin AddModuleToList; while Module32Next(hSnapshot,lpme) do AddModuleToList; end; CloseHandle(hSnapshot); // <--- Вот так, например ... end;

volvo
В самом первом сообщении темы был приведен пример использования.
Это текстовая версия — только основной контент. Для просмотра полной версии этой страницы, пожалуйста, нажмите сюда.