mrecord.pas

delphi写的一个录制鼠标动作的例子。对需要学习鼠标操作的有一定参考意义。

unit mRecord;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, ComCtrls, shellapi,Registry, ImgList, IELabel;
const
  ShortKeyError='快捷键没有激活，不能使用快捷键 Ctrl+R 及 Ctrl+Q';
  GetMessageError='已经在获取鼠标/键盘动作。！' ;
  PlayBackMessageError='已经在回放鼠标/键盘动作！';
  CreateFileError='不能建立文件:' ;
  TempFileName='MacroMK.tmp';
  FoundFile='指定路径中已经存在文件：' ;
  NoFoundFile='指定路径中不存在文件：' ;
  ChangeFile='请更改文件名再试一遍！' ;
  IllegleFile='非法文件：' ;
  OpenFileError='不能打开文件。可能不存在';
  EmptyFile='空文件：';
  ExtName='.mco';
  NoEnoughMemory='内存不够，请退出部分程序再试！';
  StopRecordMessage='还没有进行或已经停止了录制！';
  NoRecordMessage='还没有录制任何动作，请先进行录制！';
  RecordError='录制过程发生了错误，请重新录制一遍！';
  RecordingMessage='正在录制，请稍等...';
  PlayingBackMessage ='正在回放，请稍等...';
  ReCordingOrPlaying= '正在录制/回放.';
  ExtChar:Array [0..3] of char=('.','m','c','o');
  StopPlayMessageError='停止回放时发生了错误，请再试一遍！';
  StopRecordError='停止录制时发生了错误，请再试一遍！';
  AuthorEmail='mailto:[e-mail]';
  AuthorWebSite='http://lilongwu.friendpages.com';
  CompanyWebSite='http://www.beijia.com';
  KeyPath='SOFTWARE\Microsoft\Windows\CurrentVersion';
  User='RegisteredOwner';
  Company='RegisteredOrganization';
