unit1.pas

一个由DELPHI做的内在搜索工具源码,非常好用,直接编译就可以了

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button5: TButton;
    procedure Button5Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

function EnabledDebugPrivilege(const bEnabled: Boolean): Boolean; //激活或者停止Debug权限
var
  hToken: THandle;
  tp: TOKEN_PRIVILEGES;
  a: DWORD;
const
  SE_DEBUG_NAME = 'SeDebugPrivilege';
begin
  Result := False;
  if (OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES,
    hToken)) then
  begin
    tp.PrivilegeCount := 1;
    LookupPrivilegeValue(nil, SE_DEBUG_NAME, tp.Privileges[0].Luid);
    if bEnabled then
      tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED
    else
      tp.Privileges[0].Attributes := 0;
    a := 0;
    AdjustTokenPrivileges(hToken, False, tp, SizeOf(tp), nil, a);
    Result := GetLastError = ERROR_SUCCESS;
    CloseHandle(hToken);
  end;
end;

function Int2Hex(Value: Integer): string;
var
  iTemp: Integer;
  i: Integer;
const
  HexArr: array[0..15] of string = ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F');
begin
  Result := '';
  i := 0;
  while i < 4 do
  begin
    case i of
      0: iTemp := Value shr 24 and $FF;
      1: iTemp := Value shr 16 and $FF;
      2: iTemp := Value shr 8 and $FF;
      3: iTemp := Value and $FF;
    end;
    if not Boolean(iTemp) then Result := Result + '00'
    else begin
      Result := Result + HexArr[iTemp div 16];
      Result := Result + HexArr[iTemp mod 16];
    end;
    Inc(i);
  end;
end;

function Replacing(S, source, target: string): string;
var
  site, StrLen: integer;
begin
  site := pos(source, s);
  while site > 0 do
  begin
    StrLen := length(source);
    Delete(s, site, StrLen);
    Insert(target, s, site);
    site := pos(source, s);
  end;
  Result := s;
end;

procedure Searchbyte(s: string; ptr: pbyte);
const HEX: array['a'..'f'] of integer = (10, 11, 12, 13, 14, 15);
var
  int, i: integer;
  bb: byte;
  B: string;
begin
  bb := 0;
  while Length(S) > 0 do
  begin
    B := copy(s, 1, 2);
    bb := 0;
    if b[1] < 'a' then bb := bb * 16 + ord(b[1]) - 48
    else bb := bb * 16 + HEX[b[1]];
    if b[2] < 'a' then bb := bb * 16 + ord(b[2]) - 48
    else bb := bb * 16 + HEX[b[2]];
    ptr^ := bb;
    inc(ptr);
    S := copy(S, 3, length(S) - 2);
  end;
end;

function Searching(s: string; Addr: pbyte; ALength: Integer): Integer;
var
  memtype: TMemoryBasicInformation;
  startadr: dword;
  ptrs1, ptrt, ptrt1: Pbyte;
  i, ii: integer;
  x, xx: integer;
  TarLen: integer;
  ok: integer;
  j: integer;
begin
  i := 0;
  s := Replacing(s, ' ', '');
  s := LowerCase(s);
  if length(s) mod 2 <> 0 then s := '0' + s;
  TarLen := length(s) div 2;
  ptrt := AllocMem(TarLen);
  ptrt1 := ptrt;
  Searchbyte(s, ptrt);
  ok := 0;
  i := 0;
  j := 0;
  while (ok = 0) and (i < ALength) do
  begin
    //application.processMessages; //处理事件
    i := i + 1;
    x := Addr^;
    xx := ptrt^;
    if xx = x then
    begin
      for ii := 1 to TarLen do
      begin
        x := Addr^;
        xx := ptrt^;
        if x = xx then
        begin
          if ii = TarLen then
          begin
            ok := 1;
            j := i - TarLen;
            ptrt := ptrt1;
            break;
          end;
          inc(Addr);
          inc(ptrt);
          i := i + 1;
        end
        else
        begin
          ptrt := ptrt1;
          break;
        end;
      end;
    end;
    inc(Addr);
  end;

  ptrt := ptrt1;
  FreeMem(ptrt, TarLen);
  Result := j;
end;

procedure SearchAdr(hProcess: THandle);
var
  memtype: TMemoryBasicInformation;
  startadr: dword;
  ptr, ptr2, ptr3: pbyte;
  adr, adrlen: integer;
  x, y: integer;
  lpNumberOfBytes: Cardinal;
  sj: TSystemTime;
  ms: word;
begin
  startadr := 0;
  x := 0;
  while VirtualQueryEx(hProcess, pointer(startadr), memtype, sizeof(memtype)) = 28 do
  begin
    if startadr = 4198400 then
    begin
      ptr := AllocMem(memtype.RegionSize);
      ptr2 := ptr;
      ReadProcessMemory(hProcess, Pointer(startadr), ptr, memtype.RegionSize, lpNumberOfBytes);
      adr := integer(ptr);
      adrlen := memtype.RegionSize;
      GetSystemTime(sj);
      ms := sj.wMilliseconds;
      y := Searching('8B401C8B402485C075', ptr, memtype.RegionSize);
      y := startadr + y - 4;
      ReadProcessMemory(hProcess, Pointer(y), @x, 4, lpNumberOfBytes);
      GetSystemTime(sj);
      ms := sj.wMilliseconds - ms;
      form1.Caption := int2hex(x) + '费时：' + inttostr(ms) + '毫秒';
      ptr := ptr2;
      FreeMem(ptr, memtype.RegionSize);
    end;
    startadr := startadr + memtype.RegionSize;
  end;
end;

procedure TForm1.Button5Click(Sender: TObject);
var
  aproc: dword;
  hProcess: THandle;
  Fhwnd: hwnd;
  y: integer;
begin
  EnabledDebugPrivilege(true);
  Fhwnd := FindWindowA(0, 'Element Client');
  if Fhwnd > 0 then
  begin
    GetWindowThreadProcessId(Fhwnd, aproc);
    hProcess := OpenProcess(PROCESS_ALL_ACCESS, False, aproc);
    y := GetLastError;
    form1.Caption := inttostr(y);
    SearchAdr(hProcess);
    CloseHandle(hProcess);

  end
  else
  begin

  end;

end;

end.