QueueUserWorkItem 函数 delphi 转lazarus 有错

mlkj

QueueUserWorkItem 函数 Windows 说明如下：

一、异步调用函数:
BOOL QueueUserWorkItem(
PTHREAD_START_ROUTINE pfnCallback,
PVOID pvContext，
ULONG dwFlags);
该函数将“工作项目”放入线程池并且立即返回。工作项目是指一个用pfnCallback参数标识的函数。它被调用并且传递单个参数pvContext.工作项目函数原型如下：
DWORD WINAPI WorkItemFunc(PVOID pvContext);
dwFlags参数：WT_EXECUTEDEFAULT  工作项目放入非I/O组件得线程中
             WT_EXECUTEINIOTHREAD 工作项目放入I/O组件的线程中，这样的线程在I/O请求没有完成之前不会被终止运行                                  ，防止因为线程被终止导致I/O请求丢失。
             WT_EXECUTEINPERSISTENTTHREAD 放入永久线程池，
             WT_EXECUTELONGFUNCTION  工作项目需要长时间的工作，系统会据此安排更多的线程。
线程池不能设置线程个数的上限，否则排队个数超过线程个数上限的时候，会导致所有的线程都被中断。
工作项目函数如果访问了已经被卸载的DLL,会产生违规访问。

delphi 官网给出的调用例子：
unit ThreadPoolUnit;

interface

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

type  TForm3 =class(TForm)
    PaintBox1: TPaintBox;
    Button1: TButton;
    ListBox1: TListBox;
    procedureButton1Click(Sender: TObject);
  private
    type      TWorkerColor =class
        FThreadID: Integer;
        FColor: TColor;
        FForm: TForm3;
        procedurePaintLines(Sender: TObject);
        procedurePaintLine;
        constructor Create(AForm: TForm3; AColor: TColor);
      end;
    var      FIndex: Integer;
  public
    {Public declarations }  end;

  TObjectHelper =class helper forTObject

  end;

  TThreadPool =class
  private
    type      TUserWorkItem =class
        FSender: TObject;
        FWorkerEvent: TNotifyEvent;
      end;
    class procedureQueueWorkItem(Sender: TObject; WorkerEvent: TNotifyEvent; Flags: ULONG); overload; static;
  public
    class procedureQueueWorkItem(Sender: TObject; WorkerEvent: TNotifyEvent); overload; static;
    class procedureQueueIOWorkItem(Sender: TObject; WorkerEvent: TNotifyEvent); static;
    class procedureQueueUIWorkItem(Sender: TObject; WorkerEvent: TNotifyEvent); static;
  end;

var  Form3: TForm3;
  ThreadPool: TThreadPool;

implementation

{$R *.dfm}const  WT_EXECUTEDEFAULT       =ULONG($00000000);
  WT_EXECUTEINIOTHREAD    =ULONG($00000001);
  WT_EXECUTEINUITHREAD    =ULONG($00000002);
  WT_EXECUTEINWAITTHREAD  =ULONG($00000004);
  WT_EXECUTEONLYONCE      =ULONG($00000008);
  WT_EXECUTEINTIMERTHREAD =ULONG($00000020);
  WT_EXECUTELONGFUNCTION  =ULONG($00000010);
  WT_EXECUTEINPERSISTENTIOTHREAD  =ULONG($00000040);
  WT_EXECUTEINPERSISTENTTHREAD =ULONG($00000080);
  WT_TRANSFER_IMPERSONATION =ULONG($00000100);

functionQueueUserWorkItem (func: TThreadStartRoutine; Context: Pointer; Flags: ULONG): BOOL; stdcall; external kernel32 name 'QueueUserWorkItem';

functionInternalThreadFunction(lpThreadParameter: Pointer): Integer; stdcall;
begin  Result :=0;
  try
    try
      withTThreadPool.TUserWorkItem(lpThreadParameter) do        ifAssigned(FWorkerEvent) then          FWorkerEvent(FSender);
    finally
      TThreadPool.TUserWorkItem(lpThreadParameter).Free;
    end;
  except

  end;
