程序師世界是廣大編程愛好者互助、分享、學習的平台,程序師世界有你更精彩!
首頁
編程語言
C語言|JAVA編程
Python編程
網頁編程
ASP編程|PHP編程
JSP編程
數據庫知識
MYSQL數據庫|SqlServer數據庫
Oracle數據庫|DB2數據庫
 程式師世界 >> 編程語言 >> 更多編程語言 >> Delphi >> QQ聊天記錄器演示程序(一)

QQ聊天記錄器演示程序(一)

編輯:Delphi

噓!好不容易有了一點輕松點的時候.現在才有時間把前幾天做的QQ聊天記錄器發上來和大家一起分享.做這個程序是看到最近網上有一個叫QQAutoReorder的軟件.它所實現的功能就是對QQ聊天記錄進行記錄.所采用的技術是:對QQ對話框進行掛鉤.它並不能對用戶沒有點擊的QQ消息進行記錄.(我認為若想對QQ消息進行實時記錄,意思就是不等QQ消息框出來就記錄下QQ的消息.可能只能去攔截QQ的數據封包了吧.我也花了一天時間在這上面,但最後的結論是’太自不量力了’^_^看來QQ的數據封包可不是那麼容易就能得到的L)

  言歸正傳:本文采用對QQ消息框進行掛鉤了方法(一來比較容易實現,二來也是大多數此類程序通用的方法.)為了簡化程序:我將此程序分為兩部實現(均於QQ2004下實現,到最後在兼容QQ2003的版本):

  一.  捕獲別人給自己發來的消息:

  既然是掛鉤QQ的消息框,自然得從眾多的鉤子類型中找出一種最為合理,也最方便的.很容易想到的是無論你用什麼方式查看QQ的消息.總會導致一個QQ消息窗體的生成.就是會產生一個CREATE事件.從這一點上看,用一個WH_SHELL鉤子是比較明智的.

  幫助上對WH_SHELL的說明是:監控Windows外殼通知消息,例如頂級窗口的創建的釋放.我們這裡要關心是窗口的創建消息.

  由於有可能一次出現多個QQ消息窗口的情況,我在這裡使用全局鉤子:並定義以下數據結構:

  HookType.Pas單元
  unit HookType;
  interface
  uses
  Windows, Messages;
