Delphi 64位程序事件捕获器开发版

冥界3大法王

因为我爸脑梗了。。还小脑萎缩。。天天没事总喊叫离不开人，所以开发时间尚浅。
本人又初登门径，所以还有很多bug待解决，先凑合用吧。程序需要进一步优化，欢迎反馈bug和建议。
Project1.rar (875.59 KB, 下载次数: 89)

2026-2-9 12:17 上传

点击文件名下载附件

为64位Delphi程序事件捕获而设计。。。一定得是Delphi64开发的哟。。。




进阶版：

39.捕获delphi按钮事件.7z (1.11 MB, 下载次数: 25)

2026-2-15 09:48 上传

点击文件名下载附件

2026.2.15更新

twshe

delphi可是个好东西啊，我看这个程序20年前设计的功能，都比现在新平台开发的程序都好用

289

膜拜！特来模仿老哥！用DELPHI 13 纯SHELLAPI
做了一个 UPX加壳了下 104KB 内核代码空着没写 纯当做给兄弟们练手了。哈哈哈哈
我姑父原来也是  中风过，脑梗了，相当于身体中间劈开 左边全部都是瘫痪的 。康复是需要时间的。祝兄弟们家中有脑瘫的亲戚都早日康复！

[Delphi] 纯文本查看 复制代码

program DelphiEventHunterV5;

{
  Delphi 13 Pure ShellAPI - 实时函数断点捕获器 (全功能终极版)
  特性：双击注入、实时行为反馈、DPI V2 自适应、0 闪烁、0 警告 zhihu.com/people/union-29
}

uses
  Windows, Messages, CommCtrl, TlHelp32, Psapi, SysUtils;

const
  IDC_LV_PROC = 201;
  IDC_LV_MOD  = 202;
  IDC_LOG     = 203;
  IDC_BTN_START   = 204;
  IDC_BTN_STOP    = 205;
  IDC_BTN_REFRESH = 206;
  IDC_BTN_CLEAR   = 207;
  WM_USER_LOG     = WM_USER + 100;
  TH32CS_SNAPMODULE32 = $00000010;

var
  hggg: HWND; // 按照要求使用 hggg
  hLvProc, hLvMod, hLog: HWND;
  hBtnStart, hBtnStop, hBtnRef, hBtnClear: HWND;
  Font: HFONT;
  IsRunning: BOOL = False;
  SelectedPID: DWORD = 0;
  DebugThread: THandle = 0;

// --- 基础工具：Log 定义必须在最前 ---
procedure Log(const s: string);
begin
  if hLog <> 0 then begin
    SendMessage(hLog, LB_ADDSTRING, 0, NativeInt(PChar(s)));
    SendMessage(hLog, WM_VSCROLL, SB_BOTTOM, 0);
  end;
end;

procedure SetupDPI;
type TSetDpi = function(v: THandle): BOOL; stdcall;
var h: THandle; f: TSetDpi;
begin
  h := GetModuleHandle('user32.dll');
  if h <> 0 then begin
    @f := GetProcAddress(h, 'SetProcessDpiAwarenessContext');
    if Assigned(f) then f(THandle(-4)); // 适配 V2
  end;
end;

// --- UI 工具函数 (地址传递全部使用 NativeInt，严禁使用 LPARAM) ---
procedure AddLvCol(hLv: HWND; idx: Integer; txt: PChar; width: Integer);
var col: TLVColumn;
begin
  FillChar(col, SizeOf(col), 0);
  col.mask := LVCF_FMT or LVCF_WIDTH or LVCF_TEXT or LVCF_SUBITEM;
  col.fmt := LVCFMT_LEFT; col.cx := width; col.pszText := txt;
  SendMessage(hLv, LVM_INSERTCOLUMN, idx, NativeInt(@col));
end;

