【300分】VNCHook For Delphi源码(300分)

xzhifei · 2006-04-20

大名鼎鼎的WinVNC远程控制软件几年前就公开了VC源码，不过一直没有DELPHI的源码，最近终于从网上搜索到的，对比VC的源码，基本上是直接转过来的，不过有点问题，只能截获到当前EXE主窗口的消息，很奇怪，大家看看，哪里有问题，希望能解决这个问题 全部文件下载： http://www.xplan.cn/VNC.rar 源码部分： //*********************************** //DLL部分 library hthooks; uses  Windows,  UCallBacks in 'UCallBacks.pas'; {$R *.RES} exports  SetHook index 1 Name 'SetHook',  UnSetHook index 2 Name 'UnSetHook',  SetKeyboardFilterHook Index 3 Name 'SetKeyboardFilterHook',  SetMouseFilterHook Index 4 Name 'SetMouseFilterHook'; procedure DllEntryPoint(dwReason: DWord); begin  case dwReason of    Dll_Process_Attach: InitInstance;    Dll_Process_Detach: ExitInstance;  end; end; begin  DLLProc := @DllEntryPoint;  DllEntryPoint(Dll_Process_Attach) end. //********************************* unit UCallBacks; interface uses Windows, Messages, SysUtils; ///////////////////////////////////////////////////////////////////////////-/ // Storage for the global data in the DLL var  hVeneto: HWND = 0;  UpdateRectMessage: UINT = 0;  CopyRectMessage: UINT = 0;  MouseMoveMessage: UINT = 0;  hCallWndHook: HHOOK = 0; // Handle to the CallWnd hook  hGetMsgHook: HHOOK = 0; // Handle to the GetMsg hook  hDialogMsgHook: HHOOK = 0; // Handle to the DialogMsg hook  hLLKeyboardHook: HHOOK = 0; // Handle to LowLevel kbd hook  hLLMouseHook: HHOOK = 0; // Handle to LowLevel mouse hook ///////////////////////////////////////////////////////////////////////////-/  // Per-instance DLL variables  //  const  //  char sPrefSegment[] = "Application_Prefs//"; var  sModulePrefs: PChar = nil; // Name of the module that created us  prf_use_GetUpdateRect: Boolean = False; // Use the GetUpdateRect paint  mode  prf_use_Timer: Boolean = False; // Use Timer events to trigger updates  prf_use_KeyPress: Boolean = False; // Use keyboard events  prf_use_LButtonUp: Boolean = True; // Use left mouse button up events  prf_use_MButtonUp: Boolean = False; // Use middle mouse button up events  prf_use_RButtonUp: Boolean = False; // Use right mouse button up events  prf_use_Deferral: Boolean = False; // Use deferred updates  hModuleKey: HKEY = 0; // Key used to save settings  //  hInstance: HINSTANCE = NULL; // This instance of the DLL  HookMaster: Boolean = False; // Is this instance veneto itself?  appHookedOK: Boolean = False; // Did InitInstance succeed? ///////////////////////////////////////////////////////////////////////////-/  // Registered messages & atoms to be used by VNCHooks.DLL  // Messages var  VNC_DEFERRED_UPDATE: UINT = 0;  // Atoms  VNC_WINDOWPOS_ATOMNAME: TAtom = 0;  VNC_POPUPSELN_ATOMNAME: TAtom = 0;  VNC_WINDOWPOS_ATOM: TAtom = 0;  VNC_POPUPSELN_ATOM: TAtom = 0;  // Forward definition of hook procedures function HookHandle(Msg: LongWord; Wnd: HWND; wParam: Longint; lParam:  Longint): BOOL; stdcall; function CallWndProc(nCode: Integer; wParam: Longint; lParam: Longint):  LRESULT; stdcall; function GetMessageProc(nCode: Integer; wParam: Longint; lParam: Longint):  LRESULT; stdcall; function DialogMessageProc(nCode: Integer; wParam: Longint; lParam:  Longint): LRESULT; stdcall; function LowLevelKeyboardFilterProc(nCode: Integer; wParam: Longint; lParam:  Longint): LRESULT; stdcall; function LowLevelMouseFilterProc(nCode: Integer; wParam: Longint; lParam:  Longint): LRESULT; stdcall; function SetHook(Wnd: HWND; UpdateMsg: LongWord; CopyMsg: LongWord;  MouseMsg: LongWord): BOOL; stdcall; export; function UnSetHook(Wnd: HWND): BOOL; stdcall; export; function SetKeyboardFilterHook(Activate: BOOL): BOOL; stdcall; export; function SetMouseFilterHook(Activate: BOOL): BOOL; stdcall; export; // Forward definition of setup and shutdown procedures function InitInstance(): BOOL; function ExitInstance(): BOOL; implementation function DllMain(hInst: HWND; ul_reason_for_call: ULONG; lpReserved:  Integer): BOOL; stdcall; begin  // Find out why we're being called  case (ul_reason_for_call) of    DLL_PROCESS_ATTACH:      begin        // Call the initialisation function        appHookedOK := InitInstance();        // ALWAYS return TRUE to avoid breaking unhookable applications!!!        Result := True;      end;    DLL_PROCESS_DETACH:      begin        // Call the exit function        // If the app failed to hook OK, ExitInstance will still operate OK        (hopefully...)        ExitInstance();        Result := TRUE;      end;  else    Result := TRUE;  end; end; // Routine to start and stop local keyboard message filtering function SetKeyboardFilterHook(Activate: BOOL): BOOL; stdcall; begin  if (Activate) then  begin    if (hLLKeyboardHook = 0) then    begin      // Start up the hook...      hLLKeyboardHook := SetWindowsHookEx(        WH_KEYBOARD, // Hook in before msg reaches app        LowLevelKeyboardFilterProc, // Hook procedure        hInstance, // This DLL instance        0 // Hook in to all apps       &nbsp