const
  WM_USERCMD  = WM_APP + 1; //用戶自定應用程序級消息
  UC_WINCREATE = WM_APP + 2;  //QQ消息窗口創建
  UC_WINDESTROY = WM_APP + 3; //發送QQ消息
  BUFFER_SIZE = 16 * 1024;
  HOOK_MEM_FILENAME = 'MEM_FILE';
  type
  TShared = record
  KeyHook : HHook;  //鍵盤鉤子
  ShellHook: HHook;
  CallHook : HHook;
  MainWnd : THandle; //窗體的Handle(非Application.Handle)
  Moudle : THandle; //DLL
  end;
  PShared = ^TShared;
  implementation
  end.

  DLL單元代碼

  var
  MemFile: THandle;
  Shared: PShared;
  function ShellProc(iCode: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
  begin
  case iCode of
  HSHELL_WINDOWCREATED:
  //有頂級窗口創建時向演示程序發送自己定義消息WM_USERCMD. Wparamr參數說明
  // wParam specifIEs the handle of the window being created or destroyed, respectively.
  PostMessage(Shared^.MainWnd,WM_USERCMD ,UC_WINCREATE,wParam);
  end;
  Result := CallNextHookEx(Shared^.ShellHook,iCode,wParam,lParam);
  end;
  function InstallHook:Boolean;
  begin
  Shared^.Moudle:=GetModuleHandle(PChar('QQhook')); //QQhook是我的DLL文件名.
  Shared^.ShellHook := SetWindowsHookEx(WH_SHELL,
  @ShellProc,
   Shared^.Moudle,
  0);
  if Shared^.ShellHook = 0 then
  begin
  Result := False;
  Exit;
  end;
  Result := true;
  end;

  {撤消鉤子過濾函數}

  function UninstallHook: Boolean;
  begin
  Freelibrary(Shared^.Moudle);
  Result:=UnHookWindowsHookEx(Shared^.ShellHook);
  UnmapVIEwOfFile(Shared);
  CloseHandle(memFile);
  end;
  procedure DllEntry(dwReason : integer);
  begin
  case dwReason Of
  DLL_PROCESS_ATTACH:
   begin
  MemFile:= OpenFileMapping(FILE_MAP_WRITE,False,HOOK_MEM_FILENAME);
  if MemFile = 0 then
  MemFile := CreateFileMapping($FFFFFFFF,nil,
  PAGE_READWRITE,
  0,
  SizeOf(TShared),
  HOOK_MEM_FILENAME);
  Shared := MapVIEwOfFile(MemFile,
  File_MAP_WRITE,
  0,
  0,
  0);
  end;
  DLL_PROCESS_DETACH:
  begin
  //UninstallHook;
  end;
  else;
  end;
  end;
  exports
  InstallHook;
  begin
  
 DllProc := @DllEntry;
  DllEntry(DLL_PROCESS_ATTACH);
  end.

 //上述代碼對卸載鉤子沒有加太多說明,它不屬於此范圍討論之內.

  演示程序代碼

  procedure TForm1.Button1Click(Sender: TObject);
  begin
  InstallHook;
  end;
  procedure TForm1.FormCreate(Sender: TObject);
  begin
  MemFile:= OpenFileMapping(FILE_MAP_WRITE,False,HOOK_MEM_FILENAME);
  if MemFile = 0 then
  MemFile := CreateFileMapping($FFFFFFFF,nil,
  PAGE_READWRITE,
  0,
  SizeOf(TShared),
  HOOK_MEM_FILENAME);
  Shared := MapVIEwOfFile(MemFile,
  File_MAP_WRITE,
  0,
  0,
  0);
  Shared^.MainWnd := Handle;  //保存窗體句柄
  end;
  //窗口消息處理過程
  procedure TForm1.WndProc(var Msg: TMessage);
  begin
  with Msg do
  begin
  if Msg = WM_USERCMD then  //DLL發來的自定義消息
  begin
  case wParam of
  UC_WINCREATE :     //QQ消息框創建
  begin
  GetText(Findhwd(HWND(lParam))); //得到QQ消息框裡的文本
  end;
  end;
   end;
  end;
  inherited;
  end;
  //通過wParam參數找到QQ窗口句柄
  function TForm1.Findhwd(parent: HWND):HWND;
  var
  hwd,hBtn,hMemo:HWND;
  begin
  result := 0;
  
  hwd:=findwindowex(parent,0,'#32770',nil); //QQ次級窗口句柄QQ2003及以前版本沒有此項.
  if (hwd<>0) then
  begin
  hBtn := FindwindowEX(hwd,0,nil,'回訊息(&R)');  //可以以此來證明是收到的QQ消息框.
  if (hBtn<>0) then
  begin
  hMemo := GetDlgItem(hwd,$00000380);    //RichEdit的句柄,QQ消息就存在於此處.
  if (hMemo<>0) then
  result := hMemo;
  end;
  end;
  end;
  //得到指定句柄控件中的文本.
  procedure TForm1.GetText(hwd: HWND);
  var
  Ret: LongInt;
  
 QQText: PChar;
  Buf: integer;
  begin
  GetMem(QQText,1024);
  if (hwd<>0) then
  begin
  try
  Ret := SendMessage(hwd, WM_GETTEXTLENGTH, 0, 0) + 1;
  Buf := LongInt(QQText);
  SendMessage(hwd, WM_GETTEXT, Min(Ret, 1024), Buf);
  memo1.Lines.Add(QQText); //在Memo中顯示文本
  finally
  FreeMem(QQText, 1024);
  end;
  end;
  end;

  以上是我測試時的代碼,只是為了分類闡述的方便,才帖出來.也許還有些不合理的地方. 若這裡有什麼不詳盡之處,在下篇將提供完整代碼下載.




  1. 上一頁:
  2. 下一頁:
Copyright © 程式師世界 All Rights Reserved