recorder.pas

大家是不是为不知道如何在VB学到绝地程序

// TRecorder
//
// cyamon software
// place de l'H魌el-de-Ville 8
// 1040 Echallens
// Switzerland
// www.cyamon.com

// 11/99

// This unit is a freeware. You may change it, use it in your applications
// at your own risks.

// The recorder is an object that allows to record and play back mouse and
// keyboard events. The recorder is not a component, it is instead a singleton
// that is created and destroyed automatically in the initialization and
// finalization parts of this unit. The recorded information is saved into a
// memory stream.

// The recorder exports the following properties and methods:

// property State (Read only) is the recorder's state (idle, recording or playing).

// property SpeedFactor is the factor (in %) by which the playback speed is modified.
// Values < 100 accelerate, and values > 100 slowdown.

// property OnStateChange is an event that is fired when the state changes.

// procedure DoRecord(Append : boolean);
// Starts recording. When "Append" is true the new recorded information is appended
// to information already stored in the local stream. Otherwise, the local stream is
// clared before recording.

// procedure DoPlay;
// Plays the recorded information

// procedure DoStop;
// Stops recording and/or to playing

{***************************************************************
 * Modified by: riceball
 * History     :
 *        2000-5-4 9:56
 *           * Record keyboard events only
 *           + doPlay can pause now.
 *           + procedure Play;
 *           + procedure Stop;
 *           + procedure Pause;
 *           + procedure Recorde;
 *
 *_______________________________________________________________
 *legend:
 *  +  New Feature Added.
 *  #  New(Todo) Feature Added, but not work , just a start.
 *  -  Old Feature removed.
 *  *  Bug Fixed.
 *  !  Bug Found, Not Fixed.
 *  ^  My Todo Wish.
 ****************************************************************}

Unit Recorder;

Interface
Uses
  Classes,
  Windows;

Type
  TRecorderState = (rsIdle, rsRecording, rsPlaying);
  TStateChangeEvent = Procedure(NewState: TRecorderState) Of Object;

  TRecorder = Class(TObject)
  Private
    EventMsg: TEventMsg;
    FState: TRecorderState;
    FStream: TStream;
    HookHandle: THandle;
    BaseTime: Integer;
    FSpeedFactor: Integer;
    FPaused: Boolean;
    FOnStateChange: TStateChangeEvent;
    Procedure SetSpeedFactor(Const Value: Integer);
    Constructor Create;
    Procedure SetState(Const Value: TRecorderState);
  Public
    Destructor Destroy; Override;
    Procedure DoPlay(Continued: Boolean);
    Procedure DoRecord(Append: Boolean);
    Procedure DoStop;
    Procedure Play;
    Procedure Stop;
    Procedure Pause;
    Procedure Recorde;
    Property SpeedFactor: Integer Read FSpeedFactor Write SetSpeedFactor;
    Property OnStateChange: TStateChangeEvent Read FOnStateChange Write FOnStateChange;
    Property State: TRecorderState Read FState;
    Property Stream: TStream Read FStream;
  End;

Var
  TheRecorder: TRecorder;

Implementation
Uses
  SysUtils,
  Messages;
{~t}
(************)
(* PlayProc *)
(************)

Function PlayProc(Code: Integer; Undefined: WPARAM; P: LParam): LResult; Stdcall;
Begin
  Result := 0;
  If Code < 0 Then    Result := CallNextHookEx(TheRecorder.HookHandle, Code, Undefined, P)
  Else Begin
    Case Code Of
      HC_SKIP: Begin
          If TheRecorder.FStream.Position < TheRecorder.FStream.Size Then Begin
            TheRecorder.FStream.Read(TheRecorder.EventMsg, SizeOf(EventMsg));
            TheRecorder.EventMsg.Time := TheRecorder.SpeedFactor * (Integer(TheRecorder.EventMsg.Time) Div 100);
            TheRecorder.EventMsg.Time := Integer(TheRecorder.EventMsg.Time) + TheRecorder.BaseTime;
          End Else TheRecorder.SetState(rsIdle);
        End;
      HC_GETNEXT: Begin
          Result := TheRecorder.EventMsg.Time - GetTickCount();
          If Result < 0 Then Result := 0;
          PEventMsg(P)^ := TheRecorder.EventMsg;
        End;
    Else
      PEventMsg(P)^ := TheRecorder.EventMsg;
      Result := CallNextHookEx(TheRecorder.HookHandle, Code, Undefined, P)
    End {case};
  End {if};
End {PlayProc};

(**************)
(* RecordProc *)
(**************)