;      if (hLLKeyboardHook = 0) then        Result := False      else        Result := TRUE;    end    else      Result := true;  end  else  begin    if (hLLKeyboardHook <> 0) then    begin      // Stop the hook...      Result := (UnhookWindowsHookEx(hLLKeyboardHook));      hLLKeyboardHook := 0;    end    else      Result := True;  end; end; // Routine to start and stop local mouse message filtering function SetMouseFilterHook(Activate: BOOL): BOOL; stdcall; begin  if (Activate) then  begin    Result := (hLLMouseHook = 0);    if Result then    begin      // Start up the hook...      hLLMouseHook := SetWindowsHookEx(        WH_MOUSE, // Hook in before msg reaches app        LowLevelMouseFilterProc, // Hook procedure        hInstance, // This DLL instance        0 // Hook in to all apps       &nbsp

;      if (hLLMouseHook = 0) then Result := False;    end;  end  else  begin    if (hLLMouseHook <> 0) then      Result := (UnhookWindowsHookEx(hLLMouseHook)) // Stop the hook...    else      Result := True;    hLLMouseHook := 0;  end; end; // Add the new hook function SetHook(Wnd: HWND; UpdateMsg: LongWord; CopyMsg: LongWord;  MouseMsg: LongWord): BOOL stdcall; begin  // Don't add the hook if the window ID is NULL  if (Wnd = 0) then  begin    Result := False;    exit;  end;  // Don't add a hook if there is already one added  if (hVeneto <> 0) then  begin    Result := False;    exit;  end;  // Add the CallWnd hook  hCallWndHook := SetWindowsHookEx(    WH_CALLWNDPROC, // Hook in before msg reaches app    CallWndProc, // Hook procedure    hInstance, // This DLL instance    0 // Hook in to all apps    //  GetWindowThreadProcessId(Wnd, nil) // DEBUG : HOOK ONLY WinVNC   &nbsp

;  // Add the GetMessage hook  hGetMsgHook := SetWindowsHookEx(    WH_GETMESSAGE, // Hook in before msg reaches app    GetMessageProc, // Hook procedure    hInstance, // This DLL instance    0 // Hook in to all apps    //  GetWindowThreadProcessId(Wnd, nil)  // DEBUG : HOOK ONLY WinVNC   &nbsp

;  // Add the GetMessage hook  hDialogMsgHook := SetWindowsHookEx(    WH_SYSMSGFILTER, // Hook in dialogs, menus and scrollbars    DialogMessageProc, // Hook procedure    hInstance, // This DLL instance    0 // Hook in to all apps   &nbsp

;  // Check that it worked  if ((hCallWndHook <> 0) and (hGetMsgHook <> 0) and (hDialogMsgHook <> 0))    then  begin    hVeneto := Wnd; // Save the WinRFB window handle    UpdateRectMessage := UpdateMsg; // Save the message ID to use for    rectangle updates    CopyRectMessage := CopyMsg; // Save the message ID to use for copyrect    MouseMoveMessage := MouseMsg; // Save the message ID to send when mouse    moves    HookMaster := TRUE; // Set the HookMaster flag for this instance    Result := True;  end  else  begin    // Stop the keyboard hook    SetKeyboardFilterHook(FALSE);    SetMouseFilterHook(FALSE);    // Kill the main hooks    if (hCallWndHook <> 0) then      UnhookWindowsHookEx(hCallWndHook);    if (hGetMsgHook <> 0) then      UnhookWindowsHookEx(hGetMsgHook);    if (hDialogMsgHook <> 0) then      UnhookWindowsHookEx(hDialogMsgHook);    hCallWndHook := 0;    hGetMsgHook := 0;    hDialogMsgHook := 0;    // The hook failed, so return an error code    Result := True;  end; end; // Remove the hook from the system function UnSetHook(Wnd: HWND): BOOL; stdcall; // EnumWindows procedure to remove the extra property we added  function KillPropsProc(Wnd: HWND; lParam: Longint): BOOL; stdcall;  begin    // Remove our custom property...    RemoveProp(Wnd, PChar(MAKEWORD(VNC_WINDOWPOS_ATOM, 0)));    RemoveProp(Wnd, PChar(MAKEWORD(VNC_POPUPSELN_ATOM, 0)));    Result := True;  end; var  unHooked: BOOL; begin  unHooked := True;  // Remove the extra property value from all local windows  EnumWindows(@KillPropsProc, 0);  // Stop the keyboard & mouse hooks  unHooked := unHooked and SetKeyboardFilterHook(FALSE);  unHooked := unHooked and SetMouseFilterHook(FALSE);  // Is the window handle valid?  if (Wnd = 0) then    MessageBox(GetDesktopWindow, 'Window pointer is null', nil, MB_OK);  // Is the correct application calling UnSetHook?  if (Wnd <> hVeneto) then    Result := False;  // Unhook the procs  if (hCallWndHook <> 0) then  begin    unHooked := unHooked and UnhookWindowsHookEx(hCallWndHook);    hCallWndHook := 0;  end;  if (hGetMsgHook <> 0) then  begin    unHooked := unHooked and UnhookWindowsHookEx(hGetMsgHook);    hGetMsgHook := 0;  end;  if (hDialogMsgHook <> 0) then  begin    unHooked := unHooked and UnhookWindowsHookEx(hDialogMsgHook);    hDialogMsgHook := 0;  end;  // If we managed to unhook then reset  if (unHooked) then  begin    hVeneto := 0;    HookMaster := False;  end;  Result := unHooked; end; // Routine to get the window's client rectangle, in screen coordinates function GetAbsoluteClientRect(Wnd: HWnd; var Rect: TRect): BOOL; var  topleft: TPoint; begin  topleft.x := 0;  topleft.y := 0;  Result := (GetClientRect(Wnd, Rect)); // Get the client rectangle size  if Result then    Result := (ClientToScreen(Wnd, topleft)); // Get the client rectangle  position  if Result then  begin    // Now adjust the window rectangle    rect.Left := rect.Left + topleft.x;    rect.Top := rect.Top + topleft.y;    rect.Right := rect.Right + topleft.x;    rect.Bottom := rect.Bottom + topleft.y;  end; end; (****************************************************************** // Routine to send a CopyRect message to WinVNC inline void SendCopyWindowRect(HWND hWnd) { WPARAM vwParam; // All we send back is the handle of the window to be moved vwParam = (LPARAM) hWnd; // Send the update to Veneto PostMessage(  hVeneto,  CopyRectMessage,  vwParam,  0 &nbsp

