向远程计算机发送按键

来源：互联网发布：淘宝满400减50 编辑：程序博客网时间：2024/06/10 08:49

　　这个是一人ＣＯＭ应用，利用客户应用程序通过远程服务器上的服务端应用发送按键。由于这段工作时间紧，我先将源代码中部份内容贴上，并在资源中提供全部源代码下载。　　注意看到程序代码里“魔兽世界”四个字，大家就应该可以想到我用它是干什么的了，不是要黑别人，而是要带一个牧师小号，呵呵。

==========服务器端================

unit skSrv;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls,SyncObjs;

type
TfrmskSrv = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    Button1: TButton;
    memInfo: TMemo;
    chkBlock: TCheckBox;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);

    procedure chkBlockClick(Sender: TObject);
private
    { Private declarations }
public
    { Public declarations }
end;

var
frmskSrv: TfrmskSrv;
csection:TCriticalSection;
InfoCount:integer;
BlockInfo:integer;

implementation

{$R *.dfm}

procedure TfrmskSrv.Button1Click(Sender: TObject);
begin
Close;
end;

procedure TfrmskSrv.FormCreate(Sender: TObject);
begin
csection:=TCriticalSection.Create;
BlockInfo:=0;
end;

procedure TfrmskSrv.FormDestroy(Sender: TObject);
begin
csection.Free;
end;

procedure TfrmskSrv.chkBlockClick(Sender: TObject);
begin
if chkBlock.Checked then
InterlockedIncrement(BlockInfo)
else
InterlockedDecrement(BlockInfo);
end;

end.//======类型库===========

unit SdkSrv_TLB;

// ************************************************************************ //
// WARNING
// -------
// The types declared in this file were generated from data read from a
// Type Library. If this type library is explicitly or indirectly (via
// another type library referring to this type library) re-imported, or the
// 'Refresh' command of the Type Library Editor activated while editing the
// Type Library, the contents of this file will be regenerated and all
// manual modifications will be lost.
// ************************************************************************ //

// PASTLWTR : 1.2
// File generated on 2007-08-07 19:37:40 from Type Library described below.