end;

{TThreadPool }class procedureTThreadPool.QueueWorkItem(Sender: TObject; WorkerEvent: TNotifyEvent);
begin  QueueWorkItem(Sender, WorkerEvent, WT_EXECUTEDEFAULT);
end;

class procedureTThreadPool.QueueIOWorkItem(Sender: TObject; WorkerEvent: TNotifyEvent);
begin  QueueWorkItem(Sender, WorkerEvent, WT_EXECUTEINIOTHREAD);
end;

class procedureTThreadPool.QueueUIWorkItem(Sender: TObject; WorkerEvent: TNotifyEvent);
begin  QueueWorkItem(Sender, WorkerEvent, WT_EXECUTEINUITHREAD);
end;

class procedureTThreadPool.QueueWorkItem(Sender: TObject; WorkerEvent: TNotifyEvent; Flags: ULONG);
var  WorkItem: TUserWorkItem;
begin  ifAssigned(WorkerEvent) then  begin    IsMultiThread :=True;
    WorkItem :=TUserWorkItem.Create;
    try
      WorkItem.FWorkerEvent :=WorkerEvent;
      WorkItem.FSender :=Sender;
      ifnotQueueUserWorkItem(InternalThreadFunction, WorkItem, Flags) then        RaiseLastOSError;
    except
      WorkItem.Free;
      raise;
    end;
end;
end;

procedureTForm3.Button1Click(Sender: TObject);
begin  FIndex :=PaintBox1.Height;
  PaintBox1.Repaint;
  ListBox1.Items.Clear;
  TWorkerColor.Create(Self, clBlue);
  TWorkerColor.Create(Self, clRed);
  TWorkerColor.Create(Self, clYellow);
  TWorkerColor.Create(Self, clLime);
  TWorkerColor.Create(Self, clFuchsia);
  TWorkerColor.Create(Self, clTeal);
end;

{TForm3.TWorkerColor }constructor TForm3.TWorkerColor.Create(AForm: TForm3; AColor: TColor);
begin  FForm :=AForm;
  FColor :=AColor;
  TThreadPool.QueueWorkItem(Self, PaintLines);
end;

procedureTForm3.TWorkerColor.PaintLines(Sender: TObject);
var  I: Integer;
begin  FThreadID :=GetCurrentThreadID;
  forI :=0to9do  begin    PaintLine;
    //TThread.Synchronize(nil, PaintLine);
    Sleep(100);
  end;
  Destroy;
end;

procedureTForm3.TWorkerColor.PaintLine;
begin  FForm.PaintBox1.Canvas.Lock;
  try
    FForm.ListBox1.Items.Add(IntToStr(FThreadID));
    withFForm.PaintBox1 do    begin      Canvas.Pen.Color :=FColor;
      Canvas.Polyline([Point(0, FForm.FIndex), Point(Width, FForm.FIndex)]);
      Dec(FForm.FIndex);
      ifFForm.FIndex <=0then        FForm.FIndex :=0;
    end;
  finally
    FForm.PaintBox1.Canvas.Unlock;
  end;
end;

end.

该例子不能在lazarus上编译，请大家帮肋改改

mlkj

