untmain.pas

屏幕取词,一个简单的程序,希望对刚入门的朋友一点点帮助

//单元untMain.pas的代码，窗体设置见下
(*******************************************************************************
* Copy Right (C) Gan Huaxin 2001, 2002, [e-mail]
* A Free Screen Words Capture Library
*   Dedicated to my GirlFriend Sunny, Happy for ever
*
* Version         Date           Modification
*   0.1       2001-11-07~09       New, oly a test
*                                 Can Get Word, Sometimes occure error
*   0.2       2002-05-14~16       Some Bugs Fixed,And
*******************************************************************************)
unit untMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, untTypes;

type
  TfrmGanDict = class(TForm)
    btnLoad: TButton;
    btnUnLoad: TButton;
    lblHwnd: TLabel;
    btnAbout: TButton;
    lblMousePos: TLabel;
    memoThunk: TMemo;
    lblFontWidth: TLabel;
    lblRect: TLabel;
    procedure btnLoadClick(Sender: TObject);
    procedure btnUnLoadClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btnAboutClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure WndProc(var Mess: TMessage); override;
  end;

var
  frmGanDict: TfrmGanDict;

implementation

uses untAbout;

{$R *.DFM}

var
  HMapFile:THandle;
  CommonData:^TCommonData;


const
  STR_MSGNOTIFY:pchar='WM_GANNOTIFY';
var
  idMsg : UINT;

function EnableMouseHook(hld:hwnd; ProcessID : DWORD; hInst : THandle): BOOL; external 'GFDict.dll';
function DisableMouseHook: BOOL; external 'GFDict.dll';
function SetCaptureFlag(bFlag:BOOL): BOOL; external 'GFDict.dll';

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 TfrmGanDict.btnLoadClick(Sender: TObject);
begin
  if not EnableMouseHook(handle, GetCurrentProcessID, Application.Handle) then
    ShowMessage('ERROR')
  else
    SetCaptureFlag(TRUE);
end;

procedure TfrmGanDict.btnUnLoadClick(Sender: TObject);
begin
  DisableMouseHook;
end;

procedure TfrmGanDict.FormDestroy(Sender: TObject);
begin
  DisableMouseHook;
  if CommonData<>nil then begin
    UnMapViewOfFile(CommonData);
    CommonData := nil;
    CloseHandle(HMapFile);
    HMapFile := 0;
  end;
end;

procedure TfrmGanDict.FormCreate(Sender: TObject);
begin
  idMsg := RegisterWindowMessage(STR_MSGNOTIFY);
  CommonData := nil;
  MapCommonData;
  SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0,
               SWP_NOSIZE or SWP_NOMOVE);
end;

const
  StrProcNames : array[0..5] of String =
    ('TextOutA',
     'TextOutW',
     'ExtTextOutA',
     'ExtTextOutW',
     'DrawTextA',
     'DrawTextW');
procedure TfrmGanDict.WndProc(var Mess: TMessage);
begin
  case Mess.LParam of
    0:
      begin
        if (mess.msg = idMsg) then begin
          if (Mess.wParam >=0) and (Mess.WParam <= 5) then begin
            lblHwnd.Caption := StrProcNames[mess.wParam]; //Format('Handle : 0x%X', [mess.wParam]);
            if CommonData <> nil then with CommonData^ do begin
              memoThunk.Text := CommonData.BufferA;
              lblRect.Caption := Format('Client X:%d, Y:%d, Rect[%d,%d,%d,%d]',
                [MousePClient.x, MousePClient.y,
                 Rect.Left, Rect.Top, Rect.Right, Rect.Bottom]);
              // lblThunkText.Caption := CommonData.BufferA;
            end
          end else
            lblHwnd.Caption := 'UnKnow Message';
        end;
      end;
    1:
      begin
        if CommonData<>nil then with CommonData^ do
          lblMousePos.Caption := Format('Mouse Pos X : %d, Y : %d',
                                        [MousePos.X,
                                         MousePos.Y]);
      end;
    2:
      begin
        memoThunk.Text := '---';
      end;
    3:
      begin
        lblFontWidth.Caption := Format('Font Width : %d', [mess.wParam]);
      end;
  end;
  inherited;
end;

procedure TfrmGanDict.btnAboutClick(Sender: TObject);
begin
  AboutBox.ShowModal;
end;

end.