// ************************************************************************ //
// Type Lib: D:/MyPrograms/Sendkey/src/SdkSrv.tlb (1)
// LIBID: {3B01ECB9-6782-4B27-8BB4-84B2B4E4B962}
// LCID: 0
// Helpfile:
// HelpString: SdkSrv Library
// DepndLst:
// (1) v2.0 stdole, (C:/WINDOWS/system32/STDOLE2.TLB)
// ************************************************************************ //
{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers.
{$WARN SYMBOL_PLATFORM OFF}
{$WRITEABLECONST ON}
{$VARPROPSETTER ON}
interface

uses Windows, ActiveX, Classes, Graphics, StdVCL, Variants;

// *********************************************************************//
// GUIDS declared in the TypeLibrary. Following prefixes are used:
//   Type Libraries     : LIBID_xxxx
//   CoClasses          : CLASS_xxxx
//   DISPInterfaces     : DIID_xxxx
//   Non-DISP interfaces: IID_xxxx
// *********************************************************************//
const
// TypeLibrary Major and minor versions
SdkSrvMajorVersion = 1;
SdkSrvMinorVersion = 0;

LIBID_SdkSrv: TGUID = '{3B01ECB9-6782-4B27-8BB4-84B2B4E4B962}';

IID_IMySendKey: TGUID = '{24049466-2060-4CAF-BBE7-559268B54127}';
DIID_IMySendKeyEvents: TGUID = '{A10A15B5-8B3E-4366-9252-E5418699ACF7}';
CLASS_MySendKey: TGUID = '{95E49D0E-D659-4366-9279-BB700D9161F0}';
type

// *********************************************************************//
// Forward declaration of types defined in TypeLibrary
// *********************************************************************//
IMySendKey = interface;
IMySendKeyDisp = dispinterface;
IMySendKeyEvents = dispinterface;

// *********************************************************************//
// Declaration of CoClasses defined in Type Library
// (NOTE: Here we map each CoClass to its Default Interface)
// *********************************************************************//
MySendKey = IMySendKey;

// *********************************************************************//
// Interface: IMySendKey
// Flags:     (4416) Dual OleAutomation Dispatchable
// GUID:      {24049466-2060-4CAF-BBE7-559268B54127}
// *********************************************************************//
IMySendKey = interface(IDispatch)
    ['{24049466-2060-4CAF-BBE7-559268B54127}']
    procedure SendStr(vwait: SYSINT); safecall;
    function Get_WinName: WideString; safecall;
    procedure Set_WinName(const Value: WideString); safecall;
    function Get_KeyStr: WideString; safecall;
    procedure Set_KeyStr(const Value: WideString); safecall;
    procedure SetWinAndKey(const WinName: WideString; const KeyStr: WideString); safecall;
    procedure SendStr2(const KeyStr: WideString; vwait: Integer); safecall;
    property WinName: WideString read Get_WinName write Set_WinName;
    property KeyStr: WideString read Get_KeyStr write Set_KeyStr;
end;

// *********************************************************************//
// DispIntf: IMySendKeyDisp
// Flags:     (4416) Dual OleAutomation Dispatchable
// GUID:      {24049466-2060-4CAF-BBE7-559268B54127}
// *********************************************************************//
IMySendKeyDisp = dispinterface
    ['{24049466-2060-4CAF-BBE7-559268B54127}']
    procedure SendStr(vwait: SYSINT); dispid 201;
    property WinName: WideString dispid 202;
    property KeyStr: WideString dispid 203;
    procedure SetWinAndKey(const WinName: WideString; const KeyStr: WideString); dispid 204;
    procedure SendStr2(const KeyStr: WideString; vwait: Integer); dispid 205;
end;

// *********************************************************************//
// DispIntf: IMySendKeyEvents
// Flags:     (4096) Dispatchable
// GUID:      {A10A15B5-8B3E-4366-9252-E5418699ACF7}
// *********************************************************************//
IMySendKeyEvents = dispinterface
    ['{A10A15B5-8B3E-4366-9252-E5418699ACF7}']
end;

// *********************************************************************//
// The Class CoMySendKey provides a Create and CreateRemote method to
// create instances of the default interface IMySendKey exposed by
// the CoClass MySendKey. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoMySendKey = class
    class function Create: IMySendKey;
    class function CreateRemote(const MachineName: string): IMySendKey;
end;

implementation

uses ComObj;

class function CoMySendKey.Create: IMySendKey;
begin
Result := CreateComObject(CLASS_MySendKey) as IMySendKey;
end;

class function CoMySendKey.CreateRemote(const MachineName: string): IMySendKey;
begin
Result := CreateRemoteComObject(MachineName, CLASS_MySendKey) as IMySendKey;
end;

end.

//==========实现类型库===========//

unit uSrvMain;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
ComObj, ActiveX, AxCtrls, Classes, SdkSrv_TLB, StdVcl,uComFactory;

type
TMySendKey = class(TAutoObject, IConnectionPointContainer, IMySendKey)
private
    { Private declarations }
    FConnectionPoints: TConnectionPoints;
    FConnectionPoint: TConnectionPoint;
    FEvents: IMySendKeyEvents;
    { note: FEvents maintains a *single* event sink. For access to more
      than one event sink, use FConnectionPoint.SinkList, and iterate
      through the list of sinks. }
    FWinName:string;
    FKeyStr:string;
    //FInfoCount:integer;
public
    procedure Initialize; override;
protected
    { Protected declarations }
    property ConnectionPoints: TConnectionPoints read FConnectionPoints
      implements IConnectionPointContainer;
    procedure EventSinkChanged(const EventSink: IUnknown); override;
    procedure SendStr(vwait: SYSINT); safecall;
    function Get_WinName: WideString; safecall;
    procedure Set_WinName(const Value: WideString); safecall;
    function Get_KeyStr: WideString; safecall;
    procedure Set_KeyStr(const Value: WideString); safecall;
    procedure WriteInfo;
    procedure SetWinAndKey(const WinName, KeyStr: WideString); safecall;
    procedure SendStr2(const KeyStr: WideString; vWait: Integer); safecall;
end;

implementation

uses ComServ, sndkey32, skSrv, DateUtils;

procedure TMySendKey.EventSinkChanged(const EventSink: IUnknown);
begin
FEvents := EventSink as IMySendKeyEvents;
end;

procedure TMySendKey.Initialize;
begin
inherited Initialize;
FConnectionPoints := TConnectionPoints.Create(Self);
if AutoFactory.EventTypeInfo <> nil then
FConnectionPoint := FConnectionPoints.CreateConnectionPoint(
AutoFactory.EventIID, ckSingle, EventConnect)
else FConnectionPoint := nil;
end;

procedure TMySendKey.SendStr(vwait: SYSINT);
begin
if (FWinName<>'') and (FKeyStr<>'') then begin
   if AppActivate(PAnsiChar(FWinName)) then begin
    SendKeys(PAnsiChar(fkeystr),vwait=0);
    if BlockInfo=0 then
      writeinfo;
   end;
end;
end;

function TMySendKey.Get_WinName: WideString;
begin
Result:=FWinName;
end;

procedure TMySendKey.Set_WinName(const Value: WideString);
begin
if Value<>'' then begin
FWinName:=Value;
end;
end;

function TMySendKey.Get_KeyStr: WideString;
begin
result:=FKeyStr;
end;

procedure TMySendKey.Set_KeyStr(const Value: WideString);
begin
if Value<>'' then begin
FKeyStr:=Value;
end;
end;

procedure TMySendKey.WriteInfo;
begin
With frmskSrv.memInfo.Lines do begin
    csection.Acquire;
    try
      if InfoCount>1000 then begin
       clear;
       InfoCount:=0;
      end;
      Add(concat(FWinName,':',FKeyStr));
      inc(InfoCount);
    finally
      csection.Release;
    end;
end;
end;

procedure TMySendKey.SetWinAndKey(const WinName, KeyStr: WideString);
begin
FWinName:=WinName;
FKeyStr:=KeyStr;
if BlockInfo=0 then
WriteInfo;
end;

procedure TMySendKey.SendStr2(const KeyStr: WideString; vWait: Integer);
begin
if (FWinName<>'') then begin
   if AppActivate(PAnsiChar(FWinName)) then begin
    FKeyStr:=KeyStr;
    SendKeys(PAnsiChar(FKeyStr),vwait=0);
    if BlockInfo=0 then
      writeinfo;
   end;
end;
end;

initialization
TMyComApartmentFactory.Create(ComServer, TMySendKey, Class_MySendKey,
ciMultiInstance, tmApartment);
end.

//=======改写的Apartment线程工厂类==============// { *********************************************************************** }
{                                                                         }
{ Delphi Runtime Library                                                  }
{                                                                         }
{ Copyright (c) 1997-2001 Borland Software Corporation                    }
{                                                                         }
{ *********************************************************************** }

unit uComFactory;

{$H+,X+}

interface

uses ActiveX, ComObj, Classes;

type

{ Component object factory }

TMyComApartmentFactory = class(TAutoObjectFactory, IClassFactory)
protected
    function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
      out Obj): HResult; stdcall;
