gfdict.~dpr

屏幕取词的delphi代码

procedure InitServerWnd;
var
  WndClass : TWndClass; //Ex;
begin
 with WndClass do begin
    style              := WS_EX_TOPMOST;
    lpfnWndProc        := @GanServerProc;  (*消息处理函数*)
    hInstance          := GetModuleHandle('GFDict.dll');
    hbrBackground      := color_btnface + 1;
    lpszClassname      := 'GanServerDict';
    hicon              := 0;
    hCursor            := 0;
    cbClsExtra         := 0;
    cbWndExtra         := 0;
  end;

  try
    if not BOOL(RegisterClass{Ex}(WndClass)) then begin
      MessageBox(0,
                 PChar(Format('Can not register class server %d',[GetLastError])),
                 'Register Error',
                 MB_OK);
    end;
  except
    MessageBox(0, 'EXCEPTION', 'Register Server Class', MB_OK);
  end;

  hWndServer := CreateWindowEx(WS_EX_TOPMOST or WS_EX_TOOLWINDOW,
                              'GanServerDict',
                              'Gan Server',
                              WS_POPUP or WS_VISIBLE,
                              -1,-1,1,1,
                              0,
                              0,
                              0, //hInst, // GetModuleHandle('dll.dll'), // 98 for this, 2000 for 0
                              nil);
  if (hWndServer=0) then begin
    MessageBeep(0);
  end;

end;
(******************************************************************************)

procedure InitThunkCode;
var
  tfType : TThunkFunc;
  hMod : HMODULE;
  pSysFunc, pThunkFunc : Pointer;
begin
  for tfType := LOW(TThunkFunc) to HIGH(TThunkFunc) do begin
    // clear to zero
    FillChar(ThunkCodeArr[tfType], sizeof(TThunkCode), 0);

    // fill it by right value
    hMod := 0;
    hMod := GetModuleHandle(PChar(ThunkFuncNameArr[tfType].strMod));
    if hMod = 0 then continue;

    pSysFunc := nil;
    pSysFunc := GetProcAddress(hMod,
      PChar(ThunkFuncNameArr[tfType].strSysProc));
    if pSysFunc = nil then continue;

    pThunkFunc := nil;
    pThunkFunc := GetProcAddress(hInstance,
      PChar(ThunkFuncNameArr[tfType].strThunkProc));
    if pThunkFunc = nil then continue;

    // now fill it!
    ThunkCodeArr[tfType].addr_sys := pSysFunc;
    ThunkCodeArr[tfType].addr_thunk := pThunkFunc;

    ThunkCodeArr[tfType].codeThunk.siJmp := ShortInt($E9);  // jmp ____
    ThunkCodeArr[tfType].codeThunk.dwAddr :=
      DWORD(pThunkFunc) - DWORD(pSysFunc) - 5;

    ThunkCodeArr[tfType].codeBak.siJmp := PByte(pSysFunc)^;
    ThunkCodeArr[tfType].codeBak.dwAddr := PDWORD(DWORD(pSysFunc)+1)^;
  end;
end;

