gfdict.~dpr

屏幕取词的delphi代码

library GFDict;

// {$DEFINE MSG_NOT_SEND}
{$DEFINE WIN_NT}

{$IFNDEF WIN_NT}
  {$DEFINE WIN_9X}
{$ENDIF}

// {$DEFINE DEBUG}


uses
  SysUtils,
  Classes,
  windows,
  messages,
  untTypes;

const
  STR_MSGNOTIFY:PChar='WM_GANNOTIFY';

var
  HMapFile:THandle;
  CommonData:^TCommonData;
  idMsg : UINT;
  hwndServer : HWnd;

var
  hWndCover : THandle;
  LastMousePos : TPoint;
  LastTime : DWORD;
  g_CriticalSection : TRTLCriticalSection;
  m_CriticalSection : TRTLCriticalSection;
  b_InCS : boolean;

var
  hNextHookProc: HHook;
  hProc : THandle;
  bFirst : boolean;
  bDllInstalled : boolean;
  ThunkCodeArr : array[TThunkFunc] of TThunkCode;

{$IFDEF DEBUG}
  procedure GanWarning;
  begin
    MessageBeep(0);
  end;
{$ELSE}
  procedure GanWarning;
  begin
  end;
{$ENDIF}

{$DEFINE _NOTIFY_}

{$IFDEF _NOTIFY_}
  procedure GanNotify;
  begin
    MessageBeep(0);
  end;
{$ELSE}
  procedure GanNotify;
  begin
  end;
{$ENDIF}


// about Memory Map file support
procedure MapCommonData;
var FirstCall: Boolean;
begin
  HMapFile:=OpenFileMapping(FILE_MAP_WRITE, False, 'GanGan_ThunkDict');
  FirstCall:=(HMapFile = 0);
  if FirstCall then
    HMapFile:=CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,
                                0,SizeOf(TCommonData),
                                'GanGan_ThunkDict');
  CommonData:= MapViewOfFile(HMapFile, FILE_MAP_WRITE, 0, 0, 0);
  if FirstCall then FillChar(CommonData^, SizeOf(TCommonData), 0);
end;

// -----------------------------------------------------------------------------
procedure UnInstallThunkFunc(tfType : TThunkFunc);
var
  nCount : DWORD;
begin
  if not ThunkCodeArr[tfType].bInstalled then exit;
  if (hProc=0) or (ThunkCodeArr[tfType].addr_sys=nil) then exit;
  WriteProcessMemory(hProc,
                     ThunkCodeArr[tfType].addr_sys,
                     @(ThunkCodeArr[tfType].codeBak),
                     5,
                     nCount);
  ThunkCodeArr[tfType].bInstalled := false;
end;

procedure InstallThunkFunc(tfType : TThunkFunc);
var
  nCount : DWORD;
begin
  if ThunkCodeArr[tfType].bInstalled then exit;
  if (hProc=0) or (ThunkCodeArr[tfType].addr_sys=nil) then exit;
  WriteProcessMemory(hProc,
                     ThunkCodeArr[tfType].addr_sys,
                     @(ThunkCodeArr[tfType].codeThunk),
                     5,
                     nCount);
  ThunkCodeArr[tfType].bInstalled := True;
end;

procedure UnInstallGanFilter; forward;

{===================  TextOut   ==============================================}
function GanTextOutA(DC: HDC; X, Y: Integer; Str: PAnsiChar; Count: Integer): BOOL; stdcall;
var
  tm : TTextMetric;
  rect : TRect;
  size : TSize;
  i, j : integer;
  posDcOrg : TPoint;
  posDcOff : TPoint;