public
    constructor Create(ComServer: TComServerObject;
      ComClass: TAutoClass; const ClassID: TGUID;
      Instancing: TClassInstancing; ThreadingModel: TThreadingModel = tmSingle);
end;

implementation

uses
Windows, SysUtils;

type

{ TApartmentThread }

TMyApartmentThread = class(TThread)
private
    FFactory: IClassFactory2;
    FUnkOuter: IUnknown;
    FIID: TGuid;
    FSemaphore: THandle;
    FStream: Pointer;
    FCreateResult: HResult;
protected
    procedure Execute; override;
public
    constructor Create(Factory: IClassFactory2; UnkOuter: IUnknown; IID: TGuid);
    destructor Destroy; override;
    property Semaphore: THandle read FSemaphore;
    property CreateResult: HResult read FCreateResult;
    property ObjStream: Pointer read FStream;
end;

{ TMyApartmentThread }

constructor TMyApartmentThread.Create(Factory: IClassFactory2;
UnkOuter: IUnknown; IID: TGuid);
begin
FFactory := Factory;
FUnkOuter := UnkOuter;
FIID := IID;
FSemaphore := CreateSemaphore(nil, 0, 1, nil);
FreeOnTerminate := True;
inherited Create(False);
end;

destructor TMyApartmentThread.Destroy;
begin
CloseHandle(FSemaphore);
inherited Destroy;
end;