; } **********************************************) // Routine to send an UpdateRect message to Veneto //procedure SendUpdateRect(x, y, x2, y2: ShortInt); procedure SendUpdateRect(x, y, x2, y2: Smallint); var  vwParam: Longint;  vlParam: Longint; begin  OutputDebugString(PChar(IntToStr(x) + ',' + IntToStr

+ ',' + IntToStr(x2) + ',' + IntToStr(y2)));  vwParam := MAKELONG(x, y);  vlParam := MAKELONG(x2, y2);  // Send the update to Veneto  PostMessage(    hVeneto,    UpdateRectMessage,    vwParam,    vlParam   &nbsp

; end; // Send a window's position to Veneto procedure SendWindowRect(Wnd: HWND); var  wrect: TRect; begin  // Get the rectangle position  if (GetWindowRect(Wnd, wrect) and IsWindowVisible(Wnd)) then    // Send the position    SendUpdateRect(      wrect.Left,      wrect.Top,      wrect.Right,      wrect.Bottom     &nbsp

; end; // Send a deferred message into this Window's message queue, so that // we'll intercept it again only after the message that triggered it hasbeen // handled //procedure SendDeferredUpdateRect(Wnd: HWND; x, y, x2, y2: ShortInt); procedure SendDeferredUpdateRect(Wnd: HWND; x, y, x2, y2: Smallint); var  vwParam: Longint;  vlParam: Longint; begin  OutputDebugString(PChar(IntToStr(x) + ',' + IntToStr

+ ',' + IntToStr(x2) + ',' + IntToStr(y2)));  vwParam := MAKELONG(x, y);  vlParam := MAKELONG(x2, y2);  if (prf_use_Deferral) then    // Send the update back to the window    PostMessage(      Wnd,      VNC_DEFERRED_UPDATE,      vwParam,      vlParam     &nbsp

else    // Send the update to WinRFB    PostMessage(      hVeneto,      UpdateRectMessage,      vwParam,      vlParam     &nbsp

; end; procedure SendDeferredWindowRect(Wnd: HWND); var  wrect: TRect; begin  // Get the rectangle position  if (GetWindowRect(Wnd, wrect) and IsWindowVisible(Wnd)) then    // Send the position    SendDeferredUpdateRect(      Wnd,      wrect.left,      wrect.top,      wrect.right,      wrect.bottom     &nbsp

; end; procedure SendDeferredBorderRect(Wnd: HWND); var  wrect: TRect;  crect: TRect; begin  // Get the rectangle position  if (GetWindowRect(Wnd, wrect) and IsWindowVisible(Wnd)) then    // Get the client rectangle position    if (GetAbsoluteClientRect(Wnd, crect)) then    begin      // Send the four border rectangles      SendDeferredUpdateRect(Wnd, wrect.left, wrect.top, wrect.right,        crect.top);      SendDeferredUpdateRect(Wnd, wrect.left, wrect.top, crect.left,        wrect.bottom);      SendDeferredUpdateRect(Wnd, wrect.left, crect.bottom, wrect.right,        wrect.bottom);      SendDeferredUpdateRect(Wnd, crect.right, wrect.top, wrect.right,        wrect.bottom);    end; end; // Generic hook-handler function HookHandle(Msg: LongWord; Wnd: HWND; wParam: Longint; lParam:  Longint): BOOL; stdcall; var  Prop: HWnd;  region: HRGN;  buffsize: Integer;  x: Longint;  buff: PRgnData;  TopLeft: Tpoint;  uRect: PRect; begin  Result := True;  ////////////////////////////////////////////////////////////////  // *** HANDLE DEFERRED UPDATES ***  // Is this a deferred-update message?  if (Msg = VNC_DEFERRED_UPDATE) then  begin    // NOTE : NEVER use the SendDeferred- routines to send updates    //  from here, or you'll get an infinite loop....!    // NB : The format of DEFERRED_UPDATE matches that of UpdateRectMessage,    //  so just send the exact same message data to WinRFB:    PostMessage(      hVeneto,      UpdateRectMessage,      wParam,      lParam     &nbsp