Function RecordProc(Code: Integer; Undefined: WPARAM; P: LParam): LResult; Stdcall;
Begin
  Result := 0;
  If Code < 0 Then Result := CallNextHookEx(TheRecorder.HookHandle, Code, Undefined, P)
  Else Begin
    Case Code Of
      HC_ACTION: Begin
          TheRecorder.EventMsg := PEventMsg(P)^;
          TheRecorder.EventMsg.Time := Integer(TheRecorder.EventMsg.Time) - TheRecorder.BaseTime;
          If (TheRecorder.EventMsg.Message >= WM_KEYFIRST) And (TheRecorder.EventMsg.Message <= WM_KEYLAST) Then Begin
            //only record keyboard events
            If (LoByte(TheRecorder.EventMsg.ParamL) = VK_CANCEL) Then TheRecorder.SetState(rsIdle); // Recording aborted by ctrl-Break
            TheRecorder.FStream.Write(TheRecorder.EventMsg, SizeOf(TheRecorder.EventMsg));
          End {if};
        End;
      HC_SYSMODALON: ;
      HC_SYSMODALOFF:
    End {case};
  End {if};
End {RecordProc};

(********************)
(* TRecorder.Create *)
(********************)

Constructor TRecorder.Create;
Begin
  If TheRecorder = Nil Then Begin
    FStream := TMemoryStream.Create;
    FSpeedFactor := 0; //100: normal speed
    FPaused := False;
  End Else
    FAIL;
End {TRecorder.Create};

(*********************)
(* TRecorder.Destroy *)
(*********************)

Destructor TRecorder.Destroy;
Begin
  DoStop;
  FStream.Free;
  Inherited;
End {TRecorder.Destroy};

Procedure TRecorder.Play;
Begin
  doPlay(FPaused);
End;

Procedure TRecorder.Stop;
Begin
  FPaused := False;
  doStop;
End;

Procedure TRecorder.Pause;
Begin
  FPaused := True;
  doStop;
End;

Procedure TRecorder.Recorde;
Begin
  doRecord(FPaused);
End;

(********************)
(* TRecorder.DoPlay *)
(********************)

Procedure TRecorder.DoPlay(Continued: Boolean);
Begin
  If State <> rsIdle Then
    Raise Exception.Create('Recorder: Not ready to play.')
  Else If FStream.Size = 0 Then
    Raise Exception.Create('Recorder: Nothing to play')
  Else Begin
    If Not Continued Then FStream.Seek(0, 0);
    FStream.Read(EventMsg, SizeOf(EventMsg));
    HookHandle := SetWindowsHookEx(WH_JOURNALPLAYBACK, @PlayProc, HInstance, 0);
    If HookHandle = 0 Then
      Raise Exception.Create('Playback hook cannot be created')
    Else Begin
      BaseTime := GetTickCount();
      SetState(rsPlaying);
    End {if};
  End {if};
End {TRecorder.DoPlay};

(**********************)
(* TRecorder.DoRecord *)
(**********************)

Procedure TRecorder.DoRecord(Append: Boolean);
Begin
  If State <> rsIdle Then
    Raise Exception.Create('Recorder: NotReady to record.')
  Else Begin
    If Not Append Then Begin
      FStream.Size := 0;
      BaseTime := GetTickCount();
    End Else Begin
      EventMsg.Time := 0;
      If FStream.Size > 0 Then Begin
        FStream.Seek(-SizeOf(EventMsg), SoFromCurrent);
        FStream.Read(TheRecorder.EventMsg, SizeOf(EventMsg));
      End {if};
      BaseTime := GetTickCount() - EventMsg.Time;
    End {if};
    HookHandle := SetWindowsHookEx(WH_JOURNALRECORD, @RecordProc, HInstance, 0);
    If HookHandle = 0 Then
      Raise Exception.Create('JournalHook cannot be created')
    Else Begin
      SetState(rsRecording);
    End {if};
  End {if};
End {TRecorder.DoRecord};

(********************)
(* TRecorder.DoStop *)
(********************)

Procedure TRecorder.DoStop;
Begin
  SetState(rsIdle);
End {TRecorder.DoStop};

(****************************)
(* TRecorder.SetSpeedFactor *)
(****************************)

Procedure TRecorder.SetSpeedFactor(Const Value: Integer);
Begin
  If Value > 0 Then
    FSpeedFactor := Value;
End {TRecorder.SetSpeedFactor};

(**********************)
(* TRecorder.SetState *)
(**********************)

Procedure TRecorder.SetState(Const Value: TRecorderState);
Begin
  If (Value = rsIdle) And (HookHandle <> THandle(0)) Then Begin
    UnHookWindowsHookEx(HookHandle);
    HookHandle := THandle(0);
  End {if};
  If Value <> FState Then Begin
    FState := Value;
    If Assigned(FOnStateChange) Then
      FOnStateChange(FState)
  End {if};
End {TRecorder.SetState};

{~b}
Initialization
  TheRecorder := Nil;
  TheRecorder := TRecorder.Create;
Finalization
  TheRecorder.Free;
End.