gfdict.dpr

如何用delphi在windows 2000 windows xp下实现获取屏幕的汉字

library GFDict;

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

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

// {$DEFINE DEBUG}


uses
  SysUtils,Classes,windows,messages,
  untTypes in 'untTypes.pas';

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;
                                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]))));
                                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]))));
                        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}