;    Result := False;  end;  // *** Could use WM_COPYDATA to send data to WinVNC (**********************************************  if (GetClassLong(hWnd, GCW_ATOM) = = 32768)    { _RPT4(_CRT_WARN, "DBG : popup menu message (hwnd=%d, msg=%d, l=%d, w=%d)/n", hWnd, MessageId, lParam, wParam); }  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ) **********************************************) //////////////////////////////////////////////////////////////// // *** UPDATE-TRIGGERING MESSAGES *** // Do something dependent upon message type  case Msg of    ////////////////////////////////////////////////////////////////    // Messages indicating only a border repaint.    WM_NCPAINT: Result := True;    WM_NCACTIVATE:      begin        SendDeferredBorderRect(Wnd);        Exit;      end;    ////////////////////////////////////////////////////////////////    // Messages indicating a client area repaint    WM_CHAR: Result := True;    WM_KEYUP: // Handle key-presses      begin        if (prf_use_KeyPress) then          SendDeferredWindowRect(Wnd);        Exit;      end;    WM_LBUTTONUP: // Handle LMB clicks      begin        if (prf_use_LButtonUp) then          SendDeferredWindowRect(Wnd);        Exit;      end;    WM_MBUTTONUP: // Handle MMB clicks      begin        if (prf_use_MButtonUp) then          SendDeferredWindowRect(Wnd);        Exit;      end;    WM_RBUTTONUP: // Handle RMB clicks      begin        if (prf_use_RButtonUp) then          SendDeferredWindowRect(Wnd);        Exit;      end;    WM_TIMER:      begin        if (prf_use_Timer) then          SendDeferredWindowRect(Wnd);        Exit;      end;    WM_HSCROLL: Result := True;    WM_VSCROLL:      begin        if ((LOWORD(wParam) = SB_THUMBTRACK) and not (LOWORD(wParam) =          SB_ENDSCROLL)) then          SendDeferredWindowRect(Wnd);        Exit;      end;    485: // HACK to handle popup menus      begin        // Get the old popup menu selection value        Prop := GetProp(Wnd, PChar(MAKELONG(VNC_POPUPSELN_ATOM, 0)));        if (prop <> Cardinal(wParam)) then        begin          // It did, so update the menu & the selection value          SendDeferredWindowRect(Wnd);          SetProp(Wnd,            PChar(MAKELONG(VNC_POPUPSELN_ATOM, 0)),            wParam);        end;        Exit;      end;    ////////////////////////////////////////////////////////////////    // Messages indicating a full window update    WM_SYSCOLORCHANGE: Result := True;    WM_PALETTECHANGED: Result := True;    WM_SETTEXT: Result := True;    WM_ENABLE: Result := True;    BM_SETCHECK: Result := True;    BM_SETSTATE: Result := True;    EM_SETSEL:      begin        //case WM_MENUSELECT:        SendDeferredWindowRect(Wnd);        Exit;      end;    ////////////////////////////////////////////////////////////////    // Messages indicating that an area of the window needs updating    // Uses GetUpdateRect to find out which    WM_PAINT:      begin        if (prf_use_GetUpdateRect) then        begin          region := CreateRectRgn(0, 0, 0, 0);          // Get the affected region          if (GetUpdateRgn(Wnd, region, FALSE) <> ERROR) then          begin            // Get the top-left point of the client area            TopLeft.x := 0;            TopLeft.y := 0;            if (ClientToScreen(Wnd, TopLeft)) then            begin              // Get the size of buffer required              buffsize := GetRegionData(region, 0, nil);              if (buffsize <> 0) then              begin                // Now get the region data                GetMem(buff, buffsize);                if (GetRegionData(region, buffsize, buff) <> ERROR) then                begin                  for x := 0 to buff.rdh.nCount do                  begin                    // Obtain the rectangles from the list                    uRect := PRect(Integer(buff) + SizeOf(TRgnDataHeader) +                      (x * SizeOf(TRect)));                    SendDeferredUpdateRect(                      Wnd,                      (TopLeft.x + urect.Left),                      (TopLeft.y + urect.Top),                      (TopLeft.x + urect.Right),                      (TopLeft.y + urect.Bottom)                     &nbsp

;                  end;                end;                FreeMem(buff);              end;            end;          end;          // Now free the region          if (region <> 0) then DeleteObject(region);        end        else          SendDeferredWindowRect(Wnd);        Exit;      end;    ////////////////////////////////////////////////////////////////    // Messages indicating full repaint of this and a different window    // Send the new position of the window    WM_WINDOWPOSCHANGING:      begin        if IsWindowVisible(Wnd) then          SendWindowRect(Wnd);        Exit;      end;    WM_WINDOWPOSCHANGED:      begin        if IsWindowVisible(Wnd) then          SendDeferredWindowRect(Wnd);        Exit;      end;    ////////////////////////////////////////////////////////////////    // WinRFB also wants to know about mouse movement    WM_NCMOUSEMOVE: Result := True;    WM_MOUSEMOVE:      begin        // Inform WinRFB that the mouse has moved and pass it the current        cursor handle        PostMessage(          hVeneto,          MouseMoveMessage,          GetCursor(),          0         &nbsp

