0

为了测试应用程序的性能，同时接收许多请求，我创建了一个应用程序，它在线程内部，同时使用TDCOMConnection创建TClientDataSet、关联ProviderName和插入、更新和删除记录打开连接。但是当我尝试访问服务器时，出现以下错误：

应用程序调用了为不同线程编组的接口。

那会是什么？
你能帮我解决这个问题吗？

编辑

单元1.pas：

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtSvrConnect, ExtDBClient, SyncObjs, ActiveX;

type
  //0 - Executing
  //1 - Done
  //TMsg Adress
  PArray = ^TArray;
  TArray = Array of Integer;

  TCS = class(TMultiReadExclusiveWriteSynchronizer);

  TMsg = class
  public
    Done: Boolean;
    Strings: array of String;
  end;

  TWorker = class(TThread)
  private
    FOpt,
    FQuantity,
    FIndex: Integer;
    FRef: PArray;

    FCon: TExtSocketConnection;
    FCds: TExtClientDataSet;
    FMsg: TMsg;
  protected
    procedure OpenCds;
    procedure CreateObjs;
    procedure DestroyObjs;
    procedure Execute; override;
  public
    constructor Create(Opt, Quantity, I: Integer; Pt: PArray);
  end;

  TForm1 = class(TForm)
    Button1: TButton;
    edQuantity: TEdit;
    Memo1: TMemo;
    edClients: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Button2: TButton;
    Label8: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    Label11: TLabel;
    Label12: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    Workers : Array of TWorker;
    Signals : TArray;

    Size, Loop,
    Opt, CountDone: Integer;
  protected
    procedure InitializeThreads;
    procedure Reset;
    procedure Initialize;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  Cs: TCS;  

implementation

uses DB;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Reset;
  Initialize;
  Button2Click(Sender);
end;

procedure TForm1.InitializeThreads;
var I: Integer;
begin
  for I:= 0 to Length(Signals)-1 do
    Signals[I] := 0;

  for I:= 0 to Length(Workers)-1 do
    Workers[I] := TWorker.Create(Opt, Loop, I, @Signals);

  for I:= 0 to Length(Workers)-1 do
    Workers[I].Resume;
end;

procedure TForm1.Initialize;
begin
  try
     Size := StrToInt(edClients.Text);
     if Size <= 0 then
       raise Exception.Create('Value must be > 0');
  except
    //on EConvertError do
    ShowMessage('Invalid Number!');
    edClients.SetFocus;
  end;

  if Size > 0 then
  begin
    try
       Loop := StrToInt(edQuantity.Text);
       if Loop <= 0 then
         raise Exception.Create('Value must be > 0');
    except
      //on EConvertError do
      ShowMessage('Invalid Number!');
      edQuantity.SetFocus;
    end;

    if Loop > 0 then
    begin
      while (Opt < 1) or (Opt > 4) do
        try
          Opt := StrToInt(InputBox('Choose.','Choose', '4'));
        except
          Opt := 0;
          ShowMessage('Invalid Number!');
        end;

      SetLength(Workers, Size);
      SetLength(Signals, Size);
      InitializeThreads;
      Label11.Caption := IntToStr(Size);
    end;
  end;

  Button1.Enabled := (Size <= 0) or
                     (Loop <= 0);
end;

procedure TForm1.Reset;
begin
  Label11.Caption := '0'; //created
  Label12.Caption := '0'; //finalized
  Label8.Caption  := 'Threads terminated: 0';
  Size := 0;
  Loop := 0;
  Opt  := 0;
  CountDone:= 0;
  Memo1.Lines.Clear;
  Button1.Enabled := False;
end;

{ TWorker }

constructor TWorker.Create(Opt, Quantity, I: Integer; Pt: PArray);
begin
  inherited Create(True);
  FOpt   := Opt;
  FQuantity := Quantity;
  FIndex := I;
  FRef   := Pt;
  FreeOnTerminate := True;
end;