{==================  Install Mouse Hook Support ==============================}
function MousePosHookHandler(iCode: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
  pMouse : PMOUSEHOOKSTRUCT;
  mPoint : TPoint;
  rect : TRect;
  bMousePosChg : boolean;
begin
  if iCode < 0 then
  begin
    Result := CallNextHookEx(hNextHookProc, iCode, wParam, lParam);
  end
  else
  if (CommonData<>nil) and
    (CommonData^.bCapture) and
    (TryEnterCriticalSection(m_CriticalSection))
  then begin

{$IFDEF WIN_9X}
    if bFirst then begin
      bFirst := false;
      // InstallGanFilter;
      InitCoverWindow;
    end;
{$ENDIF}

    pMouse := PMOUSEHOOKSTRUCT(lParam);

    if (CommonData<>nil) then begin
      CommonData.MousePos := pMouse.pt;
      CommonData.hWndCapture := pMouse.hWnd;
      PostMessage(CommonData.CallBackHandle, idMsg, 0, 1);
    end;
    if (GetCurrentProcessID <> CommonData^.CallBackProcID) then begin
      CommonData^.hWndMouse := hWndServer;

      mPoint := pMouse^.pt;
      ScreenToClient(pMouse^.hwnd, mPoint);
      if Assigned(CommonData) then
        CommonData.MousePClient := mPoint;
    end
    else begin
      CommonData^.hWndMouse := 0;

    end;
(*
    if (pMouse.pt.x = LastMousePos.x) and (pMouse.pt.y = LastMousePos.y) then
      bMousePosChg := false
    else begin
      bMousePosChg := true;
      LastMousePos := pMouse.pt;
    end;
    if (wParam = WM_MOUSEMOVE)
      and true
{$IFDEF WIN_9X}
      and (hWndCover <> 0)
{$ENDIF}
      and bMousePosChg
      and (not b_InCS)
      and (GetTickCount - LastTime > G_DELAY_TIME) then
    begin
      LastTime := GetTickCount;

      // whether in my window
      if (CommonData<>nil) and
         (GetCurrentProcessID = CommonData^.CallBackProcID) then begin
        result := 0;
        LeaveCriticalSection(m_CriticalSection);
        result := CallNextHookEx(hNextHookProc, iCode, wParam, lParam);
        exit;
      end;
      mPoint := pMouse^.pt;
      ScreenToClient(pMouse^.hwnd, mPoint);
      if Assigned(CommonData) then
        CommonData.MousePClient := mPoint;

      rect.TopLeft := mPoint;
      rect.Right := mPoint.x + 2;
      rect.Bottom := mPoint.y + 1;
      // Work for NT 2000 XP
{$IFDEF WIN_NT}
      InstallGanFilter;

      if Assigned(CommonData) then
        CommonData.BufferA := '';

      InvalidateRect(pMouse^.hWnd, @rect, TRUE);
      if (mPoint.X<0) or (mPoint.Y<0) then
        SendMessage(pMouse.hwnd, WM_NCPAINT, 1, 0)
      else
        SendMessage(pMouse.hwnd, WM_PAINT, 0, 0);

      UninstallGanFilter;
      if Assigned(CommonData) and (CommonData.BufferA='') then begin
        SendMessage(CommonData.CallBackHandle, idMsg, 0, 2);
      end;
{$ENDIF}
      // flowing work on 98
{$IFDEF WIN_9X}
      if (hWndCover <> 0) then begin
        SetWindowPos(hWndCover, 0, pMouse.pt.X, pMouse.pt.Y, 4, 1,
          SWP_NOZORDER or SWP_NOACTIVATE);
        ShowWindow(hWndCover, SW_SHOW);

//        EnterCriticalSection(m_CriticalSection);

        InstallGanFilter;
        ShowWindow(hWndCover, SW_HIDE);

//        LeaveCriticalSection(m_CriticalSection);
      end;
{$ENDIF}
    end;
*)
    LeaveCriticalSection(m_CriticalSection);
    Result := CallNextHookEx(hNextHookProc, iCode, wParam, lParam);
  end
  else begin
    Result := CallNextHookEx(hNextHookProc, iCode, wParam, lParam);
  end;
end;

function EnableMouseHook(hld:hwnd; ProcessID : DWORD; hInst:THandle): BOOL; export;
begin
  Result := False;
  if hNextHookProc <> 0 then Exit;

  hNextHookProc := SetWindowsHookEx(WH_MOUSE, MousePosHookHandler,Hinstance, 0);
//    GetWindowThreadProcessID(hWnd, nil));

  InitCoverWindow(hInst);
  if CommonData <> nil then begin
    CommonData^.CallBackHandle := hld;
    CommonData^.CallBackProcID := ProcessID;
  end;
  Result :=hNextHookProc <> 0 ;
end;

function DisableMouseHook: BOOL; export;
begin
try
  if hNextHookProc <> 0 then
  begin
    KillTimer(CommonData^.hWndFloat, 1);
    KillTimer(CommonData^.hWndFloat, 2);
    SendMessage(CommonData^.hWndFloat, WM_CLOSE, 0, 0);
    CommonData^.hWndFloat := 0;

    UnInstallGanFilter;
    UnhookWindowshookEx(hNextHookProc);
    hNextHookProc := 0;
  end;
  Result := hNextHookProc = 0;
except
  MessageBeep(0);
end;
end;

function SetCaptureFlag(bSet:BOOL):BOOL; export;
begin
  if CommonData<>nil then begin
    result := TRUE;
    CommonData^.bCapture := bSet;
  end
  else begin
    result := FALSE;
  end;
end;

procedure DllMain(dwReason : DWORD);
begin
  case dwReason of
    DLL_PROCESS_ATTACH :
      begin
        // InstallGanFilter;
        // InitCoverWindow;
      end;
    DLL_PROCESS_DETACH :
      begin
        if (hWndServer <> 0) then begin
          SendMessage(hWndServer, WM_CLOSE, 0, 0);
          hWndServer := 0;
          try
            UnRegisterClass('GanServerDict', hInstance);
          except
            MessageBeep(0);
          end;
        end;
        UnInstallGanFilter;
        if CommonData<>nil then begin
          try
            UnMapViewOfFile(CommonData);
            CommonData := nil;
            CloseHandle(HMapFile);
            HMapFile := 0;
          except
            MessageBox(0,
                       'Error when free MapViewFile',
                       'FreeDict Error',
                       MB_OK);
          end;
        end;
(*
        if (hWndCover <> 0) then begin
          try
            DestroyWindow(hWndCover);
            hWndCover := 0;
            if (UnRegisterClass('GanFreeDict', hInstance)) then
              {MessageBox(0,
                         'Success to Unregister _GanFreeDict_ Class',
                         'Success',
                         MB_OK);}
          except
            MessageBox(0,
                       'Error when Destroy window and UnRegisterClass',
                       'FreeDict Error',
                       MB_OK);
          end;
        end;
*)

        if hProc<>0 then begin
          try
            CloseHandle(hProc);
            hProc := 0;
          except
            MessageBox(0,
                       'Error when CloseHandle',
                       'FreeDict Error',
                       MB_OK);
          end;
        end;

        DeleteCriticalSection(g_CriticalSection);
        DeleteCriticalSection(m_CriticalSection);
      end;
    DLL_THREAD_ATTACH :
      begin
      end;
    DLL_THREAD_DETACH :
      begin
      end;
  end;
end;

exports
  EnableMouseHook,
  DisableMouseHook,
  GanTextOutA,
  GanTextOutW,
  GanExtTextOutA,
  GanExtTextOutW,
  GanDrawTextA,
  GanDrawTextW,
  SetCaptureFlag;

begin
  InitializeCriticalSection(g_CriticalSection);
  InitializeCriticalSection(m_CriticalSection);
  b_InCS := false;
  hNextHookProc := 0;
  hProc := 0;
  bFirst := true;
  bDllInstalled := false;
  hWndCover := 0;
  hWndServer := 0;
  CommonData := nil;
  HMapFile := 0;
  LastTime := 0;
  FillChar(LastMousePos, sizeof(TPoint), 0);
  idMsg := RegisterWindowMessage(STR_MSGNOTIFY);

  MapCommonData;

  hProc := OpenProcess(PROCESS_ALL_ACCESS,
                       FALSE,
                       GetCurrentProcessID());
  InitThunkCode;
  InitServerWnd;
  // InitCoverWindow;

  // DisableThreadLibraryCalls(hInstance);

  DLLProc := @DLLMain;
  DLLMain(DLL_PROCESS_ATTACH);
end.