procedure TForeignProcessMemMgr.Write(const Source; Dest: Pointer; Bytes: Cardinal);
var
BytesWritten: Cardinal;
begin
if not WriteProcessMemory(FProcess, Dest, @Source, Bytes, BytesWritten) then
RaiseLastWin32Error;
end;
constructor TWin9xProcessMemMgr.Create(ProcessID: Cardinal);
begin
inherited;
FSharedList := TObjectList.Create;
end;
destructor TWin9xProcessMemMgr.Destroy;
begin
FSharedList.Free;
inherited;
end;
procedure TWin9xProcessMemMgr.NeedMoreMem(Bytes: Cardinal);
var
Ix: Integer;
Share: TSharedMem;
Rec: PMemRec;
begin
if Bytes < MemMgrMemSize then
Bytes := MemMgrMemSize
else
Bytes := (Bytes + $FFF) and not $FFF;
Ix := FSharedList.Count;
Share := TSharedMem.Create('', Bytes);
FSharedList.Add(Share);
New(Rec);
Rec^.Start := Share.Buffer;
Rec^.Size := Bytes;
Rec^.Group := Ix;
Rec^.Used := false;
FMemList.Add(Rec);
end;
{ TWinNTProcessMemMgr }
constructor TWinNTProcessMemMgr.Create(ProcessID: Cardinal);
begin
inherited;
FAllocList := TList.Create;
end;
destructor TWinNTProcessMemMgr.Destroy;
var
i: Integer;
begin
for i := 0 to FAllocList.Count - 1 do
VirtualFreeEx(FProcess, FAllocList[i], 0, MEM_RELEASE);
FAllocList.Free;
inherited;
end;
procedure TWinNTProcessMemMgr.NeedMoreMem(Bytes: Cardinal);
var
Ix: Integer;
Alloc: Pointer;
Rec: PMemRec;
begin
if Bytes < MemMgrMemSize then
Bytes := MemMgrMemSize
else
Bytes := (Bytes + $FFF) and not $FFF;
Ix := FAllocList.Count;
Alloc := VirtualAllocEx(FProcess, nil, MemMgrMemSize, MEM_COMMIT, PAGE_READWRITE);
if Alloc = nil then RaiseLastWin32Error;
FAllocList.Add(Alloc);
New(Rec);
Rec^.Start := Alloc;
Rec^.Size := Bytes;
Rec^.Group := Ix;
Rec^.Used := false;
FMemList.Add(Rec);
end;
function CreateProcessMemMgr(ProcessID: Cardinal): TProcessMemMgr;
begin
if ProcessID = GetCurrentProcessId then begin
Result := TOwnProcessMemMgr.Create;
end else begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
Result := TWinNTProcessMemMgr.Create(ProcessID)
else
Result := TWin9xProcessMemMgr.Create(ProcessID);
end;
end;
function CreateProcessMemMgrForWnd(Wnd: HWND): TProcessMemMgr;
var
PID: Cardinal;
begin
PID := 0;
GetWindowThreadProcessId(Wnd, @PID);
Result := CreateProcessMemMgr(PID);
end;
function TOwnProcessMemMgr.AllocMem(Bytes: Cardinal): Pointer;
begin
Result := SysUtils.AllocMem(Bytes);
FMemList.Add(Result);
end;
constructor TOwnProcessMemMgr.Create;
begin
inherited;
FMemList := TThreadList.Create;
end;
destructor TOwnProcessMemMgr.Destroy;
var
i: Integer;
begin
with FMemList.LockList do try
for i := 0 to Count - 1 do
System.FreeMem(Items[i]);
finally
FMemList.UnlockList;
end;
FMemList.Free;
inherited;
end;
procedure TOwnProcessMemMgr.FreeMem(P: Pointer);
begin
FMemList.Remove(P);
System.FreeMem(P);
end;
procedure TOwnProcessMemMgr.Read(Source: Pointer; var Dest; Bytes: Cardinal);
begin
System.Move(Source^, Dest, Bytes);
end;
function TOwnProcessMemMgr.ReadStr(Source: PChar): String;
begin
Result := Source;
end;
procedure TOwnProcessMemMgr.WriteStr(const Str: String; Dest: Pointer);
begin
StrPCopy(Dest, Str);
end;
{ TForeignProcessMemMgr }
function TForeignProcessMemMgr.AllocMem(Bytes: Cardinal): Pointer;
var
t: Integer;
i: Integer;
Rec, NewRec: PMemRec;
Remain: Cardinal;
begin
Result := nil;
with FMemList.LockList do try
for t := 0 to 1 do begin
for i := 0 to Count - 1 do begin
Rec := Items[i];
if not Rec^.Used and (Rec^.Size >= Bytes) then begin
Remain := Rec^.Size - Bytes;
Rec^.Size := Bytes;
Rec^.Used := true;
Result := Rec^.Start;
if Remain > 0 then begin
New(NewRec);
NewRec^.Start := Pointer(Cardinal(Result) + Cardinal(Bytes));
NewRec^.Size := Remain;
NewRec^.Group := Rec^.Group;
NewRec^.Used := false;
Insert(i + 1, NewRec);
end;
exit;
end;
end;
NeedMoreMem(Bytes);
end;
raise EProcessMemMgr.Create('ProcessMemMgr.AllocMem: not enough memory');
finally
FMemList.UnlockList;
end;
end;
constructor TForeignProcessMemMgr.Create(ProcessID: Cardinal);
begin
inherited Create;
FProcess := OpenProcess(PROCESS_VM_OPERATION or PROCESS_VM_READ or PROCESS_VM_WRITE, false, ProcessID);
if FProcess = 0 then RaiseLastWin32Error;
FMemList := TThreadList.Create;
end;
destructor TForeignProcessMemMgr.Destroy;
begin
FMemList.Free;
CloseHandle(FProcess);
inherited;
end;
procedure TForeignProcessMemMgr.FreeMem(P: Pointer);
var
i, j: Integer;
Rec, NextRec: PMemRec;
begin
with FMemList.LockList do try
for i := 0 to Count - 1 do begin
Rec := Items[i];
if Rec^.Start = P then begin
Rec^.Used := false;
j := i + 1;
while j < Count do begin
NextRec := Items[j];
if NextRec^.Used then exit;
if NextRec^.Group <> Rec^.Group then exit;
inc(Rec^.Size, NextRec^.Size);
Dispose(NextRec);
Delete(j);
end;
exit;
end;
end;
Assert(false, 'ProcessMemMgr.FreeMem: unknown pointer');
finally
FMemList.UnlockList;
end;
end;
procedure TForeignProcessMemMgr.Read(Source: Pointer; var Dest; Bytes: Cardinal);
var
BytesRead: Cardinal;
begin
if not ReadProcessMemory(FProcess, Source, @Dest, Bytes, BytesRead) then
RaiseLastWin32Error;
end;
function TForeignProcessMemMgr.ReadStr(Source: PChar): String;
var
BytesRead: Cardinal;
OldSz, DeltaSz, NewSz: Integer;
Buf: PChar;
i: Integer;
Found: Integer;
begin
Result := '';
if Source = nil then exit;
Buf := nil;
OldSz := 0;
DeltaSz := $1000 - (Cardinal(Source) and $FFF);
Found := -1;
try
while Found < 0 do begin
NewSz := OldSz + DeltaSz;
System.ReallocMem(Buf, NewSz);
if not ReadProcessMemory(FProcess, Source + OldSz, Buf + OldSz , DeltaSz, BytesRead) then
RaiseLastWin32Error;
for i := OldSz to NewSz - 1 do begin
if Buf[i] = #0 then begin
Found := i;
break;
end;
end;
DeltaSz := $1000;
end;
SetLength(Result, Found);
if Found > 0 then
System.Move(Buf^, Result[1], Found);
finally
System.FreeMem(Buf);
end;
end;
author: Michael Winter, delphi.net@gmx.net
ver: 0.1, 2000-02-26
desc:
Simple test and demo program that should show how to use uProcessMemMgr.
Captures the content of a listview control, even from inside another process
(e. g. the Desktop window in Explorer).
For demonstration, the foreign listview content is written into a stream, after
that the stream is used to fill the MainForm's own listview.
notes:
Position the mouse over a listview window. You can see the window's class name
in the caption of the main form. To capture, press F12.
Please report any problems with this unit to the email address above.
procedure ForeignListViewToStream(Wnd: HWND; Writer: TWriter;
const OnlySelectedItem: boolean = false);
const
MaxTextLen = 1024;
var
MemMgr: TProcessMemMgr;
Column: TLVColumn;
Item: TLVItem;
c, i: Integer;
ColCount: Integer;
Ok: Boolean;
// these Pointers are Pointers into the possibly foreign process
PrItemText: PChar;
PrColumn: PLVColumn;
PrItem: PLVItem;
begin
MemMgr := CreateProcessMemMgrForWnd(Wnd);
try
PrItemText := MemMgr.AllocMem(MaxTextLen);
PrColumn := MemMgr.AllocMem(SizeOf(TLVColumn));
PrItem := MemMgr.AllocMem(SizeOf(TLVItem));
// write Colunms
c := 0;
repeat
Column.mask := LVCF_FMT or LVCF_WIDTH or LVCF_TEXT;
Column.pszText := PrItemText;
Column.cchTextMax := MaxTextLen;
MemMgr.Write(Column, PrColumn, SizeOf(TLVColumn));
Ok := ListView_GetColumn(Wnd, c, PrColumn^);
if Ok then begin
MemMgr.Read(PrColumn, Column, SizeOf(TLVColumn));
Writer.WriteBoolean(true);
Writer.WriteString(MemMgr.ReadStr(Column.pszText));
case Column.fmt of
LVCFMT_RIGHT: Writer.WriteInteger(ord(taRightJustify));
LVCFMT_CENTER: Writer.WriteInteger(ord(taCenter))
else Writer.WriteInteger(ord(taLeftJustify));
end;
Writer.WriteInteger(Column.cx);
inc(c);
end;
until not Ok;
ColCount := c;
if ColCount = 0 then ColCount := 1;
Writer.WriteBoolean(false);
// write items
if OnlySelectedItem then i := ListView_GetNextItem(Wnd, -1, LVNI_SELECTED) else
i := ListView_GetNextItem(Wnd, -1, LVNI_ALL);
while i >= 0 do begin
Writer.WriteBoolean(true);
for c := 0 to ColCount - 1 do begin
Item.mask := LVIF_TEXT;
Item.iItem := i;
Item.iSubItem := c;
Item.pszText := PrItemText;
Item.cchTextMax := MaxTextLen;
MemMgr.Write(Item, PrItem, SizeOf(TLVItem));
ListView_GetItem(Wnd, PrItem^);
MemMgr.Read(PrItem, Item, SizeOf(TLVItem));
Writer.WriteString(MemMgr.ReadStr(Item.pszText));
end;
if OnlySelectedItem then i := ListView_GetNextItem(Wnd, i, LVNI_SELECTED) else
i := ListView_GetNextItem(Wnd, i, LVNI_ALL);
end;
Writer.WriteBoolean(false);
finally
MemMgr.Free;
end;
end;
procedure StreamToListView(LV: TListView; Reader: TReader);
var
c: Integer;
begin
LV.Items.BeginUpdate;
try
LV.Items.Clear;
LV.Columns.Clear;
// read columns
while Reader.ReadBoolean do begin
with LV.Columns.Add do begin
Caption := Reader.ReadString;
Alignment := TAlignment(Reader.ReadInteger);
Width := Reader.ReadInteger;
end;
end;
if LV.Columns.Count = 0 then
LV.Columns.Add;
// read items
while Reader.ReadBoolean do begin
with LV.Items.Add do begin
Caption := Reader.ReadString;
for c := 1 to LV.Columns.Count - 1 do begin
SubItems.Add(Reader.ReadString);
end;
end;
end;
finally
LV.Items.EndUpdate;
end;
end;
function GetWndClassName(Wnd: HWND): String;
var
S: Array[0..255] of Char;
begin
GetClassName(Wnd, S, 255);
Result := S;
end;
procedure TMainForm.Timer1Timer(Sender: TObject);
var
W: HWND;
CName: String;
begin
W := WindowFromPoint(Mouse.CursorPos);
CName := GetWndClassName(W);
Caption := CName;
if GetAsyncKeyState(VK_F12) and 1 <> 0 then begin
if SameText(CName, 'SysListView32')
or SameText(CName, 'TListView') or
SameText(CName, 'SysTabControl32')
then begin
GrabListView(W, CheckBox1.Checked);
end;
end;
end;