TThread与dll检查同步问题

时间：2016-06-12 00:37:57

标签： multithreading delphi

我有这个TThread，我在我的dll中使用更新一些视觉控制它的工作正常但我面临问题当我试图关闭我的dll并再次重新打开它引发了这个异常

  

从不是主线程的线程调用的checksynchronize

我做错了什么？我需要在计时器内调用checksynchronize，因为我会在应用运行时通过线程更新一些vcl。

这是我的主题单元

unit Thread;

interface

uses Messages, Windows, SysUtils, dialogs, Classes, Menus, forms, ComOBJ,
  ShlObj;

{ Thread client }

type
  TThreadCallbackProc = procedure(Sender: TObject; Updatestring : string) of object;

  TAPPTHREAD = class(TThread)
  private
     Fstatus : String;
    FOnCallbackProc: TThreadCallbackProc;
    procedure dosomework;
    procedure DoCallbackProc;
    //
  protected
    procedure Execute; override;

  Public
    constructor Create(CreateSuspended: Boolean; aThreadCallbackProc: TThreadCallbackProc);
    destructor Destroy; override;

  end;

  var
  APPTHREAD : TAPPTHREAD;




implementation


constructor TAPPTHREAD.Create(CreateSuspended: Boolean;
  aThreadCallbackProc: TThreadCallbackProc);
begin
  inherited Create(CreateSuspended);
  FreeOnTerminate := True;
  FOnCallbackProc := aThreadCallbackProc;
end;

destructor TAPPTHREAD.Destroy;
begin
//
end;

procedure TAPPTHREAD.DoCallbackProc;
begin
  if Assigned(FOnCallbackProc) then
    FOnCallbackProc(self, Fstatus);
end;

procedure TAPPTHREAD.Execute;
begin

  while not Terminated do
  begin
    Fstatus := 'Synched';
    if Fstatus <> '' then
      dosomework;
  end;
end;



procedure TAPPTHREAD.dosomework;
begin

if Assigned(FOnCallbackProc) then
begin
Synchronize(DoCallbackProc);
end;

end;

end.