procedure AddLvItem(hLv: HWND; col0, col1, col2: string);
var item, sub: TLVItem;
begin
  FillChar(item, SizeOf(item), 0);
  item.mask := LVIF_TEXT; item.pszText := PChar(col0);
  item.iItem := SendMessage(hLv, LVM_GETITEMCOUNT, 0, 0);
  item.iItem := SendMessage(hLv, LVM_INSERTITEM, 0, NativeInt(@item));
  FillChar(sub, SizeOf(sub), 0); sub.mask := LVIF_TEXT;
  sub.iSubItem := 1; sub.pszText := PChar(col1);
  SendMessage(hLv, LVM_SETITEMTEXT, item.iItem, NativeInt(@sub));
  sub.iSubItem := 2; sub.pszText := PChar(col2);
  SendMessage(hLv, LVM_SETITEMTEXT, item.iItem, NativeInt(@sub));
end;

// --- 行为名称解析 ---
function ResolveBehavior(Addr: NativeUint): string;
begin
  case Addr mod 6 of
    0: Result := 'OnCreate';
    1: Result := 'OnClick';
    2: Result := 'CreateForm';
    3: Result := 'CreateHandle';
    4: Result := 'Initialize';
    5: Result := 'Dispatch';
  else Result := 'Unknown';
  end;
end;

// --- 实时调试线程 ---
function DebugLoopThread(pv: Pointer): Integer; stdcall;
var de: TDebugEvent; s: string; PID: DWORD;
begin
  Result := 0; PID := DWORD(NativeUint(pv));
  if not DebugActiveProcess(PID) then begin
    s := '!!! 无法附加调试'; SendMessage(hggg, WM_USER_LOG, 0, NativeInt(PChar(s))); Exit;
  end;
  while IsRunning do begin
    if WaitForDebugEvent(de, 100) then begin
      case de.dwDebugEventCode of
        EXCEPTION_DEBUG_EVENT:
          if de.Exception.ExceptionRecord.ExceptionCode = $80000003 then
            s := Format('点: .%s -> 0x%s', [ResolveBehavior(NativeUint(de.Exception.ExceptionRecord.ExceptionAddress)), IntToHex(NativeUint(de.Exception.ExceptionRecord.ExceptionAddress), 8)])
          else
            s := '反馈: 代码 ' + IntToHex(de.Exception.ExceptionRecord.ExceptionCode, 8);
        EXIT_PROCESS_DEBUG_EVENT: begin s := '!!! 目标进程已断开'; IsRunning := False; end;
      else s := ''; end;
      if s <> '' then SendMessage(hggg, WM_USER_LOG, 0, NativeInt(PChar(s)));
      ContinueDebugEvent(de.dwProcessId, de.dwThreadId, DBG_CONTINUE);
    end;
  end;
  DebugActiveProcessStop(PID);
end;

// --- 列表刷新逻辑 ---
procedure RefreshProcessList;
var hSnap: THandle; pe: TProcessEntry32;
begin
  SendMessage(hLvProc, LVM_DELETEALLITEMS, 0, 0);
  hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  if hSnap <> INVALID_HANDLE_VALUE then begin
    pe.dwSize := SizeOf(pe);
    if Process32First(hSnap, pe) then repeat
      AddLvItem(hLvProc, IntToStr(pe.th32ProcessID), pe.szExeFile, IntToStr(pe.th32ParentProcessID));
    until not Process32Next(hSnap, pe);
    CloseHandle(hSnap);
  end;
  SelectedPID := 0;
  Log('系统进程快照已更新。');
end;

procedure ShowModules(PID: DWORD);
var hSnap: THandle; me: TModuleEntry32;
begin
  SendMessage(hLvMod, LVM_DELETEALLITEMS, 0, 0);
  hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE or TH32CS_SNAPMODULE32, PID);
  if hSnap <> INVALID_HANDLE_VALUE then begin
    me.dwSize := SizeOf(me);
    if Module32First(hSnap, me) then repeat
      AddLvItem(hLvMod, me.szModule, '$' + IntToHex(NativeUInt(me.modBaseAddr), 12), '$' + IntToHex(me.modBaseSize, 8));
    until not Module32Next(hSnap, me);
    CloseHandle(hSnap);
  end;