type
    TMsgList=class(TList)
  public
  //destructor Destroy;override;
  end;
    TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    BtnRecord: TButton;
    BtnStopRec: TButton;
    BtnPlayBack: TButton;
    GroupBox1: TGroupBox;
    Label1: TLabel;
    BtnSaveFile: TButton;
    EtFileName: TEdit;
    CBSaveFile: TCheckBox;
    GroupBox2: TGroupBox;
    CBPlayBack: TCheckBox;
    BtnBrowse: TButton;
    EtPlayFileName: TEdit;
    TabSheet3: TTabSheet;
    OpenMco: TOpenDialog;
    Label2: TLabel;
    Panel1: TPanel;
    Label3: TLabel;
    Label4: TLabel;
    Label6: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    Label5: TLabel;
    LbUserName: TLabel;
    LbCompanyName: TLabel;
    Bevel1: TBevel;
    Timer1: TTimer;
    ImageList1: TImageList;
    CBMinWindows: TCheckBox;
    Label8: TLabel;
    Label11: TLabel;
    BtnStopPlay: TButton;
    IELEmail: TIELabel;
    IELWebSite: TIELabel;
    IELabel1: TIELabel;
    procedure BtnRecordClick(Sender: TObject);
    procedure BtnStopRecClick(Sender: TObject);
    procedure BtnSaveFileClick(Sender: TObject);
    procedure CBSaveFileClick(Sender: TObject);
    procedure BtnPlayBackClick(Sender: TObject);
    procedure BtnStopPlayClick(Sender: TObject);
    procedure CBPlayBackClick(Sender: TObject);
    procedure BtnBrowseClick(Sender: TObject);
    procedure EtFileNameChange(Sender: TObject);
    procedure LbCompanyClick(Sender: TObject);
    procedure LbEmailClick(Sender: TObject);
    procedure LbWebSiteClick(Sender: TObject);
    procedure PageControl1Change(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure StopRoll;
    procedure StopPlayBack;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
   Form1: TForm1;
   MessageStr:String='';
   PM:Array of TEventMsg;
   MsgCount:integer=0;
   ArrayCount:Integer=0;
   PM1:Array of TEventMsg;



procedure SetMinWindows;
procedure MakeMessage;

implementation

{$R *.DFM}

uses HKProc;

var
  k:integer=0;

procedure TForm1.StopRoll;
begin
  Timer1.Enabled:=False;
  ImageList1.GetIcon(2,Form1.Icon);
  Application.Icon :=Form1.Icon;
end;

procedure TForm1.StopPlayBack;
begin
  if  not StopPlayBackMessage then begin
    ShowMessage(StopPlayMessageError);
    Exit;
  end;
  BtnPlayBack.Enabled:=True;
  BtnStopPlay.Enabled:=False;
  StopRoll;
end;

procedure SetMinWindows;
begin
  Application.Minimize;
end;

procedure MakeMessage;
var
  List:TStringList;
  i:integer;
  MsgStr,TmpStr:string;
  M:TEventMsg;
begin
  List:=Tstringlist.create;
  List.Text:=messageStr;
  if MsgCount<>List.Count then begin
    ShowMessage(RecordError);
    Exit;
  end;
  MessageStr:='';//销毁MessageStr全局变量
  try
    SetLength(PM,MsgCount);
  except
    on EOutOfMemory do begin
      ShowMessage(NoEnoughMemory);
      Application.Terminate;
    end
  end;
  for i:=0 to MsgCount-1 do begin
    {允许别的消息响应}
    Application.ProcessMessages;
    {翻译一条消息}
    MsgStr:=List.Strings[i];  //提取消息
    tmpStr:=Copy(MsgStr,1,5); //提取消息类型
    M.message:=StrToInt(tmpStr); //翻译消息
    tmpStr:=Copy(MsgStr,6,5);  //提取paramL值
    M.paramL:=StrToInt(tmpStr); //翻译paramL值
    tmpStr:=Copy(MsgStr,11,5); //提取paramL值
    M.paramH:=StrToInt(tmpStr);//翻译paramL值
    tmpStr:=Copy(MsgStr,16,13); //提取时间
    M.time:=StrToInt(tmpStr);   //翻译时间
    M.hwnd:=0;
    {添加一条消息到消息数组中}
    PM[i].message:=M.message;
    PM[i].paramL:=M.paramL;
    PM[i].paramH:=M.paramH;
    PM[i].time:=M.time;
    PM[i].hwnd:=M.hwnd;
  end;
  List.free;
end;

function CheckFile(FileName:string):boolean;
var
  RecFile:TSearchRec;
begin
  Result:=False;
  if FindFirst(FileName,faAnyFile,RecFile)=0 then begin
    ShowMessage(FoundFile+FileName+'.'+ChangeFile);
    FindClose(RecFile);
    Result:=True;
  end;
end;

procedure SaveFile(FileName:string;MsgCount:integer);
var
  RegFile:file of TEventMsg;
  i:integer;
begin
  AssignFile(RegFile,FileName);
  Rewrite(RegFile);
  for i:=0 to MsgCount-1 do begin
    Application.ProcessMessages;
    write(RegFile,PM[i]);
   // writeln;
  end;
  CloseFile(RegFile);
end;


function CheckFileValidity(FileName:string;var RecCount:integer):Boolean;
var
  FileSize:DWord;
  hFile:THandle;
  lpReOpenBuff:TOFStruct;
begin
  hFile:= OpenFile(Pchar(FileName),lpReOpenBuff,OF_READ);
  if hFile=HFILE_ERROR then begin
    ShowMessage(OpenFileError+FileName+'.');
    Result:=False;
    Exit;
  end;
  FileSize:=GetFileSize(hFile, nil);
  FileClose(hFile);
  if FileSize=0 then begin
    ShowMessage(EmptyFile+FileName+'.');
    Result:=False;
    Exit;
  end;
  if (FileSize mod 20) <>0 then begin
    ShowMessage(IllegleFile+FileName+'.');
    Result:=False;
    Exit;
  end else begin
    RecCount:=FileSize div 20;
    Result:=True;
  end;
end;

procedure GetMessageFromFile(FileName:string;RecCount:integer);
var
  RegFile:file of TEventMsg;
  i:integer;
begin
  setLength(PM1,RecCount);
  AssignFile(RegFile,FileName);
  Reset(RegFile);
  for i:=0 to RecCount-1 do  Read(RegFile,PM1[i]);
  CloseFile(RegFile);
end;

procedure  GetUserInfo(var UserName,CompanyName:string);
var
  MyReg:TRegistry;
begin
  MyReg:=TRegistry.Create;
  MyReg.RootKey:=HKEY_LOCAL_MACHINE;
  MyReg.OpenKey(KeyPath,False);
  UserName:=MyReg.ReadString(User);
  CompanyName:=MyReg.ReadString(Company);
  MyReg.CloseKey;
  MyReg.Free;
end;
procedure TForm1.BtnRecordClick(Sender: TObject);
begin
  MsgCount:=0;
  if not BtnPlayBack.Enabled then begin  //正在回放时，不允许录制
    Showmessage(PlayingBackMessage);
    Exit;
  end;
  BtnRecord.Enabled:=False;
  BtnStopRec.Enabled:=True;
  if CBMinWindows.Checked then setMinWindows;
  Timer1.Enabled:=True;
  if not GetMessage then Begin
    ShowMessage(GetMessageError);
    BtnRecord.Enabled:=True;
    BtnStopRec.Enabled:=False;
    Exit;
  end;
end;

procedure TForm1.BtnStopRecClick(Sender: TObject);
begin
  if MessageStr='' then begin
    ShowMessage(StopRecordMessage);
    Exit;
  end;
  if not StopGetMessage then begin
    ShowMessage(StopRecordError);
    Exit;
  end;
  BtnRecord.Enabled:=True;
  BtnStopRec.Enabled:=False;
  StopRoll;
  MakeMessage;
end;

procedure TForm1.BtnSaveFileClick(Sender: TObject);
begin
  if MsgCount=0 then begin   // //当没有录制任何动作时，不存盘
    ShowMessage(NoRecordMessage);
    Exit;
  end;
  if not BtnRecord.Enabled then  begin //在录制时，不允许存盘。
    ShowMessage(RecordingMessage);
    Exit;
  end;
  if CheckFile(EtFileName.Text) then exit; 
  SaveFile(EtFileName.Text,MsgCount);
end;

procedure TForm1.CBSaveFileClick(Sender: TObject);
begin
  EtFileName.ReadOnly:=not CBSaveFile.Checked;
  if EtFileName.ReadOnly then EtFileName.Color:=clScrollBar
  else EtFileName.Color:=clWindow;
  BtnSaveFile.Enabled:=CBSaveFile.Checked;
end;

procedure TForm1.BtnPlayBackClick(Sender: TObject);
var
  RecCount:integer;
begin
  if not BtnRecord.Enabled then begin //当正在录制时，不回放
    ShowMessage(RecordingMessage);   
    Exit;
  end;
  if CBPlayBack.Checked then begin
    if not CheckFileValidity(EtPlayFileName.Text,RecCount) then Exit;
    GetMessageFromFile(EtPlayFileName.Text,RecCount);
    ArrayCount:=RecCount;
  end else begin
    if MsgCount=0 then  begin //当没有录制任何动作时，不回放
      ShowMessage(NoRecordMessage);
      Exit;
    end;
  end;
  BtnStopPlay.Enabled:=True;
  BtnPlayBack.Enabled:=False;
  if CBMinWindows.Checked then setMinWindows;
  Timer1.Enabled:=True;
  if not PlayBackMessage then begin
    ShowMessage(PlayBackMessageError);
    BtnStopPlay.Enabled:=False;
    BtnPlayBack.Enabled:=True;
    Exit;
  end;
end;

procedure TForm1.BtnStopPlayClick(Sender: TObject);
begin
  if  not StopPlayBackMessage then begin
    ShowMessage(StopPlayMessageError);
    Exit;
  end;
  BtnPlayBack.Enabled:=True;
  BtnStopPlay.Enabled:=False;
  StopRoll;
end;

procedure TForm1.CBPlayBackClick(Sender: TObject);
begin
  EtPlayFileName.ReadOnly:= not CBPlayBack.Checked;
  if not EtPlayFileName.ReadOnly then EtPlayFileName.Color:=clWindow
  else EtPlayFileName.Color:=clScrollBar;
  BtnBrowse.Enabled:=CBPlayBack.Checked;
end;

procedure TForm1.BtnBrowseClick(Sender: TObject);
begin
 if OpenMco.Execute then EtPlayFileName.Text:=OpenMco.FileName;
end;

procedure TForm1.EtFileNameChange(Sender: TObject);
var
  tmp,tmp1:string;
  Len,i:integer;
begin
  tmp:=EtFileName.Text;
  len:=Length(tmp);
  if len<=4 then begin
    EtFileName.Text:=ExtName;
  end else begin
    for i:= 3 downto 0 do begin
      tmp1:=Copy(tmp,len-(4-(i+1)),1);
      if tmp1<>ExtChar[i] then begin
        Insert(ExtChar[i],tmp,Len-(4-(i+1))+1);
        break;
      end;  
    end;
    EtFileName.Text:=tmp;
  end;
end;

procedure TForm1.LbCompanyClick(Sender: TObject);
begin
  ShellExecute(0,nil,PChar(CompanyWebSite),nil,nil,SW_NORMAL);
end;

procedure TForm1.LbEmailClick(Sender: TObject);
begin
 ShellExecute(0,nil,PChar(AuthorEmail),nil,nil,SW_NORMAL);
end;

procedure TForm1.LbWebSiteClick(Sender: TObject);
begin
 ShellExecute(0,nil,PChar(AuthorWebSite),nil,nil,SW_NORMAL);
end;

procedure TForm1.PageControl1Change(Sender: TObject);
var
  UserName,CompanyName:string;
begin
  if PageControl1.ActivePage=TabSheet3 then begin
    GetUserInfo(UserName,CompanyName);
    LbUserName.Caption:=UserName;
    LbCompanyName.Caption:=CompanyName;
  end;
  if not (PageControl1.ActivePage=TabSheet1)  then begin
    if (not BtnRecord.Enabled) or (not BtnPlayBack.Enabled) then begin
      ShowMessage(ReCordingOrPlaying);
      PageControl1.ActivePage:=TabSheet1;
      Exit;
    end;
  end;

end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  if K<=1 then begin
    ImageList1.GetIcon(k,Application.Icon);
    Form1.Icon:=Application.Icon;
    Inc(K);
  end else k:=0;
end;

end.