主要表格

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Timer1: TTimer;
    Timer2: TTimer;
    procedure FormShow(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer2Timer(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure callbackproc(Sender: TObject; Updatestring : String);
  end;

var
  Form1: TForm1;

implementation
uses Thread;

{$R *.dfm}

procedure TForm1.callbackproc(Sender: TObject; Updatestring: String);
begin
label1.Caption := updatestring;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := Cafree;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin

try
if Assigned(APPTHREAD) then
AppThread.Terminate;
except end;

try 
Timer2.Enabled := False;
except end;

end;

procedure TForm1.FormShow(Sender: TObject);
begin
Timer1.Enabled := True;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
APPTHREAD := TAPPTHREAD.Create(false, CallbackProc);
Timer2.Enabled := True;
end;

procedure TForm1.Timer2Timer(Sender: TObject);
begin
Checksynchronize;
end;

end.

DFM 

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 242
  ClientWidth = 472
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnClose = FormClose
  OnDestroy = FormDestroy
  OnShow = FormShow
  PixelsPerInch = 96
  TextHeight = 13
  object Label1: TLabel
    Left = 0
    Top = 0
    Width = 472
    Height = 13
    Align = alTop
    Caption = 'Label1'
    ExplicitLeft = 232
    ExplicitTop = 136
    ExplicitWidth = 31
  end
  object Timer1: TTimer
    Enabled = False
    OnTimer = Timer1Timer
    Left = 232
    Top = 128
  end
  object Timer2: TTimer
    Enabled = False
    Interval = 1
    OnTimer = Timer2Timer
    Left = 320
    Top = 168
  end
end

dll代码

library dllapp;

uses
  System.SysUtils,
  Themes,
  Windows,
  Forms,
  dialogs,
  Graphics,
  Vcl.ExtCtrls,
  Unit1 in 'Unit1.pas' {Unit1},
  DThreadsend in 'Thread.pas';




var
  mHandle: THandle;
  DLLHandle: Longint = 0;

function createApp(Width: Integer; Height: Integer; hw: HWnd;
  app: TApplication): boolean; stdcall;
begin

  mHandle := CreateMutex(nil, True, 'APPNAMETLOAD');
  if GetLastError = ERROR_ALREADY_EXISTS then
  begin
    Halt;
  end;

  try
    form1 := Tform1.CreateParented(hw); // **
    form1.Width := Width;
    form1.Height := Height;
    Result := True
  except
    on e: exception do
    begin
      Result := False;
    end;
  end;
end;

procedure closeApp; stdcall;
begin
  ApplicationClosed := True;
  try
    if mHandle <> 0 then
      CloseHandle(mHandle);
  except
  end;
  if Assigned(form1) then
    try
      FreeAndNil(form1);
    except
    end;
  try
    OptimizeRamUsage;
  except
  end;
end;



procedure showapp; stdcall;
begin

  try
    form1.Visible := True;
  except
  end;
  form1.Show;
end;



procedure DLLEntryProc(EntryCode: Integer);
begin
  case EntryCode of
    DLL_PROCESS_DETACH:
      begin
        StyleServices.Free;
      end;
    DLL_PROCESS_ATTACH:
      begin

      end;
    DLL_THREAD_ATTACH:
      begin

      end;
    DLL_THREAD_DETACH:
      begin

      end;
  end;
end;

exports
  closeApp,
  createApp,
  showapp;

begin

  DllProc := @DLLEntryProc;


end.

主机应用程序以及我如何创建Dll

loadapp单位

unit loadapp;

interface
uses windows, forms, System.SysUtils , dialogs;

procedure loadmainapp;

type
  TcreaFunc = function (Width: Integer; Height: Integer; hw:HWnd; app: TApplication): boolean; stdcall;
  TshowFunc = procedure stdcall;
  TCloseAppFunc = procedure stdcall;


  var
  dllHandle : THandle = 0;
  creaFunc : TcreaFunc;
  showFunc : TshowFunc;
  CloseAppFunc: TCloseAppFunc;

implementation
 uses  Mainapp;

procedure loadmainapp;
var
  S: widestring;
  PW: PWideChar;
begin
S := 'dllapp.dll';

  pw:=pwidechar(widestring(s));
  dllHandle := LoadLibrary(pw);
  if dllHandle <> 0 then
  begin
    @creaFunc := GetProcAddress(dllHandle, 'createApp');
    @showFunc := GetProcAddress(dllHandle, 'showapp');
    if Assigned (creaFunc) then
    begin
      creaFunc(mainfrm.panel1.Width, mainfrm.panel1.Height, mainfrm.panel1.Handle, Application);
      DisFunc;
    end
    else
      ShowMessage('ERROR');

  end
  else
  begin
    ShowMessage('ERROR');
  end;
end;

end.

活动表格

unit activeform;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ActiveX, AxCtrls, Frmldr_TLB, StdVcl, Vcl.ExtCtrls, ShlObj, Vcl.StdCtrls, SHDocVw, MSHTML;

type
  TActiveFrmldr = class(TActiveForm, IActiveFrmldr)
    mpanl: TPanel;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }

  protected
    { Protected declarations }

  public
    { Public declarations }
  end;







implementation

uses ComObj, ComServ, Mainapp, libacload;

{$R *.DFM}

{ TActiveFrmldr }


procedure TActiveFrmldr.FormDestroy(Sender: TObject);
begin
if dllHandle <> 0 then
begin
@CloseAppFunc := GetProcAddress(dllHandle, 'closeApp');
CloseAppFunc;
FreeLibrary(dllHandle);  //release dll
end;


if Assigned(mainfrm) then
try
FreeAndNil(mainfrm);
except
end;

end;

procedure TActiveFrmldr.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
mainfrm.Parent := mpanl;
mainfrm.Left := 0;
mainfrm.Top  := 0;
mainfrm.Width := self.Width;
mainfrm.Height := self.Height;
mainfrm.Align := alClient;
mainfrm.Show;
end;


procedure TActiveFrmldr.FormCreate(Sender: TObject);
begin
Application.CreateForm(Tmainfrm, mainfrm);
Timer1.Enabled := True;
end;

initialization
  TActiveFormFactory.Create(
    ComServer,
    TActiveFormControl,
    TActiveFrmldr,
    Class_ActiveFrmldr,
    0,
    '',
    OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
    tmApartment);

finalization

end.

主要应用程序调用加载库函数的表单

unit Mainapp;

interface

uses
  Windows, Messages, System.SysUtils, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, System.Classes, libacload,
  Vcl.Controls, Vcl.StdCtrls;

type
  Tmainfrm = class(TForm)
    Panel1: TPanel;
    Timer1: TTimer;
    Timer2: TTimer;
    procedure FormShow(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Timer2Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }

  end;


var
  mainfrm: Tmainfrm;

implementation
Uses loadapp;

{$R *.dfm}



procedure Tmainfrm.FormShow(Sender: TObject);
begin
Timer1.Enabled := True;
end;

procedure Tmainfrm.Timer1Timer(Sender: TObject);
begin

Timer1.Enabled := False;

loadmainapp;

end;

procedure Tmainfrm.Timer2Timer(Sender: TObject);
begin 
checksynchronize; // i do this to check some thread in activex it self 
end;

end.

1 个答案:

答案 0 :(得分：5)

错误意味着在ThreadID与RTL的全局CheckSynchronize()变量不匹配的线程中调用System.MainThreadID。

DLL没有自己的主线程。 MainThreadID初始化为初始化DLL的任何线程。因此，如果您的DLL在与初始化DLL的线程不同的线程中创建其GUI，CheckSynchronize()（以及TThread.Synchronize()和TThread.Queue()）将无效，除非您手动更新MainThreadID变量到运行GUI的ThreadID。在创建工作线程之前执行此操作，例如：

if IsLibrary then
  MainThreadID := GetCurrentThreadID;
Form1 := TForm1.Create(nil);

或者：

procedure TForm1.FormCreate(Sender: TObject);
begin
  if IsLibrary then
    MainThreadID := GetCurrentThreadID;
end;

或者：

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Timer1.Enabled := False;
  if IsLibrary then
    MainThreadID := GetCurrentThreadID;
  APPTHREAD := TAPPTHREAD.Create(false, CallbackProc);
  Timer2.Enabled := True;
end;
相关问题
最新问题