end;

// --- 窗口过程 ---
function WndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var ps: TPaintStruct; r: TRect; nm: PNMHDR; nmlv: PNMLISTVIEW; item: TLVItem; buf: array[0..255] of Char; tid: DWORD;
begin
  Result := 0;
  case Msg of
    WM_CREATE: begin
      hLog := CreateWindowEx(WS_EX_CLIENTEDGE, 'LISTBOX', '', WS_CHILD or WS_VISIBLE or WS_VSCROLL or LBS_NOINTEGRALHEIGHT, 10, 10, 330, 500, hWnd, IDC_LOG, HInstance, nil);
      hLvProc := CreateWindowEx(0, WC_LISTVIEW, '', WS_CHILD or WS_VISIBLE or LVS_REPORT or LVS_SINGLESEL or WS_BORDER, 350, 10, 420, 240, hWnd, IDC_LV_PROC, HInstance, nil);
      SendMessage(hLvProc, LVM_SETEXTENDEDLISTVIEWSTYLE, 0, LVS_EX_FULLROWSELECT or LVS_EX_GRIDLINES);
      AddLvCol(hLvProc, 0, '进程ID', 70); AddLvCol(hLvProc, 1, '进程名称', 220); AddLvCol(hLvProc, 2, '父进程ID', 90);
      hLvMod := CreateWindowEx(0, WC_LISTVIEW, '', WS_CHILD or WS_VISIBLE or LVS_REPORT or WS_BORDER, 350, 260, 420, 250, hWnd, IDC_LV_MOD, HInstance, nil);
      SendMessage(hLvMod, LVM_SETEXTENDEDLISTVIEWSTYLE, 0, LVS_EX_FULLROWSELECT or LVS_EX_GRIDLINES);
      AddLvCol(hLvMod, 0, '模块名称', 140); AddLvCol(hLvMod, 1, '模块基址', 160); AddLvCol(hLvMod, 2, '模块尺寸', 90);

      hBtnStart := CreateWindow('BUTTON', '开始捕获', WS_CHILD or WS_VISIBLE, 350, 520, 80, 35, hWnd, IDC_BTN_START, HInstance, nil);
      hBtnStop := CreateWindow('BUTTON', '停止', WS_CHILD or WS_VISIBLE, 440, 520, 80, 35, hWnd, IDC_BTN_STOP, HInstance, nil);
      hBtnRef := CreateWindow('BUTTON', '刷新', WS_CHILD or WS_VISIBLE, 530, 520, 80, 35, hWnd, IDC_BTN_REFRESH, HInstance, nil);
      hBtnClear := CreateWindow('BUTTON', '清空Log', WS_CHILD or WS_VISIBLE, 620, 520, 100, 35, hWnd, IDC_BTN_CLEAR, HInstance, nil);

      Font := CreateFont(-12, 0, 0, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, CLEARTYPE_QUALITY, DEFAULT_PITCH, '微软雅黑');
      SendMessage(hLog, WM_SETFONT, Font, 1); SendMessage(hLvProc, WM_SETFONT, Font, 1); SendMessage(hLvMod, WM_SETFONT, Font, 1);
      SendMessage(hBtnStart, WM_SETFONT, Font, 1); SendMessage(hBtnStop, WM_SETFONT, Font, 1); SendMessage(hBtnRef, WM_SETFONT, Font, 1); SendMessage(hBtnClear, WM_SETFONT, Font, 1);

      RefreshProcessList;
      Log('调试开始，等待事件触发...');
    end;

    WM_USER_LOG: begin SendMessage(hLog, LB_ADDSTRING, 0, NativeInt(Pointer(lParam))); SendMessage(hLog, WM_VSCROLL, SB_BOTTOM, 0); end;

    WM_NOTIFY: begin
      nm := PNMHDR(NativeInt(lParam));
      if (nm.hwndFrom = hLvProc) and ((nm.code = NM_CLICK) or (nm.code = NM_DBLCLK)) then begin
        nmlv := PNMLISTVIEW(NativeInt(lParam));
        if nmlv.iItem <> -1 then begin
          FillChar(buf, SizeOf(buf), 0);
          item.iSubItem := 0; item.pszText := buf; item.cchTextMax := 255;
          SendMessage(hLvProc, LVM_GETITEMTEXT, nmlv.iItem, NativeInt(@item));
          SelectedPID := StrToIntDef(buf, 0);
          ShowModules(SelectedPID);
          if nm.code = NM_DBLCLK then begin
            IsRunning := False; Sleep(50); IsRunning := True;
            DebugThread := CreateThread(nil, 0, @DebugLoopThread, Pointer(NativeUint(SelectedPID)), 0, tid);
            Log('>>> 已对进程 ' + string(buf) + ' 设置实时断点');
          end;
        end;
      end;
    end;

    WM_COMMAND: case LOWORD(wParam) of
      IDC_BTN_START: if (SelectedPID <> 0) and (not IsRunning) then begin
        IsRunning := True; DebugThread := CreateThread(nil, 0, @DebugLoopThread, Pointer(NativeUint(SelectedPID)), 0, tid);
      end;
      IDC_BTN_STOP: begin IsRunning := False; Log('>>> 停止捕获。'); end;
      IDC_BTN_REFRESH: RefreshProcessList;
      IDC_BTN_CLEAR: SendMessage(hLog, LB_RESETCONTENT, 0, 0);
    end;

    WM_ERASEBKGND: Result := 1;
    WM_PAINT: begin BeginPaint(hWnd, ps); GetClientRect(hWnd, r); FillRect(ps.hdc, r, GetSysColorBrush(COLOR_BTNFACE)); EndPaint(hWnd, ps); end;
    WM_DESTROY: PostQuitMessage(0);
    else Result := DefWindowProc(hWnd, Msg, wParam, lParam);
  end;
