memorydump.pas

全世界知名的Open Source Delphi开发组织JCL的作品。JCL包含了很多Delphi和C++Builder中的可重用单元

                with TempNode do ImageIndex := Parent.ImageIndex;
                MappedFile := True;
              end else
                MappedFile := False;
              LastMappedFile := MappedFile;
            end else
            begin
              RepeatedItem := True;
              MappedFile := LastMappedFile;
            end;
      end;
      AllocationsNode.AlphaSort;
      ModulesNode.AlphaSort;

      TotalCommit := 0;
      TotalReserve := 0;
      for I := 0 to Length(FMemoryInfo) - 1 do with FMemoryInfo[I].MemInfo do
        case State of
          MEM_COMMIT: Inc(TotalCommit, RegionSize);
          MEM_RESERVE: Inc(TotalReserve, RegionSize);
        end;
      with StatusBar do
      begin
        Panels[0].Text := Format(sCount, [Length(FMemoryInfo)]);
        Panels[1].Text := Format(sCommited, [IntToExtended(TotalCommit)]);
        Panels[2].Text := Format(sReserved, [IntToExtended(TotalReserve)]);
      end;

      ListViewFocusFirstItem(PagesListView);
    finally
      PagesListView.Items.EndUpdate;
      MemoryTreeView.Items.EndUpdate;
      StatusBar.Panels.EndUpdate;
    end;
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TMemoryDumpForm.BuildModulesList;
var
  SnapProcHandle: THandle;
  ModuleEntry: TModuleEntry32;
  Next: Boolean;
begin
  FModulesList.Clear;
  SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, FProcessID);
  if SnapProcHandle <> THandle(-1) then
  begin
    ModuleEntry.dwSize := SizeOf(ModuleEntry);
    Next := Module32First(SnapProcHandle, ModuleEntry);
    while Next do
    begin
      FModulesList.AddObject(ModuleEntry.szModule, Pointer(ModuleEntry.modBaseAddr));
      Next := Module32Next(SnapProcHandle, ModuleEntry);
    end;
    CloseHandle(SnapProcHandle);
  end;
end;

procedure TMemoryDumpForm.SetParams(ProcessID: DWORD; const FileName: TFileName);
begin
  FProcessID := ProcessID;
  FFileName := FileName;
  Caption := Format(sCaption, [FFileName]);
  Refresh1.Execute;
end;

procedure TMemoryDumpForm.UpdateDumpList;
begin
  with DumpListView do
  begin
    if ViewAsText1.Checked then
    begin
      FDumpBytesPerLine := 64;
      Columns[1].Caption := 'Ansi text';
      Columns[2].Caption := 'Unicode text';
    end else
    begin
      FDumpBytesPerLine := 16;
      Columns[1].Caption := 'Data';
      Columns[2].Caption := 'ASCII';
    end;
    Items.Count := Integer(PagesListView.Selected.SubItems.Objects[3]) div FDumpBytesPerLine;
    Invalidate;
  end;
end;

procedure TMemoryDumpForm.Refresh1Execute(Sender: TObject);
begin
  if FProcess <> 0 then CloseHandle(FProcess);
  FProcess := OpenProcess(PROCESS_ALL_ACCESS, False, FProcessID);
  if FProcess = 0 then
  begin
    Close;
    RaiseLastOSError;
  end;
  BuildModulesList;
  BuildPagesList;
end;

procedure TMemoryDumpForm.DumpListViewData(Sender: TObject; Item: TListItem);
var
  Address: Pointer;
  LineData: packed array[0..63] of Byte;
  NR: DWORD;
  Hex, Ascii, S: string;
  I: Integer;
  W: PWideChar;
begin
  with TListView(Sender) do
    if PagesListView.Selected <> nil then
    begin
      Address := Pointer(DWORD(FMemoryInfo[PagesListView.Selected.Index].MemInfo.BaseAddress) + DWORD(Item.Index * FDumpBytesPerLine));
      SetLength(Hex, 3 * SizeOf(LineData));
      SetLength(Ascii, 3 * SizeOf(LineData));
      Hex := '';
      Ascii := '';
      if ReadProcessMemory(FProcess, Address, @LineData, SizeOf(LineData), NR) and (NR = SizeOf(LineData)) then
      begin
        if ViewAsText1.Checked then
        begin
          for I := 0 to FDumpBytesPerLine - 1 do
          begin
            if LineData[I] >= 32 then
              Hex := Hex + Chr(LineData[I])
            else
              Hex := Hex + '.';
          end;
          W := PWideChar(@LineData);
          for I := 0 to FDumpBytesPerLine div 2 - 1 do
          begin
            SetLength(S, 1);
            WideCharToMultiByte(CP_ACP, 0, W, 1, PChar(S), 1, nil, nil);
            S := PChar(S);
            if Length(S) = 0 then S := '.';
            Ascii := Ascii + S;
            Inc(W);
          end;
        end else
        begin
          for I := 0 to FDumpBytesPerLine - 1 do
          begin
            Hex := Hex + Format('%.2x ', [LineData[I]]);
            if LineData[I] >= 32 then
              Ascii := Ascii + Chr(LineData[I])
            else
              Ascii := Ascii + '.';
          end;
        end;
      end;
      Item.Caption := Format('%p', [Address]);
      Item.SubItems.Add(Hex);
      Item.SubItems.Add(Ascii);
    end;
