请各位高手帮帮小妹看看这个程序啊，多谢了
用delphi实现查看某进程内存变化和拷贝文件，请大家帮帮忙给出函数调用的注释和与此相关的原理，不甚感激！unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Buttons,TLHelp32,SHELLAPI;
type
TForm2 = class(TForm)
Timer1: TTimer;
Label1: TLabel;
Edit1: TEdit;
Button2: TButton;
Button3: TButton;
Memo1: TMemo;
Label2: TLabel;
Label3: TLabel;
Edit2: TEdit;
Label4: TLabel;
SpeedButton1: TSpeedButton;
procedure Button2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
private
{ Private declarations }
ArrExeFileMem:array[0..1] of String;
procedure initSome;
public
{ Public declarations }
end;
type
TPDWord = ^DWORD;
PVM_Counters=^TVM_Counters;
TVM_Counters=record
PeakVirtualSize:ULONG;
VirtualSize:ULONG;
PagedFaultCount:ULONG;
PeakWorkingSetSize:ULONG;
WorkingSetSize:ULONG;
QuotaPeakPagedPoolUsage:ULONG;
QuotaPagedPoolUsage:ULONG;
QuotaPeakNonPagedPoolUsage:ULONG;
QuotaNonPagedPoolUsage:ULONG;
PagefileUsage:ULONG;
PeakPagefileUsage:ULONG;
end;
const ProcessVMCounters =3;
function NtQueryInformationProcess
(
ProcessHandle: Thandle;
PrcInfoClass:DWORD ;
PrcInfo:Pointer ;
PrcInfoLength:ULONG;
returnlength: TPDword
):
DWORD; stdcall ;external 'ntdll.dll' name 'NtQueryInformationProcess';
var
Form2: TForm2;
H:THandle;
FileName:String;
OutFile:TextFile;
MiAO:Integer=0;
implementation
uses unit1;
{$R *.dfm}
// Our Function here:
function GetPrcVMCounters(PID:DWORD):TStringList;
var
status:DWORD;
retlen:DWORD;
VM_Info:TVM_Counters;
hProcess:THandle;
begin
result:=TStringList.Create;
hProcess :=OpenProcess(PROCESS_QUERY_INFORMATION,FALSE,PID);
status:=NtQueryInformationProcess
(
hProcess,
ProcessVMCounters,
@VM_Info,
sizeof(TVM_Counters),
@retlen
);
if(status<>0) then
begin
ShowMessage('NtQueryInformationProcess 失败');
exit;
end;
with result do
begin
Add('进程虚拟地址空间的最大数值 : '+IntToStr(VM_Info.PeakVirtualSize)+' Byte');
Add('进程的虚拟地址空间的大小 : '+IntToStr(VM_Info.VirtualSize)+' Byte');
Add('进程分页错误数目 : '+IntToStr(VM_Info.PagedFaultCount)+' Byte');
Add('进程的工作集列表的最大值 : '+IntToStr(VM_Info.PeakWorkingSetSize)+' Byte');
Add('进程的工作集列表的大小 : '+IntToStr(VM_Info.WorkingSetSize)+' Byte');
Add('填充到进程的分页池的峰值的最大值 : '+IntToStr(VM_Info.QuotaPeakPagedPoolUsage)+' Byte');
Add('填充到进程的分页池的峰值大小 : '+IntToStr(VM_Info.QuotaPagedPoolUsage)+' Byte');
Add('填充到进程的非分页池的峰值的最大值 : '+IntToStr(VM_Info.QuotaNonPagedPoolUsage)+' Byte');
Add('填充到进程的分页池的峰值大小 : '+IntToStr(VM_Info.QuotaNonPagedPoolUsage)+' Byte');
Add('进程多使用的页文件页的最大值 : '+IntToStr(VM_Info.PeakPagefileUsage)+' Byte');
end;
end;
//==========
function getTaskExeMem(PID:DWORD):String;
var
status:DWORD;
retlen:DWORD;
VM_Info:TVM_Counters;
hProcess:THandle;
begin
hProcess :=OpenProcess(PROCESS_QUERY_INFORMATION,FALSE,PID);
status:=NtQueryInformationProcess
(
hProcess,
ProcessVMCounters,
@VM_Info,
sizeof(TVM_Counters),
@retlen
);
if(status<>0) then
begin
ShowMessage('NtQueryInformationProcess 失败');
exit;
end;
Result:=IntToStr(VM_Info.WorkingSetSize)+' Byte'; // end;
//==========
function FindProcessName(StrExeName:String):THandle;
var
lppe: tprocessentry32;
sshandle: thandle;
found: boolean;
begin
result:=0;
sshandle := createtoolhelp32snapshot(TH32CS_SNAPALL, 0);
found := process32first(sshandle, lppe);
while found do
begin
if ansiCompareText(ExtractFileName(lppe.szExefile),StrExeName) = 0 then
begin
result:=lppe.th32ProcessID;
break;
end;
found := process32next(sshandle, lppe);
end;
CloseHandle(sshandle);
end;
procedure Output(Text: string);
begin
//Writeln(OutFile, Text: FIELD_WIDTH, Value div 1024, ' KB(', Value, ' Byte)');
Writeln(OutFile,Text);
end;
procedure TForm2.Button2Click(Sender: TObject);
begin
MiAO:=0;
initSome;
H:=FindProcessName(Trim(Edit1.text));
if H=0 then
begin ShowMessage('Error') ;Application.Terminate ; Exit; end;
self.Button3.Enabled :=True;
Memo1.Lines:=GetPrcVMCounters(h);
self.Timer1.Enabled :=true;
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
FillChar(ArrExeFileMem,2,#0);
end;
procedure TForm2.Timer1Timer(Sender: TObject);
begin
ArrExeFileMem[1]:=getTaskExeMem(H);
if ArrExeFileMem[0]<>ArrExeFileMem[1] then
begin
OutPut(ArrExeFileMem[1]+'-----'+DateTimeToStr(NOW));
ArrExeFileMem[0]:= ArrExeFileMem[1] ;
end;
inc(MiAO);
Edit2.Text := intTOStr(MiAo);
end;
procedure TForm2.Button3Click(Sender: TObject);
var
URL:PChar;
begin
ShowMessage(FileName);
Self.Timer1.Enabled :=False;
CloseFile(OutFile);
URL:=PChar(FileName);
ShellExecute(0,nil,URl,nil,nil,SW_NORMAL);
end;
procedure TForm2.SpeedButton1Click(Sender: TObject);
var
URL:PChar;
begin
URL:=pchar('www.163.com#39;);
ShellExecute(0,nil,URl,nil,nil,SW_NORMAL);
end;
procedure TForm2.initSome;
begin
FileName:=ExtractFilePath(ParamStr(0))+'MemLogs.txt';
AssignFile(OutFile, Filename);
if FileExists(Filename) then
begin
Append(OutFile);
Writeln(OutFile);
end
else
Rewrite(OutFile);
Writeln(OutFile, '======= ', Edit1.text , ',', DateTimeToStr(Now), ' =======');
end;
end.
下面是拷贝的代码
unit Unit3;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons,ShellAPI,TLHelp32, fileCtrl;
type
TForm3 = class(TForm)
Memo1: TMemo;
Label2: TLabel;
BitBtn1: TBitBtn;
Edit1: TEdit;
Label1: TLabel;
BitBtn4: TBitBtn;
Edit2: TEdit;
BitBtn2: TBitBtn;
BitBtn3: TBitBtn;
procedure BitBtn2Click(Sender: TObject);
procedure BitBtn3Click(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
procedure BitBtn4Click(Sender: TObject);
procedure Edit1Change(Sender: TObject);
procedure Edit2Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
private
{ Private declarations }
public
function CurrentIsValidDir(SearchRec:TSearchRec):integer;
procedure RecurSearchFile(CurrentDir:string;SearchFileType:string;SearchResult:TStrings;var Number:integer);
procedure Xcopy(SourceDir,TargetDir:String);
{ Public declarations }
end;
var
Form3: TForm3;
TotalFileNumbers:Integer;
SearchFileType:String;
Copying:Boolean;
implementation
uses unit1;
{$R *.dfm}
function TForm3.CurrentIsValidDir(SearchRec:TSearchRec):integer;
begin
if ((SearchRec.Attr <> 16) and
(SearchRec.Name<>'.') and
(SearchRec.Name<>'..')) then
Result:=0
else if ((SearchRec.Attr = 16) and
(SearchRec.Name<>'.') and
(SearchRec.Name<>'..')) then
Result:=1
else
Result:=2;
end;
Procedure TForm3.RecurSearchFile(CurrentDir:string;SearchFileType:string;SearchResult:TStrings;var Number:integer);
var
i:integer;
Subdir:TStringList;
SearchRec:TsearchRec;
begin
if (FindFirst(CurrentDir+SearchFileType, faAnyFile, SearchRec)=0) then
begin
repeat
if CurrentIsValidDir(SearchRec)=0 then
begin
Inc(Number);
Searchresult.Add(CurrentDir+SearchRec.Name);
end;
application.ProcessMessages ;
until (FindNext(SearchRec) <> 0);
end;
FindClose(SearchRec);
Subdir:=TStringList.Create;
if (FindFirst(CurrentDir+'*.*', faDirectory, SearchRec)=0) then
begin
repeat
if CurrentIsValidDir(SearchRec)=1 then
begin
Subdir.Add(SearchRec.Name);
end;
application.ProcessMessages ;
until (FindNext(SearchRec) <> 0);
end;
FindClose(SearchRec);
for i:=0 to Subdir.Count-1 do
begin
RecurSearchfile(CurrentDir+Subdir.Strings[i]+'\',SearchFileType,Searchresult,Number);
end;
Subdir.Free;
end;
procedure TForm3.Xcopy(SourceDir,TargetDir:String);
var
OpStruc: TSHFileOpStruct;//
FromBuf, ToBuf: Array [0..128] of Char;//
begin
FillChar(FromBuf, Sizeof(FromBuf), 0 );
FillChar(ToBuf, Sizeof(ToBuf), 0 );
StrPCopy(FromBuf, SourceDir+'*.*' );
StrPCopy(ToBuf, TargetDir);
With OpStruc do
begin
Wnd:= Handle;/
wFunc:= FO_Copy;//
pFrom:= @FromBuf;
pTo:=@ ToBuf;
fFlags:= FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;//
fAnyOperationsAborted:= False;
hNameMappings:= Nil;
lpszProgressTitle:= Nil;
end;
ShFileOperation( OpStruc );//
end;
procedure TForm3.BitBtn2Click(Sender: TObject);
begin
BitBtn2.Enabled:=False;
Copying:=True;
memo1.lines.Clear ;
TotalFileNumbers:=0;
RecurSearchFile(Edit1.Text,SearchFileType,memo1.lines, TotalFileNumbers);
Xcopy(Edit1.Text,Edit2.Text);
Copying:=False;
Memo1.Lines.Add('拷贝操作全部结束,一共拷贝'+IntToStr(TotalFileNumbers)+'个文件到目标目录.');
Edit1.Clear;
Edit2.Clear;
end;
procedure TForm3.BitBtn3Click(Sender: TObject);
begin
Close;
end;
procedure TForm3.BitBtn1Click(Sender: TObject);
var
SelectDir:string;
begin
if SelectDirectory(SelectDir, [sdAllowCreate, sdPerformCreate, sdPrompt],0) then
begin
if length(SelectDir) > 3 then
SelectDir:=SelectDir+'\';
Edit1.Text:=SelectDir;
end;
end;
procedure TForm3.BitBtn4Click(Sender: TObject);
var
SelectDir:string;
begin
if SelectDirectory(SelectDir, [sdAllowCreate, sdPerformCreate, sdPrompt],0) then
begin
if length(SelectDir) > 3 then
SelectDir:=SelectDir+'\';
Edit2.Text:=SelectDir;
end;
end;
procedure TForm3.Edit1Change(Sender: TObject);
begin
if ((Edit1.Text='')or(Edit2.Text='')) then
BitBtn2.Enabled:=False
else
BitBtn2.Enabled:=True;
end;
procedure TForm3.Edit2Change(Sender: TObject);
begin
if ((Edit1.Text='')or(Edit2.Text='')) then
BitBtn2.Enabled:=False
else
BitBtn2.Enabled:=True;
end;
procedure TForm3.FormCreate(Sender: TObject);
begin
TotalFileNumbers:=0;
SearchFileType:='*.*';
Copying:=False;
end;
procedure TForm3.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if Copying then
CanClose:=False
else
CanClose:=True;
end;
end.
请大虾们帮帮忙哈
----------------------------------------------