begin
//  EnterCriticalSection(g_CriticalSection);

  result := FALSE;
  UnInstallThunkFunc(tfTextOutA);
{$IFNDEF MSG_NOT_SEND}
try
  if (CommonData<>nil) then begin
    GetDcOrgEx(dc, posDcOrg); // Get The DC offset
    posDcOff := Point(x,y);
    LPtoDP(dc, posDcOff, 1);

    Rect.Left := posDcOrg.x + posDcOff.x;
    Rect.Top := posDcOrg.y + posDcOff.y;

    if BOOL(GetTextAlign(dc) and  TA_UPDATECP) then begin
      GetCurrentPositionEx(dc, @posDcOff);
      Inc(Rect.Left, posDcOff.x);
      Inc(Rect.Top, posDcOff.y);
    end;

    GetTextExtentPointA(DC, Str, Count, size);

    Rect.Right :=  Rect.Left + size.cx;
    Rect.Bottom := Rect.Top + size.cy;

    if PtInRect(rect, CommonData.MousePos) then begin // in total area!
      if StrPos(Str, ' ')<>nil then begin
        i := 0;

        while (Str[i] = Char(' ')) and (i<Count) do Inc(i);

        j := i;

        while (i<Count) do begin
          if Str[i]=Char(' ') then begin
            Str[i] := Char(0);
            GetTextExtentPointA(DC, Str, i-1, size);
            rect.Right := rect.Left + size.cx;

            if PtInRect(rect, CommonData.MousePos) then begin
              // SendMessage(CommonData.CallBackHandle, idMsg, i, 3);
              StrCopy(CommonData.BufferA, PChar(@(Str[j])));
              CommonData^.Rect := Rect;
              CommonData^.charcount:=Count;
              SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutA), 0);
              Str[i] := Char(' ');
              break;
            end;

            Str[i] := Char(' ');
            while (Str[i] = Char(' ')) and (i < Count) do Inc(i);
            if i=Count then break;
            j := i;
            Dec(i);
            // break;
          end;
          inc(i);
        end;
        if (i=Count) then begin
          StrCopy(CommonData.BufferA, PChar(@(Str[j])));
          CommonData^.Rect := Rect;
          SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutA), 0);
        end;
      end else
      begin
        StrCopy(CommonData.BufferA, Str);
        CommonData^.Rect := Rect;
        SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutA), 0);
      end;
    end;
  end;
  (*
  StrCopy(CommonData.BufferA, Str);
  CommonData^.Rect := Rect;
  SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutA), 0);
  *)
except
  GanWarning;
  StrCopy(CommonData.BufferA, 'Error in TextOutA');
  SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutA), 0);
end;
{$ENDIF}
  TextOutA(DC, X, Y, Str, Count);
  InstallThunkFunc(tfTextOutA);
//  UnInstallGanFilter;

//  LeaveCriticalSection(g_CriticalSection);
end;

function GanTextOutW(DC: HDC; X, Y: Integer; Str: PWideChar; Count: Integer): BOOL; stdcall;
var
  tm : TTextMetric;
  rect : TRect;
  size : TSize;
  i, j : integer;
  wChar : WideChar;
  posDcOrg, posDcOff : TPoint;
