Przeszukiwanie pamięci procesu

0

Czy jest możliwe przeszukanie pamięci procesu w Delphi?
Mój program ma za zadanie odczytanie danych z procesu, który otworzy użytkownik. Z góry chcę podkreślić, że nie chodzi o szkodliwe oprogramowanie!

Użytkownik odpala mój program, a następnie odpala zewnętrzny program o nazwie okna załóżmy "Aplikacja1222". Wykrywam ten program i potrzebuje odczytać z tego procesu dane.
Problem w tym, że dane mają zmienne adresy w pamięci zależne od różnych czynników.
Czy jest możliwe przeszukanie pamięci tego procesu?

Potrzebuje znaleźć taki wiersz w pamięci i go odczytać, cały:

stala_nazwa1=zmienna_wartosc1&stala_nazwa2=zmienna_wartosc2

Wiem, że będą potrzebne wyrażenia regularne do tych zmiennych wartości, ale jak zabrać się za wyszukanie takiego wiersza w procesie?
Prosiłbym o jakieś wskazówki, opis działania, kod napiszę sam, tylko nie wiem jak zacząć.

dodanie znacznika <code class="none"> - @furious programming

1

Polecam skorzystać z poniższych rozwiązań. Mniejsza o może przekombinowane i nie do konca poprawne nazewnictwo typów czy parametrów. Ważne, że działa. A Pid procesu na podstawie uchwytu okna uzyskasz funkcją GetWindowThreadProcessId. Będzie ona w zmiennej typu najlepiej DWORD podanej jako drugi parametr. Więcej informacji o użytych elementach kodu w ich opisach na MSDNie. Jakby coś nie było po Twojej myśli, to śmiało możesz sobie ten kod dostosować do własnych potrzeb i po swojemu popoprawiać lub rozszerzyć czy zmienić.

//...
uses
  Windows;

type
  TOnFindProc = procedure(FindedAddress : Cardinal);

function FindBytesInMemory(APid : DWORD; RangeFrom, RangeTo : Cardinal;
  ArrayOfBytes : array of Byte; OnFindProc : TOnFindProc;
  StopAfterFirstFinding : boolean) : Cardinal;
const
  BufferSize = 65535;
var
  Found : boolean;
  SizeOfArr : Byte;
  HProcess : THandle;
  X, Y, Addr : Cardinal;
  BytesRead, BytesToRead : DWORD;
  Buffer : array[0..BufferSize - 1] of Byte;
begin
  Result := 0;
  Found := False;
  SizeOfArr := Length(ArrayOfBytes);
  HProcess := OpenProcess(PROCESS_ALL_ACCESS, False, APid);
  if (HProcess > 0) and (RangeFrom < RangeTo) then
  begin
    Addr := RangeFrom;
    while Addr < RangeTo do
    begin
      BytesToRead := BufferSize;
      if (RangeTo - Addr) < BytesToRead then
      begin
        BytesToRead := RangeTo - Addr;
      end;
      ReadProcessMemory(HProcess, Pointer(Addr), @Buffer[0], BytesToRead, BytesRead);
      if BytesRead > 0 then
      begin
        for X := 0 to BytesRead - 1 do
        begin
          Found := True;
          for Y := Low(ArrayOfBytes) to High(ArrayOfBytes) do
          begin
            if Buffer[X + Y] <> ArrayOfBytes[Y] then
            begin
              Found := False;
              Break;
            end;
          end;
          if Found then
          begin
            Result := Addr + X + Y - SizeOfArr;
            if @OnFindProc <> nil then
            begin
              OnFindProc(Result);
            end;
            Break;
          end;
        end;
      end;
      Addr := Addr + BytesToRead;
      if (Found) and (StopAfterFirstFinding) then
      begin
        Break;
      end;
    end;
    CloseHandle(HProcess);
  end;
end;

procedure FindStringInMemory(APID : word; RangeFrom, RangeTo : Cardinal;
  StringToFind : string; IgnoreCase : boolean; OnFindProc : TOnFindProc);
const
  BufferSize = 65535;
var
  Found : boolean;
  S1, S2 : string;
  SizeOfArr : word;
  X, Y, Addr : Cardinal;
  ArrayOfBytes : array of Byte;
  HProcess, BytesRead, BytesToRead : DWORD;
  Buffer : array[0..BufferSize - 1] of Byte;
