A
Another_eYes
Unregistered / Unconfirmed
GUEST, unregistred user!
代码中use到的DelayLsts代码在这里：http://www.delphibbs.com/delphibbs/dispq.asp?lid=3262960
unit中导出的过程/函数说明：
procedure KillApp(WndCapt, exeFileName: string);
按exe全路径文件名杀死对方进程，WndCapt为对方进程主窗口的Caption, 如果<>''则对方进程在被杀时有机会执行OnClose（可以正常退出），如果=''则被强杀。
function FindAppInfo(WndCapt, exeFileName: string; var WndHandle, ProcessId, ThreadId: THandle): Boolean;
根据文件名和主窗口caption查找该进程的各种Handle(内部使用)
function AttachMonitor(WndCapt, exeFileName: string; var Handle: Cardinal; Notification, Context: Pointer): Boolean;
监控某个进程是否结束，Handle为返回的句柄（可以用于DettachMonitor），Notification为在对方进程结束时的通知回调函数，Context为自定义传递给回调函数的参数。回调函数定义为：
procedure (Context: Pointer); 或者 procedure of object;
procedure DettachMonitor(var Handle: Cardinal; KillProcess: Boolean);
去除对某个进程的监控，Handle为AttachMonitor返回的Handle, KillProcess为是否在去除的同时杀死对方进程。
function LaunchApp(exeFileName, CmdParams: string; MonitorHandle: PHandle; Notification, Context: Pointer): Boolean;
运行某个exe程序，可以同时对其进行监控，如果MonitorHandle不为nil时将对对方进程进行监控并返回监控句柄到MonitorHandle指向的变量。如果MonitorHandle=nil其效果和winexec一样。
function LocatePathFromDesktopLnk(SubFile: string): string;
在桌面快捷方式中查找包含某个子文件的目录，SubFile为相对路径文件名，返回值为路径。比如：LocatePathFromDesktopLnk('ACDSee6.chm') （ACDSee6.chm为ACDSee 6.0的帮助文件）将返回：C:/Program Files/ACD Systems/ACDSee/6.0/ （假如你系统安装了ACDSee 6.0的话）
function GetProgramFilePath(SubPath: string): string;
获取操作系统program files目录，比如：C:/Program Files/
procedure CreateShortCut(AName, AFileName: string; ToDeskTop, ToStartMenu, ToDestPath: Boolean);
创建快捷方式，ToDeskTop为创建到桌面，ToStartMenu为创建到开始菜单，ToDestPath为创建到AFileName所在目录
unit AppUtils;
interface
uses
Windows, messages, SysUtils, Classes, TlHelp32, DelayLists, shlObj, ActiveX,
ComObj;
const
CSIDL_PROGRAM_FILES = $28;
type
TAppMonitorThread = class(TThread)
protected
procedure Execute; override;
public
Wnd: HWnd;
PrcsId, ThrdId: THandle;
CallBack: TMethod;
WaitEvents: array [0..1] of THandle;
InstAddr: Pointer;
constructor Create(Wnd: HWnd; ProcessId, ThreadId: THandle; var Monitor: TAppMonitorThread;
CallbackProc: Pointer; CallbackContext: Pointer);
constructor CreateWithProcess(const Info: TProcessInformation; var Monitor: TAppMonitorThread;
CallbackProc: Pointer; CallbackContext: Pointer);
procedure StopApp;
procedure StopMonitor;
end;
procedure KillApp(WndCapt, exeFileName: string);
function FindAppInfo(WndCapt, exeFileName: string; var WndHandle, ProcessId, ThreadId: THandle): Boolean;
function AttachMonitor(WndCapt, exeFileName: string; var Handle: Cardinal; Notification, Context: Pointer): Boolean;
procedure DettachMonitor(var Handle: Cardinal; KillProcess: Boolean);
function LaunchApp(exeFileName, CmdParams: string; MonitorHandle: PHandle; Notification, Context: Pointer): Boolean;
function LocatePathFromDesktopLnk(SubFile: string): string;
function GetProgramFilePath(SubPath: string): string;
procedure CreateShortCut(AName, AFileName: string; ToDeskTop, ToStartMenu, ToDestPath: Boolean);
implementation
function CreateMonitor(Wnd: HWnd; ProcessId, ThreadId: THandle; var Monitor: TAppMonitorThread;
CallbackProc: Pointer; CallbackContext: Pointer): Boolean;
var
t: TAppMonitorThread;
begin
result := false;
try
t := TAppMonitorThread.Create(Wnd, ProcessId, ThreadId, Monitor, CallbackProc, CallbackContext);
result := t = Monitor;
except
end;
end;
procedure KillApp(WndCapt, exeFileName: string);
var
Wnd, ProcessId, ThreadId: THandle;
Monitor: TAppMonitorThread;
begin
if FindAppInfo(WndCapt, exeFileName, wnd, processid, threadid) then
if CreateMonitor(Wnd, ProcessId, threadid, Monitor, nil, nil) then
Monitor.StopApp;
end;
type
TEnumWndInfo = record
Caption: string;
Wnd: HWND;
ProcessId, ThreadId: THandle;
end;
PEnumWndInfo = ^TEnumWndInfo;
function FindWindowWithCaption(AWnd: HWND; Info: PEnumWndInfo): LongBool; stdcall;
var
str: string;
Id, Id2: THandle;
begin
result := True;
if info.Caption <> '' then
begin
setlength(str, length(info.Caption)+1);
GetWindowText(AWnd, pchar(str), length(str));
if stricomp(pchar(str), pchar(info.Caption)) = 0 then
begin
Id2 := GetWindowThreadProcessId(AWnd, Id);
if Id = Info.ProcessId then
begin
result := false;
info.Wnd := AWnd;
Info.ThreadId := Id2;
end;
end;
end;
end;
function getProcessModule(PId: Cardinal; ModuleName: string): Boolean;
var
snp: Thandle;
nm, ps, nm1, nm2: string;
me32: TModuleEntry32;
begin
result := false;
me32.dwSize := sizeof(me32);
nm := extractfilename(ModuleName);
ps := extractfilepath(modulename);
snp := CreateToolHelp32SnapShot(TH32CS_SNAPMODULE, PId);
if snp <> 0 then
try
if Module32First(snp, me32) then
repeat
nm1 := me32.szExePath;
nm2 := me32.szModule;
if nm2 = copy(nm1, length(nm1)-length(nm2)+1, length(nm2)) then
result := (comparetext(modulename, nm1) = 0)
else begin
if (nm1 <> '') and (nm1[length(nm1)] <> '/') then nm1 := nm1 + '/';
result := comparetext(ps, nm1) = 0;
end;
until result or not Module32Next(snp, me32);
finally
closehandle(snp);
end;
end;
function FindAppInfo(WndCapt, exeFileName: string; var WndHandle, ProcessId, ThreadId: THandle): Boolean;
var
Snp: THandle;
pe32: TProcessEntry32;
me32: TModuleEntry32;
ps, ps1, nm, nm1: string;
Info: TEnumWndInfo;
begin
result := false;
nm := extractfilename(exefilename);
ps := extractfilepath(exefilename);
pe32.dwSize := sizeof(pe32);
snp := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
if snp <> 0 then
try
if Process32First(snp, pe32) then
repeat
nm1 := pe32.szExeFile;
result := (comparetext(exeFileName, nm1)=0) or ((comparetext(nm, nm1)=0) and getprocessmodule(pe32.th32ProcessID, exeFileName));
if result then
ProcessId := pe32.th32ProcessID;
until result or not process32Next(snp, pe32);
finally
closehandle(snp);
end;
if result then
begin
info.Caption := WndCapt;
info.Wnd := 0;
info.ProcessId := ProcessId;
info.ThreadId := 0;
enumwindows(@FindWindowWithCaption, Integer(@Info));
WndHandle := info.Wnd;
ThreadId := info.ThreadId;
end;
end;
function AttachMonitor(WndCapt, exeFileName: string; var Handle: Cardinal; Notification, Context: Pointer): Boolean;
var
h1, h2, h3: Thandle;
begin
result := findappinfo(wndcapt, exefilename, h1, h2, h3);
if result then
result := createmonitor(h1, h2, h3, TAppMonitorThread(Handle), Notification, Context);
end;
function LaunchApp(exeFileName, CmdParams: string; MonitorHandle: PHandle; Notification, Context: Pointer): Boolean;
var
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
ps, cmd: string;
begin
if CmdParams = '' then
cmd := ''
else begin
cmd := '"'+exeFileName+'" '+CmdParams;
exeFileName := '';
end;
ps := extractfilepath(exeFileName);
fillchar(StartupInfo, sizeof(TStartupInfo), 0);
fillchar(ProcessInfo, sizeof(ProcessInfo), 0);
StartupInfo.cb := sizeof(TStartupInfo);
result := CreateProcess(pchar(exeFileName), pchar(cmd), nil, nil, false, 0, nil, pchar(ps), startupinfo, ProcessInfo);
if result and (MonitorHandle <> nil) then
TAppMonitorThread.CreateWithProcess(ProcessInfo, TAppMonitorThread(MonitorHandle^), Notification, Context);
end;
procedure DettachMonitor(var Handle: Cardinal; KillProcess: Boolean);
begin
try
try
if KillProcess and (Handle <> 0) then
TAppMonitorThread(Handle).StopApp
else
TAppMonitorThread(Handle).StopMonitor;
finally
Handle := 0;
end;
except
end;
end;
{ TAppMonitorThread }
constructor TAppMonitorThread.Create(Wnd: HWnd; ProcessId, ThreadId: THandle; var Monitor: TAppMonitorThread;
CallbackProc, CallbackContext: Pointer);
begin
Self.Wnd := Wnd;
PrcsId := ProcessId;
ThrdId := ThreadId;
Callback.Code := CallbackProc;
Callback.Data := CallbackContext;
Waitevents[0] := CreateEvent(nil, false, false, nil);
waitevents[1] := OpenProcess(PROCESS_ALL_ACCESS, false, PrcsId);
InstAddr := @Monitor;
Monitor := Self;
inherited Create(True);
end;
constructor TAppMonitorThread.CreateWithProcess(const Info: TProcessInformation;
var Monitor: TAppMonitorThread; CallbackProc, CallbackContext: Pointer);
begin
PrcsId := Info.dwProcessId;
ThrdId := Info.dwThreadId;
Callback.Code := CallbackProc;
Callback.Data := CallbackContext;
Waitevents[0] := CreateEvent(nil, false, false, nil);
waitevents[1] := Info.hProcess;
closehandle(Info.hThread);
InstAddr := @Monitor;
Monitor := Self;
inherited Create(True);
end;
type
TCallbackProc = procedure of object;
procedure TAppMonitorThread.Execute;
begin
FreeOnTerminate := False;
try
waitformultipleobjects(2, @WaitEvents, false, INFINITE);
except
end;
closehandle(WaitEvents[0]);
closehandle(WaitEvents[1]);
if callback.Code <> nil then
try
TCallbackProc(Callback);
except
end;
if InstAddr <> nil then
PInteger(InstAddr)^ := 0;
Terminate;
DelayRelease(self);
end;
procedure TAppMonitorThread.StopApp;
var
Tick: Cardinal;
begin
try
InstAddr := nil;
Tick := GetTickCount;
if Wnd <> 0 then
begin
postmessage(wnd, WM_CLOSE, 0, 0);
while not Terminated and (GetTickCount - Tick < 2000) do
sleep(1);
end;
if not Terminated then
begin
if ThrdId <> 0 then
begin
Tick := GetTickCount;
postthreadmessage(thrdid, WM_QUIT, 0, 0);
while not Terminated and (GetTickCount - Tick < 200) do
sleep(1);
end;
if not Terminated then
TerminateProcess(PrcsId, 0);
end;
except
end;
end;
procedure TAppMonitorThread.StopMonitor;
begin
try
InstAddr := nil;
SetEvent(WaitEvents[0]);
except
end;
end;
function LocatePathFromDesktopLnk(SubFile: string): string;
var
LnkPs: array [0..MAX_PATH] of Char;
ExePs: array [0..MAX_PATH] of Char;
LnkName: string;
Dt: TWin32FindData;
FindHandle: THandle;
Obj: IUnknown;
sLnk: IShellLink;
pFile: IPersistFile;
ws: widestring;
tmp: string;
function OpenLnk(Name: WideString): Boolean;
var
fdt: TWin32FindData;
begin
result := pFile.Load(PWideChar(Name), STGM_READ or STGM_SHARE_DENY_NONE) = S_OK;
if result then
begin
result := sLnk.GetPath(@ExePs, MAX_PATH, fdt, 0) = NOERROR;
if result then
result := fileexists(extractfilepath(exeps)+subfile);
end;
end;
begin
result := '';
if shgetspecialfolderpath(0, @LnkPs, CSIDL_DESKTOPDIRECTORY, false) then
begin
LnkName := LnkPs+'/*.lnk';
FindHandle := FindFirstFile(PChar(LnkName), dt);
if FindHandle <> INVALID_HANDLE_VALUE then
try
Obj := CreateComObject(CLSID_ShellLink);
sLnk := Obj as IShellLink;
pFile := Obj as IPersistFile;
repeat
tmp := LnkPs;
tmp := tmp +'/'+dt.cFileName;
ws := tmp;
if openlnk(ws) then
begin
result := extractfilepath(exeps);
exit;
end;
until not findnextfile(findhandle, dt);
finally
windows.FindClose(FindHandle);
pFile := nil;
sLnk := nil;
Obj := nil;
end;
end;
end;
function GetProgramFilePath(SubPath: string): string;
var
ps: array [0..MAX_PATH] of Char;
begin
if shgetspecialfolderpath(0, @Ps, CSIDL_PROGRAM_FILES, false) then
begin
result := ps;
result := result+'/'+subpath
end
else result := '';
end;
procedure CreateShortCut(AName, AFileName: string; ToDeskTop, ToStartMenu, ToDestPath: Boolean);
var
MyObject : IUnknown;
MySLink : IShellLink;
MyPFile : IPersistFile;
WFileName : WideString;
ps: array [0..MAX_PATH] of Char;
path: string;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
with MySLink do begin
//SetArguments('C:/AUTOEXEC.BAT');
SetPath(PChar(AFileName));
SetWorkingDirectory(PChar(ExtractFilePath(AFileName)));
end;
if ToDestPath then
begin
WFileName := extractfilepath(AFileName)+AName+'.lnk';
MyPFile.Save(PWChar(WFileName),False);
end;
if ToDeskTop then
if shgetspecialfolderpath(0, @Ps, CSIDL_DESKTOPDIRECTORY, false) then
begin
path := ps;
path := path+'/'+AName+'.lnk';
wfilename := path;
MyPFile.Save(PWChar(WFileName), False);
end;
if ToStartMenu and shgetspecialfolderpath(0, @ps, CSIDL_PROGRAMS, false) then
begin
path := ps;
path := path+'/'+AName+'.lnk';
wfilename := path;
mypfile.Save(pwchar(wfilename), false);
end;
end;
end.
unit中导出的过程/函数说明：
procedure KillApp(WndCapt, exeFileName: string);
按exe全路径文件名杀死对方进程，WndCapt为对方进程主窗口的Caption, 如果<>''则对方进程在被杀时有机会执行OnClose（可以正常退出），如果=''则被强杀。
function FindAppInfo(WndCapt, exeFileName: string; var WndHandle, ProcessId, ThreadId: THandle): Boolean;
根据文件名和主窗口caption查找该进程的各种Handle(内部使用)
function AttachMonitor(WndCapt, exeFileName: string; var Handle: Cardinal; Notification, Context: Pointer): Boolean;
监控某个进程是否结束，Handle为返回的句柄（可以用于DettachMonitor），Notification为在对方进程结束时的通知回调函数，Context为自定义传递给回调函数的参数。回调函数定义为：
procedure (Context: Pointer); 或者 procedure of object;
procedure DettachMonitor(var Handle: Cardinal; KillProcess: Boolean);
去除对某个进程的监控，Handle为AttachMonitor返回的Handle, KillProcess为是否在去除的同时杀死对方进程。
function LaunchApp(exeFileName, CmdParams: string; MonitorHandle: PHandle; Notification, Context: Pointer): Boolean;
运行某个exe程序，可以同时对其进行监控，如果MonitorHandle不为nil时将对对方进程进行监控并返回监控句柄到MonitorHandle指向的变量。如果MonitorHandle=nil其效果和winexec一样。
function LocatePathFromDesktopLnk(SubFile: string): string;
在桌面快捷方式中查找包含某个子文件的目录，SubFile为相对路径文件名，返回值为路径。比如：LocatePathFromDesktopLnk('ACDSee6.chm') （ACDSee6.chm为ACDSee 6.0的帮助文件）将返回：C:/Program Files/ACD Systems/ACDSee/6.0/ （假如你系统安装了ACDSee 6.0的话）
function GetProgramFilePath(SubPath: string): string;
获取操作系统program files目录，比如：C:/Program Files/
procedure CreateShortCut(AName, AFileName: string; ToDeskTop, ToStartMenu, ToDestPath: Boolean);
创建快捷方式，ToDeskTop为创建到桌面，ToStartMenu为创建到开始菜单，ToDestPath为创建到AFileName所在目录
unit AppUtils;
interface
uses
Windows, messages, SysUtils, Classes, TlHelp32, DelayLists, shlObj, ActiveX,
ComObj;
const
CSIDL_PROGRAM_FILES = $28;
type
TAppMonitorThread = class(TThread)
protected
procedure Execute; override;
public
Wnd: HWnd;
PrcsId, ThrdId: THandle;
CallBack: TMethod;
WaitEvents: array [0..1] of THandle;
InstAddr: Pointer;
constructor Create(Wnd: HWnd; ProcessId, ThreadId: THandle; var Monitor: TAppMonitorThread;
CallbackProc: Pointer; CallbackContext: Pointer);
constructor CreateWithProcess(const Info: TProcessInformation; var Monitor: TAppMonitorThread;
CallbackProc: Pointer; CallbackContext: Pointer);
procedure StopApp;
procedure StopMonitor;
end;
procedure KillApp(WndCapt, exeFileName: string);
function FindAppInfo(WndCapt, exeFileName: string; var WndHandle, ProcessId, ThreadId: THandle): Boolean;
function AttachMonitor(WndCapt, exeFileName: string; var Handle: Cardinal; Notification, Context: Pointer): Boolean;
procedure DettachMonitor(var Handle: Cardinal; KillProcess: Boolean);
function LaunchApp(exeFileName, CmdParams: string; MonitorHandle: PHandle; Notification, Context: Pointer): Boolean;
function LocatePathFromDesktopLnk(SubFile: string): string;
function GetProgramFilePath(SubPath: string): string;
procedure CreateShortCut(AName, AFileName: string; ToDeskTop, ToStartMenu, ToDestPath: Boolean);
implementation
function CreateMonitor(Wnd: HWnd; ProcessId, ThreadId: THandle; var Monitor: TAppMonitorThread;
CallbackProc: Pointer; CallbackContext: Pointer): Boolean;
var
t: TAppMonitorThread;
begin
result := false;
try
t := TAppMonitorThread.Create(Wnd, ProcessId, ThreadId, Monitor, CallbackProc, CallbackContext);
result := t = Monitor;
except
end;
end;
procedure KillApp(WndCapt, exeFileName: string);
var
Wnd, ProcessId, ThreadId: THandle;
Monitor: TAppMonitorThread;
begin
if FindAppInfo(WndCapt, exeFileName, wnd, processid, threadid) then
if CreateMonitor(Wnd, ProcessId, threadid, Monitor, nil, nil) then
Monitor.StopApp;
end;
type
TEnumWndInfo = record
Caption: string;
Wnd: HWND;
ProcessId, ThreadId: THandle;
end;
PEnumWndInfo = ^TEnumWndInfo;
function FindWindowWithCaption(AWnd: HWND; Info: PEnumWndInfo): LongBool; stdcall;
var
str: string;
Id, Id2: THandle;
begin
result := True;
if info.Caption <> '' then
begin
setlength(str, length(info.Caption)+1);
GetWindowText(AWnd, pchar(str), length(str));
if stricomp(pchar(str), pchar(info.Caption)) = 0 then
begin
Id2 := GetWindowThreadProcessId(AWnd, Id);
if Id = Info.ProcessId then
begin
result := false;
info.Wnd := AWnd;
Info.ThreadId := Id2;
end;
end;
end;
end;
function getProcessModule(PId: Cardinal; ModuleName: string): Boolean;
var
snp: Thandle;
nm, ps, nm1, nm2: string;
me32: TModuleEntry32;
begin
result := false;
me32.dwSize := sizeof(me32);
nm := extractfilename(ModuleName);
ps := extractfilepath(modulename);
snp := CreateToolHelp32SnapShot(TH32CS_SNAPMODULE, PId);
if snp <> 0 then
try
if Module32First(snp, me32) then
repeat
nm1 := me32.szExePath;
nm2 := me32.szModule;
if nm2 = copy(nm1, length(nm1)-length(nm2)+1, length(nm2)) then
result := (comparetext(modulename, nm1) = 0)
else begin
if (nm1 <> '') and (nm1[length(nm1)] <> '/') then nm1 := nm1 + '/';
result := comparetext(ps, nm1) = 0;
end;
until result or not Module32Next(snp, me32);
finally
closehandle(snp);
end;
end;
function FindAppInfo(WndCapt, exeFileName: string; var WndHandle, ProcessId, ThreadId: THandle): Boolean;
var
Snp: THandle;
pe32: TProcessEntry32;
me32: TModuleEntry32;
ps, ps1, nm, nm1: string;
Info: TEnumWndInfo;
begin
result := false;
nm := extractfilename(exefilename);
ps := extractfilepath(exefilename);
pe32.dwSize := sizeof(pe32);
snp := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
if snp <> 0 then
try
if Process32First(snp, pe32) then
repeat
nm1 := pe32.szExeFile;
result := (comparetext(exeFileName, nm1)=0) or ((comparetext(nm, nm1)=0) and getprocessmodule(pe32.th32ProcessID, exeFileName));
if result then
ProcessId := pe32.th32ProcessID;
until result or not process32Next(snp, pe32);
finally
closehandle(snp);
end;
if result then
begin
info.Caption := WndCapt;
info.Wnd := 0;
info.ProcessId := ProcessId;
info.ThreadId := 0;
enumwindows(@FindWindowWithCaption, Integer(@Info));
WndHandle := info.Wnd;
ThreadId := info.ThreadId;
end;
end;
function AttachMonitor(WndCapt, exeFileName: string; var Handle: Cardinal; Notification, Context: Pointer): Boolean;
var
h1, h2, h3: Thandle;
begin
result := findappinfo(wndcapt, exefilename, h1, h2, h3);
if result then
result := createmonitor(h1, h2, h3, TAppMonitorThread(Handle), Notification, Context);
end;
function LaunchApp(exeFileName, CmdParams: string; MonitorHandle: PHandle; Notification, Context: Pointer): Boolean;
var
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
ps, cmd: string;
begin
if CmdParams = '' then
cmd := ''
else begin
cmd := '"'+exeFileName+'" '+CmdParams;
exeFileName := '';
end;
ps := extractfilepath(exeFileName);
fillchar(StartupInfo, sizeof(TStartupInfo), 0);
fillchar(ProcessInfo, sizeof(ProcessInfo), 0);
StartupInfo.cb := sizeof(TStartupInfo);
result := CreateProcess(pchar(exeFileName), pchar(cmd), nil, nil, false, 0, nil, pchar(ps), startupinfo, ProcessInfo);
if result and (MonitorHandle <> nil) then
TAppMonitorThread.CreateWithProcess(ProcessInfo, TAppMonitorThread(MonitorHandle^), Notification, Context);
end;
procedure DettachMonitor(var Handle: Cardinal; KillProcess: Boolean);
begin
try
try
if KillProcess and (Handle <> 0) then
TAppMonitorThread(Handle).StopApp
else
TAppMonitorThread(Handle).StopMonitor;
finally
Handle := 0;
end;
except
end;
end;
{ TAppMonitorThread }
constructor TAppMonitorThread.Create(Wnd: HWnd; ProcessId, ThreadId: THandle; var Monitor: TAppMonitorThread;
CallbackProc, CallbackContext: Pointer);
begin
Self.Wnd := Wnd;
PrcsId := ProcessId;
ThrdId := ThreadId;
Callback.Code := CallbackProc;
Callback.Data := CallbackContext;
Waitevents[0] := CreateEvent(nil, false, false, nil);
waitevents[1] := OpenProcess(PROCESS_ALL_ACCESS, false, PrcsId);
InstAddr := @Monitor;
Monitor := Self;
inherited Create(True);
end;
constructor TAppMonitorThread.CreateWithProcess(const Info: TProcessInformation;
var Monitor: TAppMonitorThread; CallbackProc, CallbackContext: Pointer);
begin
PrcsId := Info.dwProcessId;
ThrdId := Info.dwThreadId;
Callback.Code := CallbackProc;
Callback.Data := CallbackContext;
Waitevents[0] := CreateEvent(nil, false, false, nil);
waitevents[1] := Info.hProcess;
closehandle(Info.hThread);
InstAddr := @Monitor;
Monitor := Self;
inherited Create(True);
end;
type
TCallbackProc = procedure of object;
procedure TAppMonitorThread.Execute;
begin
FreeOnTerminate := False;
try
waitformultipleobjects(2, @WaitEvents, false, INFINITE);
except
end;
closehandle(WaitEvents[0]);
closehandle(WaitEvents[1]);
if callback.Code <> nil then
try
TCallbackProc(Callback);
except
end;
if InstAddr <> nil then
PInteger(InstAddr)^ := 0;
Terminate;
DelayRelease(self);
end;
procedure TAppMonitorThread.StopApp;
var
Tick: Cardinal;
begin
try
InstAddr := nil;
Tick := GetTickCount;
if Wnd <> 0 then
begin
postmessage(wnd, WM_CLOSE, 0, 0);
while not Terminated and (GetTickCount - Tick < 2000) do
sleep(1);
end;
if not Terminated then
begin
if ThrdId <> 0 then
begin
Tick := GetTickCount;
postthreadmessage(thrdid, WM_QUIT, 0, 0);
while not Terminated and (GetTickCount - Tick < 200) do
sleep(1);
end;
if not Terminated then
TerminateProcess(PrcsId, 0);
end;
except
end;
end;
procedure TAppMonitorThread.StopMonitor;
begin
try
InstAddr := nil;
SetEvent(WaitEvents[0]);
except
end;
end;
function LocatePathFromDesktopLnk(SubFile: string): string;
var
LnkPs: array [0..MAX_PATH] of Char;
ExePs: array [0..MAX_PATH] of Char;
LnkName: string;
Dt: TWin32FindData;
FindHandle: THandle;
Obj: IUnknown;
sLnk: IShellLink;
pFile: IPersistFile;
ws: widestring;
tmp: string;
function OpenLnk(Name: WideString): Boolean;
var
fdt: TWin32FindData;
begin
result := pFile.Load(PWideChar(Name), STGM_READ or STGM_SHARE_DENY_NONE) = S_OK;
if result then
begin
result := sLnk.GetPath(@ExePs, MAX_PATH, fdt, 0) = NOERROR;
if result then
result := fileexists(extractfilepath(exeps)+subfile);
end;
end;
begin
result := '';
if shgetspecialfolderpath(0, @LnkPs, CSIDL_DESKTOPDIRECTORY, false) then
begin
LnkName := LnkPs+'/*.lnk';
FindHandle := FindFirstFile(PChar(LnkName), dt);
if FindHandle <> INVALID_HANDLE_VALUE then
try
Obj := CreateComObject(CLSID_ShellLink);
sLnk := Obj as IShellLink;
pFile := Obj as IPersistFile;
repeat
tmp := LnkPs;
tmp := tmp +'/'+dt.cFileName;
ws := tmp;
if openlnk(ws) then
begin
result := extractfilepath(exeps);
exit;
end;
until not findnextfile(findhandle, dt);
finally
windows.FindClose(FindHandle);
pFile := nil;
sLnk := nil;
Obj := nil;
end;
end;
end;
function GetProgramFilePath(SubPath: string): string;
var
ps: array [0..MAX_PATH] of Char;
begin
if shgetspecialfolderpath(0, @Ps, CSIDL_PROGRAM_FILES, false) then
begin
result := ps;
result := result+'/'+subpath
end
else result := '';
end;
procedure CreateShortCut(AName, AFileName: string; ToDeskTop, ToStartMenu, ToDestPath: Boolean);
var
MyObject : IUnknown;
MySLink : IShellLink;
MyPFile : IPersistFile;
WFileName : WideString;
ps: array [0..MAX_PATH] of Char;
path: string;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
with MySLink do begin
//SetArguments('C:/AUTOEXEC.BAT');
SetPath(PChar(AFileName));
SetWorkingDirectory(PChar(ExtractFilePath(AFileName)));
end;
if ToDestPath then
begin
WFileName := extractfilepath(AFileName)+AName+'.lnk';
MyPFile.Save(PWChar(WFileName),False);
end;
if ToDeskTop then
if shgetspecialfolderpath(0, @Ps, CSIDL_DESKTOPDIRECTORY, false) then
begin
path := ps;
path := path+'/'+AName+'.lnk';
wfilename := path;
MyPFile.Save(PWChar(WFileName), False);
end;
if ToStartMenu and shgetspecialfolderpath(0, @ps, CSIDL_PROGRAMS, false) then
begin
path := ps;
path := path+'/'+AName+'.lnk';
wfilename := path;
mypfile.Save(pwchar(wfilename), false);
end;
end;
end.