procedure TWorker.CreateObjs;
begin
  FMsg := TMsg.Create;

  FCon := TExtSocketConnection.Create(nil);
  FCon.Address := '127.0.0.1';
  FCon.ConnectionName := 'ServerConn';
  FCon.ComputerName := '127.0.0.1';
  FCon.LoginPrompt := False;
  FCon.ServerGUID := '{5CC58302-83A4-11D2-B28F-00E046600CDA}';
  FCon.ServerName := 'ServerConn.ServerConnDat';

  FCds := TExtClientDataSet.Create(nil);
  FCds.FieldDefs.Add('Code', ftInteger, 0, True);
  FCds.FieldDefs.Add('Code2', ftInteger, 0, True);
  FCds.FieldDefs.Add('Year', ftInteger, 0, True);
  FCds.FieldDefs.Add('Month', ftInteger, 0, True);
  FCds.FieldDefs.Add('Amount', ftInteger, 0, True);

  FCds.Params.CreateParam(ftInteger, 'Code', ptInput);
  FCds.Params.CreateParam(ftInteger, 'Code2', ptInput);

  FCds.RemoteServer := FCon;
  FCds.ProviderName := 'prvYearMonth';

  FCds.CreateDataSet;
end;

procedure TWorker.DestroyObjs;
begin
  FCon.AppServer.Logout;
  FCds.Free;
  FCon.Free;
  if Length(FMsg.Strings) = 0 then
    FMsg.Free;
end;

procedure TWorker.Execute;
var I: Integer;
    Y,M: Integer;
    Entered: Boolean;
begin
  inherited;
  CoInitialize(nil);
  CreateObjs;
  Y := 2013;
  M := 12;
  try
    OpenCds;
    for I:= 0 To FQuantity-1 do
    begin
      try
        //Insert
        FCds.Append;
        FCds.FieldByName('Code').AsInteger := 0;
        FCds.FieldByName('Code2').AsInteger := 1;
        FCds.FieldByName('Year').AsInteger := Y;
        FCds.FieldByName('Month').AsInteger := M;
        FCds.FieldByName('Amount').AsInteger := 99;
        FCds.Post;
        FCds.ApplyUpdates(0);

        //Update
        if FOpt > 2 then
        begin
          FCds.Last;
          FCds.Edit;
          FCds.FieldByName('Amount').AsInteger := 88;
          FCds.Post;
          FCds.ApplyUpdates(0);
        end;

        //delete
        if (FOpt mod 2) = 0 then
        begin
          FCds.Last;
          FCds.Delete;
          FCds.ApplyUpdates(0);
        end;

      except
        SetLength(FMsg.Strings, Length(FMsg.Strings)+1);
        FMsg.Strings[Length(FMsg.Strings)-1] := 'Turn: '+IntToStr(I)+'. Msg: '+Exception(ExceptObject).Message;
      end;

      Inc(M);
      if M = 13 then
      begin
        M := 1;
        Inc(Y);
      end;
    end;
    if Length(FMsg.Strings) > 0 then
    begin
      repeat Entered := Cs.BeginWrite;
       until Entered; //Hint: Is this necessary??

      try
        FMsg.Done := True;
        FRef^[FIndex] := Integer(FMsg);
      finally Cs.EndWrite; end;
    end
    else
    begin
      repeat Entered := Cs.BeginWrite;
      until Entered;

      try
        FRef^[FIndex] := 1;
      finally Cs.EndWrite; end;
    end;
  finally
    DestroyObjs;
    CoUninitialize;
  end;
end;

procedure TWorker.OpenCds;
begin
  FCds.FetchParams;
  FCds.RemoteServer.AppServer.Login();
  FCds.Params.ParamByName('Code').AsInteger := 0;
  FCds.Params.ParamByName('Code2').AsInteger := 1;
  FCds.DataRequestAndOpen; //this will perform DataRequest and Open.
end;

procedure TForm1.Button2Click(Sender: TObject);
var I, J: Integer;
    P: TMsg;
    IsDone: Boolean;
    Signal: Integer;
begin
  for I:= 0 to Length(Signals)-1 do
  begin
    Cs.BeginRead;

    try
      Signal := Signals[I];
    finally Cs.EndRead; end;

    if Signal > 0 then
      if Signal = 1 then
      begin
        Memo1.Lines.Add('Thread: '+IntToStr(I)+' Finished!');
        Inc(CountDone);
      end
      else
      begin
        P:= TMsg(Signal);

        Cs.BeginRead;
        try
          IsDone := P.Done;
        finally Cs.EndRead; end;

        if IsDone then
        begin
          for J := 0 to Length(P.Strings)-1 do
            Memo1.Lines.Add('Thread: '+IntToStr(I)+' Threw an exception: '+ P.Strings[J]);
          Inc(CountDone);
          P.Free;
        end;
      end;
  end;
  if CountDone = Size then
  begin
    Label8.Caption := 'Finished';
    Button1.Enabled := True;
  end
  else
    Label8.Caption := 'Threads running :'+IntToStr(Size-CountDone);
  Label12.Caption := IntToStr(CountDone);