;        Exit;      end;    ////////////////////////////////////////////////////////////////    // VNCHOOKS PROPERTIES HANDLING WINDOWS    WM_DESTROY:      begin        RemoveProp(Wnd, PChar(MAKEWORD(VNC_WINDOWPOS_ATOM, 0)));        RemoveProp(Wnd, PChar(MAKEWORD(VNC_POPUPSELN_ATOM, 0)));        Exit;      end;  end; end; // Hook procedure for CallWindow hook function CallWndProc(nCode: Integer; wParam: Longint; lParam: Longint):  LRESULT; stdcall; var  cwpStruct: PCwpStruct; begin  // Do we have to handle this message?  if (nCode = HC_ACTION) then    if (hVeneto <> 0) then // Process the hook if the Veneto window handle      is valid    begin      cwpStruct := PCwpStruct(lParam);      HookHandle(cwpStruct.message, cwpStruct.hwnd, cwpStruct.wParam,        cwpStruct.lParam);    end;  // Call the next handler in the chain  Result := CallNextHookEx(hCallWndHook, nCode, wParam, lParam); end; // Hook procedure for GetMessageProc hook function GetMessageProc(nCode: Integer; wParam: Longint; lParam: Longint):  LRESULT; stdcall; var  Msg: PMsg; begin  // Do we have to handle this message?  if (nCode = HC_ACTION) then    if (hVeneto <> 0) then // Process the hook only if the Veneto window is      valid    begin      Msg := PMsg(lParam);      if (wParam = PM_REMOVE) then // Only handle application messages if  they're being removed:        HookHandle(Msg.message, Msg.hwnd, Msg.wParam, Msg.lParam); // Handle      the message    end;  // Call the next handler in the chain  Result := CallNextHookEx(hGetMsgHook, nCode, wParam, lParam); end; // Hook procedure for DialogMessageProc hook function DialogMessageProc(nCode: Integer; wParam: Longint; lParam:  Longint): LRESULT; stdcall; var  Msg: PMsg; begin  // Do we have to handle this message?  if (nCode >= 0) then    if (hVeneto <> 0) then // Process the hook only if the Veneto window is      valid    begin      Msg := PMsg(lParam);      HookHandle(Msg.message, Msg.hwnd, Msg.wParam, Msg.lParam); // Handle       the message    end;  // Call the next handler in the chain  Result := CallNextHookEx(hGetMsgHook, nCode, wParam, lParam); end; // Hook procedure for LowLevel Keyboard filtering function LowLevelKeyboardFilterProc(nCode: Integer; wParam: Longint; lParam:  Longint): LRESULT; stdcall; var  Msg: PMsg; begin  // Are we expected to handle this callback?  if (nCode = HC_ACTION) then  begin    Msg := PMsg(lParam);    HookHandle(Msg.message, Msg.hwnd, Msg.wParam, Msg.lParam); // Handle the    message  end;  // Otherwise, pass on the message  Result := CallNextHookEx(hLLKeyboardHook, nCode, wParam, lParam); end; // Hook procedure for LowLevel Mouse filtering function LowLevelMouseFilterProc(nCode: Integer; wParam: Longint; lParam:  Longint): LRESULT; stdcall; var  Msg: PMsg; begin  // Are we expected to handle this callback?  if (nCode = HC_ACTION) then  begin    Msg := PMsg(lParam);    HookHandle(Msg.message, Msg.hwnd, Msg.wParam, Msg.lParam); // Handle the    message  end;  // Otherwise, pass on the message  Result := CallNextHookEx(hLLMouseHook, nCode, wParam, lParam); end; function StrLen(const Str: PChar): Cardinal; assembler; asm        MOV     EDX,EDI        MOV     EDI,EAX        MOV     ECX,0FFFFFFFFH        XOR     AL,AL        REPNE   SCASB        MOV     EAX,0FFFFFFFEH        SUB     EAX,ECX        MOV     EDI,EDX end; function NameFromPath(const path: PChar): PChar; var  x: Integer;  l: Integer; begin  l := strlen(path);  Result := nil;  // Find the file part of a filename  for x := (l - 1) downto 0 do    if (path[x] = '/') then    begin      Result := PChar(Copy(string(path), x + 1, l));      Break;    end;  // If we didn't fine a / then just return a copy of the original  if (Result = nil) then    Result := path; end; const  szSoftware = 'Software';  szCompany = 'Levin';  szProfile = 'HTHooks'; function GetRegistryKey(): HKEY; var  hAppKey: HKEY;  hSoftKey: HKEY;  hCompanyKey: HKEY;  dw: PDWORD; begin  hAppKey := 0;  hSoftKey := 0;  hCompanyKey := 0;  GetMem(dw, SizeOf(DWORD));  if (RegOpenKeyEx(HKEY_CURRENT_USER, szSoftware, 0, KEY_WRITE or KEY_READ,    hSoftKey) = ERROR_SUCCESS) then  begin    if (RegCreateKeyEx(hSoftKey, szCompany, 0, nil,      REG_OPTION_NON_VOLATILE, KEY_WRITE or KEY_READ, nil,      hCompanyKey, dw) = ERROR_SUCCESS) then      RegCreateKeyEx(hCompanyKey, szProfile, 0, nil,        REG_OPTION_NON_VOLATILE, KEY_WRITE or KEY_READ, nil,        hAppKey, dw);  end;  if (hSoftKey <> 0) then    RegCloseKey(hSoftKey);  if (hCompanyKey <> 0) then    RegCloseKey(hCompanyKey);  FreeMem(dw);  Result := hAppKey; end; function GetModuleKey(const proc_name: PChar): HKEY; var  hModule: HKEY;  hAppKey: HKEY;  FileName: PChar;  dw: PDWORD; begin  hModule := 0;  // Work out the registry key to save this under //  sModulePrefs := malloc(strlen(sPrefSegment) + strlen(proc_name) + 1);  sModulePrefs := PChar('Software/HowTo/HookUsage/' + proc_name);  //  if (sModulePrefs = nil) then Result := 0;    //  sprintf(sModulePrefs, "%s%s", sPrefSegment, proc_name);      // Check whether the library's entry exists!  hAppKey := GetRegistryKey();  //  if (hAppKey = 0) then Result := 0;    // Attempt to open the section for this application  if (RegOpenKeyEx(hAppKey,    sModulePrefs,    0, KEY_WRITE or KEY_READ,    hModule   &nbsp