改成Lazarus后可以编译，但运行出错

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Windows,Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  ExtCtrls;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    ListBox1: TListBox;
    PaintBox1: TPaintBox;
    procedure Button1Click(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end;


  TThreadStartRoutine = function(lpThreadParameter: Pointer): Integer stdcall;

  TWorkerColor = class
        FThreadID: Integer;
        FColor: TColor;
        FForm: TForm1;
        FIndex: Integer;
        procedure PaintLines(Sender: TObject);
        procedure PaintLine;
        constructor Create(AForm: TForm1; AColor: TColor);
      end;


  TThreadPool = class
  private
     FSender: TObject;
     FWorkerEvent: TNotifyEvent;
     class procedure QueueWorkItem(Sender: TObject; WorkerEvent: TNotifyEvent; Flags: ULONG); overload;
  end;


var
  Form1: TForm1;
  ThreadPool: TThreadPool;

implementation

{$R *.lfm}

const
  WT_EXECUTEDEFAULT       = ULONG($00000000);
  WT_EXECUTEINIOTHREAD    = ULONG($00000001);
  WT_EXECUTEINUITHREAD    = ULONG($00000002);
  WT_EXECUTEINWAITTHREAD  = ULONG($00000004);
  WT_EXECUTEONLYONCE      = ULONG($00000008);
  WT_EXECUTEINTIMERTHREAD = ULONG($00000020);
  WT_EXECUTELONGFUNCTION  = ULONG($00000010);
  WT_EXECUTEINPERSISTENTIOTHREAD  = ULONG($00000040);
  WT_EXECUTEINPERSISTENTTHREAD = ULONG($00000080);
  WT_TRANSFER_IMPERSONATION = ULONG($00000100);

function QueueUserWorkItem (func: TThreadStartRoutine; Context: Pointer; Flags: ULONG): BOOL; stdcall; external kernel32 name 'QueueUserWorkItem';


function InternalThreadFunction(lpThreadParameter: Pointer): Integer; stdcall;
begin
  Result := 0;
  try
    try
      with TThreadPool(lpThreadParameter) do
        if Assigned(FWorkerEvent) then
          FWorkerEvent(FSender);
    finally
      TThreadPool(lpThreadParameter).Free;
    end;
  except

  end;
end;

{ TThreadPool }


class procedure TThreadPool.QueueWorkItem(Sender: TObject; WorkerEvent: TNotifyEvent; Flags: ULONG);
var
  WorkItem: TThreadPool;
begin
  if Assigned(WorkerEvent) then
  begin
    IsMultiThread := True;
    WorkItem := TThreadPool.Create;
    try
      WorkItem.FWorkerEvent := WorkerEvent;
      WorkItem.FSender := Sender;
      if not QueueUserWorkItem(@InternalThreadFunction, WorkItem, Flags) then
        RaiseLastOSError;
    except
      WorkItem.Free;
      raise;
    end;
end;
end;


{ TForm1 }

procedure TForm1.Button1Click(Sender: TObject);
begin
// FIndex := PaintBox1.Height;
  PaintBox1.Repaint;
  ListBox1.Items.Clear;

  TWorkerColor.Create(Self, clBlue);
  TWorkerColor.Create(Self, clRed);
  TWorkerColor.Create(Self, clYellow);
  TWorkerColor.Create(Self, clLime);
  TWorkerColor.Create(Self, clFuchsia);
  TWorkerColor.Create(Self, clTeal);

end;


constructor TWorkerColor.Create(AForm: TForm1; AColor: TColor);
var
  WEvent: TNotifyEvent ;
begin
  FForm := AForm;
  FColor := AColor;
  WEvent:= @PaintLines ;
  TThreadPool.QueueWorkItem(Self,WEvent ,WT_EXECUTEINIOTHREAD);
end;

procedure TWorkerColor.PaintLines(Sender: TObject);
var
  I: Integer;
begin
  FThreadID := GetCurrentThreadID;
  for I := 0 to 9 do
  begin
    PaintLine;
    //TThread.Synchronize(nil, PaintLine);
    Sleep(100);
  end;
  Destroy;
end;

procedure TWorkerColor.PaintLine;
begin
  FForm.PaintBox1.Canvas.Lock;
  try
    FForm.ListBox1.Items.Add(IntToStr(FThreadID));
    with FForm.PaintBox1 do
    begin
      Canvas.Pen.Color := FColor;
      Canvas.Polyline([Point(0, FIndex), Point(Width, FIndex)]);
      Dec(FIndex);
      if FIndex <= 0 then
        FIndex := 0;
    end;
  finally
    FForm.PaintBox1.Canvas.Unlock;
  end;
end;

jixian

最好把整个程序文件压缩上传到这里。