end;

procedure TMemoryDumpForm.PagesListViewSelectItem(Sender: TObject;
  Item: TListItem; Selected: Boolean);
begin
  if Selected then
  begin
    if (DWORD(Item.SubItems.Objects[0]) = PAGE_NOACCESS) or
       (DWORD(Item.SubItems.Objects[2]) = 0) then
    begin
      DumpListView.Items.Count := 0;
      DumpListView.Invalidate;
    end else
      UpdateDumpList;
  end;
end;

procedure TMemoryDumpForm.PagesListViewData(Sender: TObject; Item: TListItem);
var
  I: Integer;
begin
  with Item, FMemoryInfo[Item.Index].MemInfo do
  begin
    Caption := Format('%p', [BaseAddress]);
    SubItems.AddObject(AllocationProtectStr(Protect), Pointer(Protect));
    SubItems.AddObject(Format('%p', [AllocationBase]), AllocationBase);
    SubItems.AddObject(AllocationProtectStr(AllocationProtect), Pointer(AllocationProtect));
    SubItems.AddObject(Format('%.0n', [IntToExtended(RegionSize)]), Pointer(RegionSize));
    SubItems.AddObject(StateStr(State), Pointer(State));
    I := FModulesList.IndexOfObject(AllocationBase);
    if I <> - 1 then SubItems.Add(FModulesList[I]) else SubItems.Add('');
    SubItems.AddObject(TypeStr(Type_9), Pointer(Type_9));
  end;
  Item.ImageIndex := ImageIndexFromInfo(FMemoryInfo[Item.Index]);
end;

procedure TMemoryDumpForm.PagesListViewCustomDrawItem(Sender: TCustomListView;
  Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
  if DWORD(Item.SubItems.Objects[0]) = PAGE_NOACCESS then
    Sender.Canvas.Font.Color := clBtnFace;
end;

procedure TMemoryDumpForm.MemoryTreeViewChange(Sender: TObject; Node: TTreeNode);
begin
  if Node.Level = 1 then
    with PagesListView do
    begin
      while Assigned(Selected) do Selected.Selected := False;
      ItemFocused := PagesListView.Items[Integer(Node.Data)];
      ItemFocused.Selected := True;
      ItemFocused.MakeVisible(False);
    end;
end;

procedure TMemoryDumpForm.MemoryTreeViewGetSelectedIndex(Sender: TObject;
  Node: TTreeNode);
begin
  Node.SelectedIndex := Node.ImageIndex;
end;

procedure TMemoryDumpForm.ViewAsText1Execute(Sender: TObject);
begin
  with ViewAsText1 do
    Checked := not Checked;
  UpdateDumpList;  
end;

procedure TMemoryDumpForm.SaveData1Update(Sender: TObject);
begin
  TAction(Sender).Enabled := (ActiveControl = PagesListView) and
    (PagesListView.Selected <> nil) and
    (DWORD(PagesListView.Selected.SubItems.Objects[0]) <> PAGE_NOACCESS);
end;

procedure TMemoryDumpForm.SaveData1Execute(Sender: TObject);
var
  MS: TMemoryStream;
  NR: DWORD;
begin
  with SaveDataDialog, FMemoryInfo[PagesListView.Selected.Index].MemInfo do
  begin
    FileName := '';
    if Execute then
    begin
      MS := TMemoryStream.Create;
      try
        MS.Size := RegionSize;
        if ReadProcessMemory(FProcess, BaseAddress, MS.Memory, RegionSize, NR) and
          (NR = RegionSize) then
          MS.SaveToFile(FileName)
        else
          RaiseLastOSError;
      finally
        MS.Free;
      end;
    end;
  end;
end;

end.