begin
  if StringToFind <> '' then
  begin
    SetLength(ArrayOfBytes, Length(StringToFind));
    for X := Low(ArrayOfBytes) to High(ArrayOfBytes) do
    begin
      ArrayOfBytes[X] := Ord(StringToFind[X + 1]);
    end;
    SizeOfArr := Length(ArrayOfBytes);
    HProcess := OpenProcess(PROCESS_ALL_ACCESS, False, APID);
    if (HProcess > 0) and (RangeFrom < RangeTo) then
    begin
      Addr := RangeFrom;
      while Addr < RangeTo do
      begin
        BytesToRead := BufferSize;
        if (RangeTo - Addr) < BytesToRead then
        begin
          BytesToRead := RangeTo - Addr;
        end;
        ReadProcessMemory(HProcess, Pointer(Addr), @Buffer[0], BytesToRead, BytesRead);
        if BytesRead > 0 then
        begin
          for X := 0 to BytesRead - 1 do
          begin
            Found := True;
            for Y := Low(ArrayOfBytes) to High(ArrayOfBytes) do
            begin
              if IgnoreCase then
              begin
                S1 := AnsiLowerCase(Chr(Buffer[X + Y]));
                S2 := AnsiLowerCase(Chr(ArrayOfBytes[Y]));
                if S1 <> S2 then
                begin
                  Found := False;
                  Break;
                end;
              end
              else
              begin
                if Buffer[X + Y] <> ArrayOfBytes[Y] then
                begin
                  Found := False;
                  Break;
                end;
              end;
            end;
            if Found then
            begin
              if @OnFindProc <> nil then
              begin
                OnFindProc(Addr + X + Y - SizeOfArr);
              end;
            end;
          end;
        end;
        Addr := Addr + BytesToRead;
      end;
    end;
    CloseHandle(HProcess);
  end;
end;

//...
0

Ogromne dzięki!

0
olesio napisał(a)

Chętnie zobaczę szybszą wersję. Sam kiedyś coś tam próbowałem przerobić. Ale po zbyt dużej ilości zmian kod nie działał jak chciałem, więc odpuściłem by nie skopać całości.

Przede wszystkim zwróć uwagę, że w funkcji FindStringInMemory ta pętla:

for Y := Low(ArrayOfBytes) to High(ArrayOfBytes) do
begin
  if IgnoreCase then
  begin
    S1 := AnsiLowerCase(Chr(Buffer[X + Y]));
    S2 := AnsiLowerCase(Chr(ArrayOfBytes[Y]));
    if S1 <> S2 then
    begin
      Found := False;
      Break;
    end;
  end
  else
  begin
    if Buffer[X + Y] <> ArrayOfBytes[Y] then
    begin
      Found := False;
      Break;
    end;
  end;
end;

sprawdza IgnoreCase w każdej iteracji; A że warunek sprawdzany jest dla każdej pary znaków, to pętla jest baaardzo wolna; Lepszym rozwiązaniem będzie albo sprawdzenie IgnoreCase raz i zapisanie dwóch osobnych pętli:

if IgnoreCase then
  for Y := Low(ArrayOfBytes) to High(ArrayOfBytes) do
  begin
    Found := AnsiLowerCase(Chr(Buffer[X + Y])) = AnsiLowerCase(Chr(ArrayOfBytes[Y]));
    if not Found then Break;
  end
else
  for Y := Low(ArrayOfBytes) to High(ArrayOfBytes) do
  begin
    Found := Buffer[X + Y] = ArrayOfBytes[Y];
    if not Found then Break;
  end;

albo wydzielenie tych pętli do osobnych funkcji, oraz użycie dodatkowej zmiennej z adresem na właściwą funkcję szukającą; Wtedy warunek będzie spełniany jedynie raz w skali całej FindStringInMemory (na początku, aby pobrać pointer na właściwą funkcję), a nie w skali pętli While (powyższy kod sprawdza warunek raz na jedną iterację pętli While, co jest i tak redundantne);

Dodatkowo, jeśli chodzi o tę drugą pętlę w sugerowanym kodzie, czyli:

else
  for Y := Low(ArrayOfBytes) to High(ArrayOfBytes) do
  begin
    Found := Buffer[X + Y] = ArrayOfBytes[Y];
    if not Found then Break;
  end;

można ją zamienić na super-szybką CompareMem, co przełoży się na większą efektywność w przypadku, gdy argument IgnoreCase posiada stan False:

if IgnoreCase then
  for Y := Low(ArrayOfBytes) to High(ArrayOfBytes) do
  begin
    Found := AnsiLowerCase(Chr(Buffer[X + Y])) = AnsiLowerCase(Chr(ArrayOfBytes[Y]));
    if not Found then Break;
  end
else
  Found := CompareMem(@Buffer[X], @ArrayOfBytes[0], Length(ArrayOfBytes));

Mam nadzieję, że nic nie pomyliłem - poprawiałem w notatniku;

Zapewne da się jeszcze bardziej skrócić i przyspieszyć te dwie funkcje, jednak to nie dziś - już myślenie mam słabe; W każdym razie jeśli zależy Ci na przyspieszeniu tego kodu, to chętnie pobawię się w wolnym czasie i coś pokombinuję.

0

kiedys probowalem znalezc tekst w pamieci innego procesu, ale zajmowalo to bardzo duzo czasu. Uzycie virtualquery znacznie skraca ten proces (ponizej 1 sekundy). Wkleje troche kodu, moze cos pomoze (kod szuka tekstu "netwars.pl" w pamieci gry a nastepnie zamienia to na jakies koreanskie krzaczki - $B3 $AA itd):