<> ERROR_SUCCESS) then  begin    // Cut off the app directory and just use the name    FileName := NameFromPath(proc_name);    if (FileName = nil) then      RegCloseKey(hAppKey);    // Adjust the moduleprefs name //    sprintf(sModulePrefs, "%s%s", sPrefSegment, file_name);    sModulePrefs := PChar('Software/HowTo/HookUsage/' + FileName); {    if FileName <> nil then    begin      Dec(FileName, SizeOf(Cardinal));      FreeMem(FileName, Cardinal(Pointer(FileName)^));    end; }    GetMem(dw, SizeOf(DWORD));    // Now get the module key again    if (RegCreateKeyEx(hAppKey,      sModulePrefs,      0, nil, REG_OPTION_NON_VOLATILE,      KEY_WRITE or KEY_READ,      nil,      hModule,      dw) <> ERROR_SUCCESS) then      RegCloseKey(hAppKey); // Couldn't find/create the key - fail!    FreeMem(dw);  end;  // Close the application registry key  RegCloseKey(hAppKey);  Result := hModule; end; procedure WriteProfileInt(key: PChar; Value: Integer); begin  RegSetValueEx(    hModuleKey,    key,    0,    REG_DWORD,    @Value,    sizeof(Value)); end; function InitInstance(): BOOL; var  proc_name: array[0..MAX_PATH] of Char;  Size: DWORD; begin  // Create the global atoms  VNC_WINDOWPOS_ATOM := GlobalAddAtom(PChar(VNC_WINDOWPOS_ATOMNAME));  if (VNC_WINDOWPOS_ATOM = 0) then Result := False;  VNC_POPUPSELN_ATOM := GlobalAddAtom(PChar(VNC_POPUPSELN_ATOMNAME));  if (VNC_POPUPSELN_ATOM = 0) then Result := False;  // Attempt to get the program/module name  size := GetModuleFileName(    HInstance,    @proc_name,    MAX_PATH);  if Size = 0 then Result := False;  // Get the key for the module  hModuleKey := GetModuleKey(proc_name);  //  if (hModuleKey = 0) then Result := False;    // Read in the prefs  prf_use_GetUpdateRect := BOOL(GetProfileInt(proc_name,    'use_GetUpdateRect',    Integer(True)));  prf_use_Timer := BOOL(GetProfileInt(proc_name,    'use_Timer',    Integer(FALSE)));  prf_use_KeyPress := BOOL(GetProfileInt(proc_name,    'use_KeyPress',    Integer(TRUE)));  prf_use_LButtonUp := BOOL(GetProfileInt(proc_name,    'use_LButtonUp',    Integer(TRUE)));  prf_use_MButtonUp := BOOL(GetProfileInt(proc_name,    'use_MButtonUp',    Integer(TRUE)));  prf_use_RButtonUp := BOOL(GetProfileInt(proc_name,    'use_RButtonUp',    Integer(TRUE)));  prf_use_Deferral := BOOL(GetProfileInt(proc_name,    'use_Deferral',    Integer(TRUE)));  Result := True; end; function ExitInstance(): BOOL; begin  // Free the created atoms  if (VNC_WINDOWPOS_ATOM <> 0) then  begin    GlobalDeleteAtom(VNC_WINDOWPOS_ATOM);    VNC_WINDOWPOS_ATOM := 0;  end;  if (VNC_POPUPSELN_ATOM <> 0) then  begin    GlobalDeleteAtom(VNC_POPUPSELN_ATOM);    VNC_POPUPSELN_ATOM := 0;  end;  // Write the module settings to disk  if (sModulePrefs <> nil) then  begin    WriteProfileInt(      'use_GetUpdateRect',      Integer(prf_use_GetUpdateRect)     &nbsp