procedure TMyApartmentThread.Execute;
var
msg: TMsg;
Unk: IUnknown;
begin
try
    CoInitializeEx(nil,COINIT_APARTMENTTHREADED);
    try
      FCreateResult := FFactory.CreateInstanceLic(FUnkOuter, nil, FIID, '', Unk);
      FUnkOuter := nil;
      FFactory := nil;
      if FCreateResult = S_OK then
        CoMarshalInterThreadInterfaceInStream(FIID, Unk, IStream(FStream));
      ReleaseSemaphore(FSemaphore, 1, nil);
      if FCreateResult = S_OK then
        while GetMessage(msg, 0, 0, 0) do
        begin
          DispatchMessage(msg);
          Unk._AddRef;
          if Unk._Release = 1 then break;
        end;
    finally
      Unk := nil;
      CoUninitialize;
    end;
except
    { No exceptions should go unhandled }
end;
end;

{ TMyComApartmentFactory }

constructor TMyComApartmentFactory.Create(ComServer: TComServerObject;
ComClass:TAutoClass; const ClassID: TGUID;
Instancing: TClassInstancing; ThreadingModel: TThreadingModel);
begin
inherited Create(ComServer, ComClass,
ClassID, Instancing, ThreadingModel);
end;

function TMyComApartmentFactory.CreateInstance(const UnkOuter: IUnknown;
const IID: TGUID; out Obj): HResult; stdcall;
begin
if not IsLibrary and (ThreadingModel = tmApartment) then
begin
    LockServer(True);
    try
      with TMyApartmentThread.Create(Self, UnkOuter, IID) do
      begin
        if WaitForSingleObject(Semaphore, INFINITE) = WAIT_OBJECT_0 then
        begin
          Result := CreateResult;
          if Result <> S_OK then Exit;
          Result := CoGetInterfaceAndReleaseStream(IStream(ObjStream), IID, Obj);
        end else
          Result := E_FAIL
      end;
    finally
      LockServer(False);
    end;
end else
    Result := inherited CreateInstance(UnkOuter, IID, Obj);
end;

initialization

finalization

end.

//客户端关键代码是uRmtobj.pas这个文件

//客户端主窗体代码

unit uSndClient;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, sdkSrv_tlb, comobj,activex, ExtCtrls,urmtobj,
ComCtrls, ToolWin,UApartThread,Buttons, LMDCustomComponent, LMDIniCtrl;

type

TfrmSendKey = class(TForm)
    edWinName: TEdit;
    edKeystr: TEdit;
    Button2: TButton;
    Label1: TLabel;
    Label2: TLabel;
    edComputer: TEdit;
    edUser: TEdit;
    edPsw: TEdit;
    lmdIni: TLMDIniCtrl;
    btnWriteIni: TButton;
    btnLoadKey: TButton;
    cbOnTop: TCheckBox;
    ToolBar1: TToolBar;
    tb1: TToolButton;
    tb2: TToolButton;
    tb3: TToolButton;
    tb4: TToolButton;
    tb5: TToolButton;
    tb6: TToolButton;
    ToolButton10: TToolButton;
    tb7: TToolButton;
    tb8: TToolButton;
    btStop: TButton;
    ToolButton1: TToolButton;
    sbMini: TSpeedButton;
    procedure Button2Click(Sender: TObject);
    procedure btnWriteIniClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnLoadKeyClick(Sender: TObject);
    procedure cbOnTopClick(Sender: TObject);
    procedure tb1Click(Sender: TObject);
    procedure btStopClick(Sender: TObject);
    procedure sbMiniClick(Sender: TObject);
protected

private
    FWinSize:integer;
    FWoWKeyString:string;
    FSendWinName:string;
    FRegion:THandle;
    FMainInt:MySendKey;
    procedure SetWoWKeyString(const Value: string);
    function ReadWoWKeyString: string;
    procedure SetSendWinName(const Value: string);
    function ReadSendWinName: string;
    procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest;
    procedure FreeCurrentRegion;
    { Private declarations }
public
    FWoWKeyList:TStringList;
    sComputer,sUser,sPsw:widestring;
    property WoWKeyString:string read ReadWoWKeyString write SetWoWKeyString;
    property SendWinName:string read ReadSendWinName write SetSendWinName;
    { Public declarations }
end;

var
frmSendKey: TfrmSendKey;
rmtObject:IMySendKey;
KeyCount:integer;
thr:TTmpThread;

implementation

uses Math, StrUtils;

{$R *.dfm}

{ TTmpThread }

procedure TfrmSendKey.Button2Click(Sender: TObject);
begin
close;
end;

procedure TfrmSendKey.SetWoWKeyString(const Value: string);
begin
FWoWKeyString := Value;
end;