begin
//  EnterCriticalSection(g_CriticalSection);

  result := FALSE;
  UnInstallThunkFunc(tfTextOutW);
{$IFNDEF MSG_NOT_SEND}
try
  if (CommonData<>nil) then begin
    GetDcOrgEx(dc, posDcOrg);
    posDcOff := Point(x,y);
    LPtoDP(dc, posDcOff, 1);

    Rect.Left := posDcOrg.x + posDcOff.x;
    Rect.Top := posDcOrg.y + posDcOff.y;

    if BOOL(GetTextAlign(dc) and  TA_UPDATECP) then begin
      GetCurrentPositionEx(dc, @posDcOff);
      Inc(Rect.Left, posDcOff.x);
      Inc(Rect.Top, posDcOff.y);
    end;

    GetTextExtentPointW(DC, Str, Count, size);

    rect.Right := rect.Left + size.cx;
    rect.Bottom := rect.Top + size.cy;

    if PtInRect(rect, CommonData.MousePos) then begin
      if StrPos(PChar(WideCharToString(Str)), ' ')<>nil then begin
        i := 0;

        while (Str[i] = WideChar(' ')) and (i<Count) do Inc(i);

        j := i;

        while (i<Count) do begin
          if Str[i]=WideChar(' ') then begin
            Str[i] := WideChar(0);
            GetTextExtentPoint32W(DC, Str, i-1, size);
            rect.Right := rect.Left + size.cx;

            if PtInRect(rect, CommonData.MousePos) then begin
              // SendMessage(CommonData.CallBackHandle, idMsg, i, 3);
              //StrCopy(CommonData.BufferA,PChar(WideCharToString(@(Str[j]))));
              lstrcpyW(commondata.bufferw,Str);

              CommonData^.Rect := Rect;
              SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutW), 0);
              Str[i] := WideChar(' ');
              break;
            end;

            Str[i] := WideChar(' ');
            while (Str[i] = WideChar(' ')) and (i < Count) do Inc(i);
            if i=Count then break;
            j := i;
            Dec(i);
            // break;
          end;
          inc(i);
        end;
        if (i=Count) then begin
          //StrCopy(CommonData.BufferA, PChar(WideCharToString(@(Str[j]))));
          lstrcpyW(commondata.bufferw,PWideChar(@Str[j]));
          CommonData^.Rect := Rect;
          SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutW), 0);
        end;
      end else
      begin
        StrCopy(CommonData.BufferA,PChar(WideCharToString(Str)));
        CommonData^.Rect := Rect;
        SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutW), 0);
      end;
    end;
  end;
except
  GanWarning;
  StrCopy(CommonData.BufferA, 'Error in TextOutW');
  SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfTextOutW), 0);
end;
{$ENDIF}
  result := TextOutW(DC, X, Y, Str, Count);
  InstallThunkFunc(tfTextOutW);
//  UnInstallGanFilter;

//  LeaveCriticalSection(g_CriticalSection);
end;

{===================  ExtTextOut  ============================================}
(*
  这个函数在UltraEdit里会出错，加上异常处理就没有关系。
  Bug Fixed 2002-05-13
*)
function GanExtTextOutA(DC: HDC; X, Y: Integer; Options: Longint;
  Rect: PRect; Str: PAnsiChar; Count: Longint; Dx: PInteger): BOOL; stdcall;
var
  posDcOrg : TPoint;
  posDc : TPoint;
  RectText : TRect;
  size : TSize;
begin
//  EnterCriticalSection(g_CriticalSection);

  result := FALSE;
  UnInstallThunkFunc(tfExtTextOutA);
{$IFNDEF MSG_NOT_SEND}

  GetDcOrgEx(dc, posDcOrg);
  posDc := Point(x,y);
  LPtoDP(dc, posDc, 1);

  RectText.Left := posDc.x + posDcOrg.x;
  RectText.Top := posDc.y + posDcOrg.y;

  if BOOL(GetTextAlign(dc) and TA_UPDATECP) then begin
    GetCurrentPositionEx(dc, @posDc);
    Inc(RectText.Left, posDc.x);
    Inc(RectText.Top, posDc.y);
  end;

  GetTextExtentPointA(dc, Str, Count, size); {Get The Length and Height of str}
  with RectText do begin
    Right := Left + size.cx;
    Bottom := Top + Size.cy;
  end;

  if (CommonData<>nil) {and false} and PtInRect(RectText, CommonData.MousePos) then begin
    try
      StrCopy(CommonData.BufferA, Str);
      CommonData^.Rect := RectText;
      
    except
      GanWarning;
      StrCopy(CommonData.BufferA, 'ERROR in ExtTextOutA');

    end;
    SendMessage(CommonData^.CallBackHandle, idMsg, Integer(tfExtTextOutA), 0);
  end;
{$ENDIF}
  result := ExtTextOutA(DC, X, Y, Options, Rect, Str, Count, Dx);
  InstallThunkFunc(tfExtTextOutA);
//  UnInstallGanFilter;

//  LeaveCriticalSection(g_CriticalSection);
end;

function GanExtTextOutW(DC: HDC; X, Y: Integer; Options: Longint;
  Rect: PRect; Str: PWideChar; Count: Longint; Dx: PInteger): BOOL; stdcall;
var
  posDcOrg : TPoint;