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

這是一個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                    }
{                   &nbsp;                                                     }
{ *********************************************************************** }

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);
&nbsp;         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
&nbsp; 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;
  &nbsp; 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
&nbsp;       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。不過回復的有點慢，見諒.