function TfrmSendKey.ReadWoWKeyString: string;
begin
if edKeystr.Text<>'' then
FWoWKeyString:=edKeystr.Text;
result:=FWoWKeyString;
end;

procedure TfrmSendKey.SetSendWinName(const Value: string);
begin
FSendWinName := Value;
end;

function TfrmSendKey.ReadSendWinName: string;
begin
if edWinName.Text<>'' then
FSendWinName:=edWinName.text;
result:=FSendWinName;
end;

procedure TfrmSendKey.FormCreate(Sender: TObject);
begin
FWoWKeyList:=TStringList.Create;
FWinSize:=Height;
{ for i:=0 to ComponentCount-1 do begin
    with Components[i] do
      tmp:=CreateRectRgn(Left,Top,Left+Width,Top+Height);
      if i=0 then begin
        FRegion:=tmp;
        Continue;
      end;
      CombineRgn(FRegion,FRegion,tmp,RGN_AND);
      DeleteObject(tmp);
end;
If FRegion<>0 then
    SetWindowRgn(Handle,FRegion,true); }
{for i:=0 to ControlCount-1 do
    if TToolButton(Controls[i]).Style=tbsButton then begin
       TToolButton(Controls[i]).Caption:=inttostr(TToolButton(Controls[i]).tag);
       TToolButton(Controls[i]).Width:=23;
    end; }
end;

procedure TfrmSendKey.FormDestroy(Sender: TObject);
begin
if Assigned(thr) then
   with thr do begin
    Terminate;
    Free;
end;
FWoWKeyList.Free;
rmtObject:=nil;
FMainInt:=nil;
//FreeCurrentRegion;
end;

procedure TfrmSendKey.btnWriteIniClick(Sender: TObject);
begin
with lmdIni do begin
WriteString('WOWKey','KeyStr',WoWKeyString);
WriteString('WOWKey','SendWin',SendWinName);
end;
end;

procedure TfrmSendKey.btnLoadKeyClick(Sender: TObject);
begin
with lmdIni do begin
    WoWKeyString:=ReadString('WOWKey','KeyStr','9,r,4');
    edKeystr.Text:=FWoWKeyString;
    SendWinName:=ReadString('WOWKey','SendWin','魔兽世界');
    edWinName.Text:=FSendWinName;
end;
end;

procedure TfrmSendKey.cbOnTopClick(Sender: TObject);
begin
with cbOnTop do begin
    If Checked then frmSendKey.FormStyle:=fsStayOnTop
    else
      frmSendKey.FormStyle:=fsNormal;
end;
end;

procedure TfrmSendKey.tb1Click(Sender: TObject);
begin
   if not Assigned(FMainInt) then begin
     sComputer:=trim(edComputer.Text);
     sUser:=trim(edUser.text);
     sPsw:=trim(edpsw.text);
     FMainInt:=CreatRMTObj(sComputer,sUser,sPsw);
     FMainInt.WinName:=trim(edWinName.Text);
   end;
   if Assigned(FMainint) then
     with FMainint do begin
       SendStr2(inttostr(TToolButton(Sender).tag),-1);
     end;
end;

procedure TfrmSendKey.WMNCHitTest(var M: TWMNCHitTest);
begin
inherited;
if M.Result = htClient then M.Result := htCaption;
end;

procedure TfrmSendKey.FreeCurrentRegion;
begin
if FRegion<>0 then begin
    SetWindowRgn(Handle,0,true);
    DeleteObject(FRegion);
    FRegion:=0;
end;
end;

procedure TfrmSendKey.btStopClick(Sender: TObject);
begin
with btstop do begin
    if tag=$ff then begin
      if not Assigned(thr) then
        thr:=TTmpThread.Create(true);
      FWoWKeyList.CommaText:=WoWKeyString;//传送字符串
       tag:=$0;
       Caption:='S&top';
      thr.Resume;
    end
    else begin
      thr.Suspend;
      tag:=$ff;
      Caption:='&Send'
    end;
end;
end;

procedure TfrmSendKey.sbMiniClick(Sender: TObject);
begin
If sbMini.Caption = '↓' then begin
     Height:=FWinSize;
     sbMini.Caption := '↑'
end
else begin
    Height:=ToolBar1.Height+2;
    sbMini.Caption := '↓'
end;
end;

end.

//===========uRmtObj.pas==================//