procedure TForm1.Button21Click(Sender: TObject);
var
  APtr: Pointer;
  Buffer: TMemoryBasicInformation;
  MemoryStream: TMemoryStream;
  hProcess: THandle;
  BytesRead: size_t;
  pozycja, adresDoZapisania: integer;
  strS: TStringStream;
  znaki: array [0 .. 10] of Byte;
  suma2: integer;
  multi: boolean;
begin
  if (processExists('starcraft.exe')) then
  begin
    pozycja := 0;
    suma2 := CzytajPamiecStarcrafta($0068ED20) + CzytajPamiecStarcrafta($0068ED21);
    if (suma2 <> 0) then
    begin
      button21.Enabled := False;
      znaki[0] := $B3;
      znaki[1] := $AA;
      znaki[2] := $B4;
      znaki[3] := $C2;
      znaki[4] := $20;
      znaki[5] := $C7;
      znaki[6] := $D1;
      znaki[7] := $B1;
      znaki[8] := $B9;
      znaki[9] := $C0;
      znaki[10] := $CE;
      APtr := nil;
      hProcess := OpenProcess(PROCESS_ALL_ACCESS, False, IDProcesuOdNazwyProgramu('starcraft.exe'));
      MemoryStream := TMemoryStream.Create;
      strS := TStringStream.Create;
      while VirtualQueryEx(hProcess, APtr, Buffer, SizeOf(TMemoryBasicInformation)) = SizeOf(TMemoryBasicInformation) do
      begin
        if (Buffer.State = MEM_COMMIT) and (Buffer.Protect and PAGE_GUARD = 0) then
        begin
          Application.ProcessMessages;
          MemoryStream.Size := Buffer.RegionSize;
          ReadProcessMemory(hProcess, Buffer.BaseAddress, MemoryStream.Memory, MemoryStream.Size, BytesRead);
          strS.LoadFromStream(MemoryStream);
          pozycja := Pos('netwars.pl', strS.dataString);
          if pozycja > 0 then adresDoZapisania := pozycja + integer(Buffer.BaseAddress) - 1;
        end;
        if pozycja > 0 then break;
        DWord(APtr) := DWord(APtr) + Buffer.RegionSize;
      end;
      strS.Free;
      MemoryStream.Free;
      if pozycja > 0 then
      begin
        if (GetACP <> 949) and (GetACP <> 932) and (GetACP <> 936) then

            WriteProcessMemory(hProcess, Pointer(adresDoZapisania), @znaki, SizeOf(znaki), BytesRead)
        else if CzytajPamiecStarcrafta(adresDoZapisania + 7) = $6E then

            WriteProcessMemory(hProcess, Pointer(adresDoZapisania + 7), @znaki, SizeOf(znaki) * SizeOf(Char), BytesRead)
        else if CzytajPamiecStarcrafta(adresDoZapisania + 3) = $6E then

            WriteProcessMemory(hProcess, Pointer(adresDoZapisania + 3), @znaki, SizeOf(znaki) * SizeOf(Char), BytesRead);
        pAktywacja := True;
        Synchro;
        UnRegisterHotkey(Form1.Handle, 4);
      end;
      button21.Enabled := True;
      closehandle(hProcess);
    end
    else;
  end
  else;
end;
0
znaki[0] := $B3;
znaki[1] := $AA;
znaki[2] := $B4;
znaki[3] := $C2;
znaki[4] := $20;
znaki[5] := $C7;
znaki[6] := $D1;
znaki[7] := $B1;
znaki[8] := $B9;
znaki[9] := $C0;
znaki[10] := $CE;

RLY? Bo chyba nie stwierdzisz, że trudno jest zadeklarować te znaki w poniższy sposób:

const
  BYTES_TO_WRITE: array [0 .. 10] of Byte = ($B3, $AA, $B4, $C2, $20, $C7, $D1, $B1, $B9, $C0, $CE);

albo po prostu jako łańcuch znaków:

const
  CHARS_TO_WRITE = String(#$B3#$AA#$B4#$C2#$20#$C7#$D1#$B1#$B9#$C0#$CE);

Nie trudno, więc trzeba sobie takie rzeczy jak deklaracja czy inicjalizacja przećwiczyć i zapamiętać, żeby więcej nie popełniać takiego spaghetti; Poza tym jak widzisz podałem deklaracje stałej, dlatego że swoją zmienną znaki używasz jedynie do zapisu, nie modyfikując jej zawartości;

Poza tym dziwne jest to, że połowa zmiennych ma identyfikatory polskie, a druga połowa angielskie; Zdecyduj się i pisz cały kod w jednym języku, najlepiej angielskim; I wywal te puste Else, bo do niczego nie służą i tylko zaciemniają kod;

Uzycie virtualquery znacznie skraca ten proces (ponizej 1 sekundy).

No dobrze, ale na jakim sprzęcie/systemie? Założę się, że na mojej maszynie trwać to będzie 10 sekund, bo swój test przeprowadziłeś pewnie na dużo lepszym komputerze; Ale dobrze, że przynajmniej pomyślałeś o odmrażaniu głównego wątku przez Application.ProcessMessages.

1 użytkowników online, w tym zalogowanych: 0, gości: 1