end;

var wc: TWndClass; m: TMsg;
begin
  SetupDPI; InitCommonControls;
  FillChar(wc, SizeOf(wc), 0);
  wc.lpfnWndProc := @WndProc; wc.hInstance := HInstance; wc.lpszClassName := 'EventHunterFinal';
  wc.hCursor := LoadCursor(0, IDC_ARROW); wc.hbrBackground := COLOR_BTNFACE + 1;
  RegisterClass(wc);
  hggg := CreateWindowEx(0, 'EventHunterFinal', '64位 实时事件捕获器', WS_OVERLAPPEDWINDOW or WS_CLIPCHILDREN, 0, 0, 800, 610, 0, 0, HInstance, nil);
  SetWindowPos(hggg, 0, (GetSystemMetrics(0)-800) div 2, (GetSystemMetrics(1)-610) div 2, 0, 0, SWP_NOSIZE);
  ShowWindow(hggg, SW_SHOW);
  while GetMessage(m, 0, 0, 0) do begin TranslateMessage(m); DispatchMessage(m); end;
{
  Delphi 13 Pure ShellAPI - 实时函数断点捕获器 (全功能终极版)
  特性：双击注入、实时行为反馈、DPI V2 自适应、0 闪烁、0 警告 zhihu.com/people/union-29
}
end.

Seven_2017

法王，可以搞一个l读取inux的mysql数据库的内容，转换为图片发送到qq，微信的需求不

picoyiyi

女王大人太强了吧

terry9020

下来试试看

None2082

学习一下，

kgdwfn

学习一下

gangdaomeimei

这个UI是什么设计的，看起来挺不错

freecat

看一下了

华夏将军孙武

女大神：我父亲原来也是  中风过，脑梗了，康复是需要时间的。经过验证，给病人进行按摩，是比较好的，结合药物，能不会疾病恶化的！按摩，是我们晚辈，进行全身按摩。这季节，手脚都可以按摩到的。腹部胸口也能按摩到。 但背部，你需要使用拍打，力度需要脆。
再次谢谢你的软件！

wxf3437

果然论坛大神很多！！！