;    WriteProfileInt(      'use_Timer',      Integer(prf_use_Timer)     &nbsp

;    WriteProfileInt(      'use_KeyPress',      Integer(prf_use_KeyPress)     &nbsp

;    WriteProfileInt(      'use_LButtonUp',      Integer(prf_use_LButtonUp)     &nbsp

;    WriteProfileInt(      'use_MButtonUp',      Integer(prf_use_MButtonUp)     &nbsp

;    WriteProfileInt(      'use_RButtonUp',      Integer(prf_use_RButtonUp)     &nbsp

;    WriteProfileInt(      'use_Deferral',      Integer(prf_use_Deferral)     &nbsp

;     {    if sModulePrefs <> nil then    begin      Dec(sModulePrefs, SizeOf(Cardinal));      FreeMem(sModulePrefs, Cardinal(Pointer(sModulePrefs)^));    end;    }    sModulePrefs := nil;  end;  // Close the registry key for this module  if (hModuleKey <> 0) then    RegCloseKey(hModuleKey);  Result := True; end; initialization  DisableThreadLibraryCalls(HInstance);  VNC_DEFERRED_UPDATE :=    RegisterWindowMessage('HTHooks.Deferred.UpdateMessage');  VNC_WINDOWPOS_ATOMNAME :=    GlobalAddAtom(PChar('HTHooks.CopyRect.WindowPos'));  VNC_POPUPSELN_ATOMNAME :=    GlobalAddAtom(PChar('HTHooks.PopUpMenu.Selected')); finalization //  Just saw this now, upsssss... //  GlobalDeleteAtom(VNC_DEFERRED_UPDATE); end.

xzhifei · 2006-04-20

//*************************** //测试部分代码 unit Unitest; interface uses  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, ULibImport,  Dialogs, StdCtrls, AppEvnts; type  TForm1 = class(TForm)    Button1: TButton;    Label1: TLabel;    Label2: TLabel;    Button2: TButton;    ApplicationEvents1: TApplicationEvents;    procedure ApplicationEvents1Message(var Msg: tagMSG;      var Handled: Boolean);    procedure Button1Click(Sender: TObject);    procedure Button2Click(Sender: TObject);  private    { Private declarations }  public    { Public declarations }  end; var  Form1: TForm1; implementation {$R *.dfm} procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;  var Handled: Boolean); var { Mouse }  p: TPoint; { Screen }  l, t, r, b: integer;  rt: TRect; begin //  caption := IntToStr(Msg.message);  if (Msg.message = RFB_MOUSE_UPDATE) then  begin    GetCursorPos(p);    Label1.Caption :=      'x:' + IntToStr(P.x) + #13#10 +      'y:' + IntToStr(P.Y);  end  else    if (Msg.message = RFB_SCREEN_UPDATE) then    begin      l := Short(LOWORD(Msg.wParam));      t := Short(HIWORD(Msg.wParam));      r := Short(LOWORD(Msg.lParam));      b := Short(HIWORD(Msg.lParam));      Label2.Caption :=        'l:' + IntToStr(l) + #13#10 +        't:' + IntToStr(t) + #13#10 +        'r:' + IntToStr(r) + #13#10 +        'b:' + IntToStr(b);    end; end; procedure TForm1.Button1Click(Sender: TObject); begin  if not dll_loaded then  begin    WNDHandle := Handle;    LoadDll;    if not SetHooks then      Application.MessageBox('装载DLL时失败！', '错误');  end; end; procedure TForm1.Button2Click(Sender: TObject); begin  if dll_loaded then  begin    UnSetHooks;    UnLoadDll; //    sen.Terminate; //    DoStop;  end; end; end. //***************************** unit ULibImport; interface uses Windows, Messages, Classes, SysUtils, Forms; type { functions in vnchooks.dll } //  T_SetHook = function(wh: HWND; UpdateMsg, CopyMsg, MouseMsg: UINT): BOOL;  cdecl; //  T_UnSetHook = function(wh: HWND): BOOL; cdecl;  T_SetHook = function(thread_id:WORD; UpdateMsg, CopyMsg, MouseMsg: UINT): BOOL;  cdecl;  T_UnSetHook = function(thread_id:WORD): BOOL; cdecl;  T_SetMouseFilterHook = function(activate: BOOL): BOOL; cdecl;  T_SetKeyboardFilterHook = function(activate: BOOL): BOOL; cdecl; function LoadDll: boolean; function UnLoadDll: boolean; function GetEntryPoints: boolean; function SetHooks: boolean; function UnSetHooks: boolean; function MyPath: string; const //  dllname = 'VNCHooks.dll';  dllname = 'hthooks.dll'; var  VNCHOOKS_HANDLE: THandle;  ProcAddr: FarProc;  SetHook: T_SetHook;  UnSetHook: T_UnSetHook;  SetMouseFilterHook: T_SetMouseFilterHook;  SetKeyboardFilterHook: T_SetKeyboardFilterHook;  dll_loaded: boolean;  RFB_SCREEN_UPDATE,    RFB_COPYRECT_UPDATE,    RFB_MOUSE_UPDATE: UINT;  WNDHandle:HWND; implementation function MyPath: string; begin  Result := IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName)); end; function SetHooks: boolean; begin  result := false;  if dll_loaded then begin    RFB_SCREEN_UPDATE := RegisterWindowMessage('WinVNC.Update.DrawRect');    RFB_COPYRECT_UPDATE := RegisterWindowMessage('WinVNC.Update.CopyRect');    RFB_MOUSE_UPDATE := RegisterWindowMessage('WinVNC.Update.Mouse'); //    result := SetHook(Application.Handle, RFB_SCREEN_UPDATE, //      RFB_COPYRECT_UPDATE, RFB_MOUSE_UPDATE);    result := SetHook(WNDHandle, RFB_SCREEN_UPDATE,      RFB_COPYRECT_UPDATE, RFB_MOUSE_UPDATE);  end; end; function UnSetHooks: boolean; begin  result := true;  if dll_loaded then begin //    if UnSetHook(Application.Handle) then begin    if UnSetHook(GetCurrentThreadId) then begin      RFB_SCREEN_UPDATE := 0;      RFB_COPYRECT_UPDATE := 0;      RFB_MOUSE_UPDATE := 0;    end;  end; end; function LoadDll: boolean; begin  result := false;  VNCHOOKS_HANDLE := LoadLibrary(PChar(MyPath+dllname));  if VNCHOOKS_HANDLE <> 0 then begin    dll_loaded := GetEntryPoints;    if not dll_loaded then      FreeLibrary(VNCHOOKS_HANDLE)    else      result := true;  end; end; function UnLoadDll: boolean; begin  result := true;  if dll_loaded then begin    SetHook := nil;    UnSetHook := nil;    SetMouseFilterHook := nil;    SetKeyboardFilterHook := nil;    dll_loaded := false;    if not FreeLibrary(VNCHOOKS_HANDLE) then      result := false;    VNCHOOKS_HANDLE := 0;  end; end; function GetEntryPoints: boolean; begin  result := true; { Register SetHook }  ProcAddr := GetProcAddress(VNCHOOKS_HANDLE, 'SetHook');  if ProcAddr <> nil then SetHook := ProcAddr  else result := false; { Register UnSetHook }  ProcAddr := GetProcAddress(VNCHOOKS_HANDLE, 'UnSetHook');  if ProcAddr <> nil then UnSetHook := ProcAddr  else result := false; { Register SetMouseFilterHook }  ProcAddr := GetProcAddress(VNCHOOKS_HANDLE, 'SetMouseFilterHook');  if ProcAddr <> nil then SetMouseFilterHook := ProcAddr  else result := false; { Register SetKeyboardFilterHook }  ProcAddr := GetProcAddress(VNCHOOKS_HANDLE, 'SetKeyboardFilterHook');  if ProcAddr <> nil then SetKeyboardFilterHook := ProcAddr  else result := false; end; initialization  dll_loaded := false; end.

constantine · 2006-04-20

我也看过一个，不知道是不是我那个，回头找找，不在公司

xzhifei · 2006-04-20

期待中。。。

xmcccc · 2006-04-20

哪儿有VNC的DELPHI的源码,如果只是用HOOK的话,也不能完全得到变化的区域,另外,个人觉得可以直接调用VC写的那个DLL

zbird · 2006-04-20

去看了一下，发现VNC的源码N多，连.NET、J2ME的都有 http://sourceforge.net/projects/delphivnc

meigreat · 2006-04-20

在DLL和测试端都的工程文件中加上一个单元sharemem试一下

xmcccc · 2006-04-20

这不是指针的问题

xzhifei · 2006-04-20

http://sourceforge.net/ 上的DELPHI源码只是一个客户端连接！！！

meigreat · 2006-04-20

把DLL中的 cdecl  修试改成stdcall能成功调用

meigreat · 2006-04-20

但是好那两个按钮的重绘消息有问题

Aiirii · 2006-04-20

加入学习中

meigreat · 2006-04-20

测试端的ONMESSAGE里面加    Dispatch( Msg)就可以了

meigreat · 2006-04-20

大家有空帮小弟看一下我的问题 http://www.delphibbs.com/delphibbs/dispq.asp?lid=3395061 多谢

xzhifei · 2006-04-20

感谢meigreat,我试试看

Aiirii · 2006-04-20

meigreat 没有说到关键的地方！ 晚上看了下代码，错误很多，感觉很难修改，因为你一堆东西很杂乱的堆在一起， 简单的修改你的错误： >>只能截获到当前EXE主窗口的消息 最简单，可以如下修改： //  PostMessage( //    hVeneto, //    UpdateRectMessage, //    vwParam, //    vlParam //   &nbsp

;  PostMessage(    HWND_BROADCAST,    UpdateRectMessage,    vwParam,    vlParam   &nbsp

; hVeneto 改为 HWND_BROADCAST 还有几种其它的改法, 代码不是直接修改你的，有点小区别，但原理是一样的，如： library hthooks; function StartHook(hForm: THandle): Integer; stdcall; begin ....    hMemFile := CreateFileMapping(MAXDWORD, nil, PAGE_READWRITE, 0,      SizeOf(THandle), memFileName);    pFormHnd := MapViewOfFile(hMemFile, FILE_MAP_WRITE, 0, 0, 0);    if pFormHnd = nil then    begin      Result := 4;      UnhookWindowsHookEx(hMouseHook);      Exit;    end else      pFormHnd^ := hForm; begin  DLLProc := @EntryProc;  hMemFile := OpenFileMapping(FILE_MAP_WRITE, False, memFileName);  if hMemFile <> 0 then    pFormHnd := MapViewOfFile(hMemFile, FILE_MAP_WRITE, 0, 0, 0); end. 全局HOOK, 在不同的程序，对应的 hVeneto 的值是不同的，这点如果你明白了，你的问题所在就很清楚了。 另外，一些声明错了，如stdcall, cdecl   另外，label1, label2 的取值有些问题， dll中的消息处理，也是一塌糊涂的感觉！ 另外，你的代码可能HOOK到 paint 之类的，然后，你又给刷新 label1, label2, 这样可能有问题，这部分，我没细看

xzhifei · 2006-04-22

多人接受答案了。

【300分】VNCHook For Delphi源码(300分)

xzhifei

Unregistered / Unconfirmed

xzhifei

Unregistered / Unconfirmed

constantine

Unregistered / Unconfirmed

xzhifei

Unregistered / Unconfirmed

xmcccc

Unregistered / Unconfirmed

zbird

Unregistered / Unconfirmed

meigreat

Unregistered / Unconfirmed

xmcccc

Unregistered / Unconfirmed

xzhifei

Unregistered / Unconfirmed

meigreat

Unregistered / Unconfirmed

meigreat

Unregistered / Unconfirmed

Aiirii

Unregistered / Unconfirmed

meigreat

Unregistered / Unconfirmed

meigreat

Unregistered / Unconfirmed

xzhifei

Unregistered / Unconfirmed

Aiirii

Unregistered / Unconfirmed

xzhifei

Unregistered / Unconfirmed

Similar threads