end;

initialization
  Cs := TCS.Create;

finalization
  Cs.free;

end.

单元1.dfm：

object Form1: TForm1
  Left = 622
  Top = 188
  Width = 374
  Height = 494
  Caption = 'Test Performance'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Label1: TLabel
    Left = 1
    Top = 1
    Width = 31
    Height = 13
    Caption = 'Clients'
  end
  object Label2: TLabel
    Left = 125
    Top = 3
    Width = 39
    Height = 13
    Caption = 'Quantity'
  end
  object Label3: TLabel
    Left = 10
    Top = 120
    Width = 30
    Height = 13
    Caption = 'Result'
  end
  object Label4: TLabel
    Left = 3
    Top = 50
    Width = 38
    Height = 13
    Caption = '1- Insert'
  end
  object Label5: TLabel
    Left = 3
    Top = 65
    Width = 81
    Height = 13
    Caption = '2- Insert e Delete'
  end
  object Label6: TLabel
    Left = 3
    Top = 95
    Width = 110
    Height = 13
    Caption = '4- Insert Update Delete'
  end
  object Label7: TLabel
    Left = 3
    Top = 80
    Width = 79
    Height = 13
    Caption = '3- Insert Update '
  end
  object Label8: TLabel
    Left = 16
    Top = 437
    Width = 103
    Height = 13
    Caption = 'Threads terminated: 0'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clRed
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    ParentFont = False
  end
  object Label9: TLabel
    Left = 264
    Top = 56
    Width = 37
    Height = 13
    Caption = 'Created'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clBlue
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    ParentFont = False
  end
  object Label10: TLabel
    Left = 264
    Top = 72
    Width = 53
    Height = 13
    Caption = 'Terminated'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clGreen
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    ParentFont = False
  end
  object Label11: TLabel
    Left = 320
    Top = 56
    Width = 28
    Height = 13
    AutoSize = False
    Caption = '0'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clBlue
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    ParentFont = False
  end
  object Label12: TLabel
    Left = 320
    Top = 72
    Width = 28
    Height = 13
    AutoSize = False
    Caption = '0'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clGreen
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    ParentFont = False
  end
  object Button1: TButton
    Left = 270
    Top = 14
    Width = 75
    Height = 25
    Caption = 'Run'
    TabOrder = 0
    OnClick = Button1Click
  end
  object edQuantity: TEdit
    Left = 125
    Top = 17
    Width = 121
    Height = 21
    TabOrder = 1
    Text = '10'
  end
  object Memo1: TMemo
    Left = 10
    Top = 136
    Width = 337
    Height = 281
    ScrollBars = ssBoth
    TabOrder = 2
  end
  object edClients: TEdit
    Left = 1
    Top = 18
    Width = 121
    Height = 21
    TabOrder = 3
    Text = '400'
  end
  object Button2: TButton
    Left = 271
    Top = 104
    Width = 75
    Height = 25
    Caption = 'Check Now'
    TabOrder = 4
    OnClick = Button2Click
  end
end
4

1 回答 1

3

单元线程的 ActiveX/COM 对象只能在创建它的同一线程中使用。如果您需要在另一个线程中使用这样的对象，则必须使用 ActiveX/COM 中的任何一个将其编组到该CoMarshalInterThreadInterfaceInStream()线程IGlobalInterfaceTable。创建一个特殊的代理，将方法调用委托给原始线程。由于您使用的是组件包装器，因此这两种选择都不适合您。因此，您唯一的选择是在将要使用它们的线程的方法内创建组件实例Execute()，并且不要忘记先Execute()调用CoInitialize/Ex()，例如：

procedure TMyThread.Execute;
var
  Conn: TDCOMConnection;
  DS: TClientDataSet;
begin
  CoInitialize(nil);
  try
    Conn := TDCOMConnection.Create(nil);
    try
      DS := TClientDataSet.Create(nil);
      try
        ...
      finally
        DS.Free;
      end;
    finally
      Conn.Free;
    end;
  finally
    CoUninitialize;
  end;
end;
于 2013-05-18T01:13:22.473 回答