程式師世界 >> 編程語言 >> .NET網頁編程 >> .NET實例教程 >> 清除文本文檔中的多余分隔符

清除文本文檔中的多余分隔符

編輯：.NET實例教程

這是一個DELPHI編寫的小程序，對於對付網上眾多靠空格和換行加長篇幅的文章。它可以清除多余的空格、換行及TAB。Delphi7，WINXP編碼通過
program pcliptxt;

{$APPTYPE CONSOLE}

uses
SysUtils,classes;

const
TTheFmtChar=[#9,#10,#13,#32];
THeadLine=#13#10#32#32;

var
fCount:integer;
fHasChar,fHeadLine:boolean;
msSrc:TMemoryStream;
i:integer;

begin
{ TODO -oUser -cConsole Main : Insert code here }
if ParamCount<1 then begin
    writeln('Examples:cliptxt TextFilename');
    exit;
end;
if not FileExists(ParamStr(1)) then begin
    writeln('The file:',ParamStr(1),'not found!');
    exit;
end;
fHeadLine:=false; fHasChar:=false;
mssrc:=TMemoryStream.Create;
try
    mssrc.LoadFromFile(ParamStr(1));
    i:=0;fcount:=0;
    while i<=mssrc.size-1 do begin
     if (pchar(mssrc.Memory)[i] in TTheFmtChar) then begin
       if not fHasChar then
        fHasChar:=true
       else begin
        inc(i);
        inc(fcount);
       end;
       if pchar(mssrc.memory)[i] in [#10,#13] then
         fHeadLine:=true;
     end
     else begin
       if fHeadLine then begin
         write(THeadLine);
         fHeadLine:=false;
       end
       else begin
       if (fHasChar) and (0<fCount) then
         dec(i);
       end;
       fHasChar:=false;

;     Write(pchar(mssrc.memory)[i]);
       inc(i);
     end;
   end;
finally
    mssrc.Free;
end;
end.
;
//   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==================//
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;
& nbsp;   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.

//==關鍵代碼uApartThread.pas==//
unit UApartThread;

interface
uses sysutils,classes,Windows,activex,SdkSrv_TLB,uRmtObj,strutils;

type
TTmpThread=class(TThread)
procedure Execute; override;
end;

function GetWaitTime(var str: string): integer;
Function CreatRMTObj(const ComputerName,UserName,PassWord:widestring):MySendKey;

implementation
uses comobj, uSndClIEnt;

function GetWaitTime(var str: string): integer;
var
tmp:string;
begin
Result:=0;
if str[1]='@' then begin
    tmp:=MidStr(str,2,4);
    TryStrToInt(tmp,result);
    Delete(str,1,5);
end
end;

Function CreatRMTObj(const ComputerName,UserName,PassWord:widestring):MySendKey;
begin
Result:=IMySendKey(DoConnect(@CLASS_MySendKey,
                               @IID_IMySendKey,
                               ComputerName,UserName,PassWord));
end;

procedure TTmpThread.Execute;
var
tmp:string;
begin
CoInitializeEx(nil,COINIT_APARTMENTTHREADED);
try
    with frmSendKey do begin
      if not assigned(rmtObject) then begin
        sComputer:=trim(edComputer.Text);
        sUser:=trim(edUser.text);
        sPsw:=trim(edpsw.text);
        rmtObject:=CreatRMTObj(sComputer,sUser,sPsw);
      end;
      rmtObject.WinName:=SendWinName;//目標Windows標題
      KeyCount:=0;
      while (not terminated) do begin
          if not Assigned(rmtObject) then exit;
          if KeyCount>=FWoWKeyList.Count then KeyCount:=0;
          tmp:=FWoWKeyList[keyCount];
          with rmtobject do begin
            Sleep(GetWaitTime(tmp));
            SendStr2(tmp,-1);
            inc(KeyCount);
          end;
        end;
      end;
finally
    CoUninitialize;
end;
end;

end.

有問題留言或email。不過回復的有點慢，見諒.