线程问题(进度条窗体实现) ( 积分: 100 )

  • 主题发起人 主题发起人 yzykjh
  • 开始时间 开始时间
Y

yzykjh

Unregistered / Unconfirmed
GUEST, unregistred user!
我想通过Form1调用进度条窗体，但进度条窗体没有反映，请大家帮忙！
procedure TForm1.Button1Click(Sender: TObject);
var
xc: TRecGuage;
i: integer;
begin
xc:=TRecGuage.Create(0,100);
xc.Resume;
for i:=0 to 100do
begin
xc.Current:=i;
sleep(20);
end;
xc.Terminate;
end;

///////////////////进度条窗体
unit UfrmRecGuage;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, ExtCtrls;
type
TfrmRecGuage = class(TForm)
Panel1: TPanel;
Label2: TLabel;
ProgressBar1: TProgressBar;
Label1: TLabel;
procedure FormClose(Sender: TObject;
var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;

/////////////////////////////线程
TRecGuage = class(TThread)
private
{ Private declarations }
fCurrent: Longword;
fForm: TfrmRecGuage;
procedure Update;
protected
procedure Execute;
override;
public
constructor Create(vMin, vMax: Longword);
virtual;
destructor Destroy;
override;
published
property Current: Longword read fCurrent write fCurrent default 0;
end;

var
frmRecGuage: TfrmRecGuage;
implementation
{$R *.dfm}
procedure TfrmRecGuage.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Action:=caFree;
end;

{ TRecGuage }
constructor TRecGuage.Create(vMin, vMax: Longword);
begin
inherited Create(True);
//挂起线程
fForm:=TfrmRecGuage.Create(Application);
fForm.ProgressBar1.Min:=vMin;
fForm.ProgressBar1.Max:=vMax;
fForm.ProgressBar1.Position:=vMin;
fForm.Show;
FreeOnTerminate:=True;
Resume;
end;

destructor TRecGuage.Destroy;
begin
fForm.Close;
inherited;
end;

procedure TRecGuage.Execute;
var
i: integer;
begin
inherited;
Synchronize(Update);
end;

procedure TRecGuage.Update;
begin
frmRecGuage.ProgressBar1.Position:=Current;
end;

end.
 
我想通过Form1调用进度条窗体，但进度条窗体没有反映，请大家帮忙！
procedure TForm1.Button1Click(Sender: TObject);
var
xc: TRecGuage;
i: integer;
begin
xc:=TRecGuage.Create(0,100);
xc.Resume;
for i:=0 to 100do
begin
xc.Current:=i;
sleep(20);
end;
xc.Terminate;
end;

///////////////////进度条窗体
unit UfrmRecGuage;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, ExtCtrls;
type
TfrmRecGuage = class(TForm)
Panel1: TPanel;
Label2: TLabel;
ProgressBar1: TProgressBar;
Label1: TLabel;
procedure FormClose(Sender: TObject;
var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;

/////////////////////////////线程
TRecGuage = class(TThread)
private
{ Private declarations }
fCurrent: Longword;
fForm: TfrmRecGuage;
procedure Update;
protected
procedure Execute;
override;
public
constructor Create(vMin, vMax: Longword);
virtual;
destructor Destroy;
override;
published
property Current: Longword read fCurrent write fCurrent default 0;
end;

var
frmRecGuage: TfrmRecGuage;
implementation
{$R *.dfm}
procedure TfrmRecGuage.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Action:=caFree;
end;

{ TRecGuage }
constructor TRecGuage.Create(vMin, vMax: Longword);
begin
inherited Create(True);
//挂起线程
fForm:=TfrmRecGuage.Create(Application);
fForm.ProgressBar1.Min:=vMin;
fForm.ProgressBar1.Max:=vMax;
fForm.ProgressBar1.Position:=vMin;
fForm.Show;
FreeOnTerminate:=True;
Resume;
end;

destructor TRecGuage.Destroy;
begin
fForm.Close;
inherited;
end;

procedure TRecGuage.Execute;
var
i: integer;
begin
inherited;
Synchronize(Update);
end;

procedure TRecGuage.Update;
begin
frmRecGuage.ProgressBar1.Position:=Current;
end;

end.
 
记住:Synchronize里过程的代码都在主线程里执行，所以你的多线程相当于
没有作用。
 
这个问题，我的同事有一篇详细的文章作了介绍。
转载一下了，原作者是：Sundy(晶晶)
他的Blog：http://www.blogcn.com/user35/sundytu/index.html
昨天(现在已经开始新的一天啦^_^)要将公司软件中开始的shap界面改为多线程。所以产生下文！
因为我们的系统在开始的时候要从位于互联网上的主机上下载大量的数据并完成初始化，所以这个时候需要一个界面来告诉用户：“现在程序正在努力工作中，请稍候”，不然的话，用户还以为程序失去响应了并强制结束它呢^_^。
由于界面上的工作一般都由主线程完成，但由于软件开始编写的时候都是将下载和初始化的工作放在主线程中的(这也是大多数程序的工作方式)，在主界面Show出来之前程序一直都忙于下载，分析，根本没有时间去更新提示的shap界面，所以会造成界面响应太慢，还是给人感觉好像程序失去响应一样^_^。所以考虑之后，便将这个界面转移到另外一个线程。但查找了很多资料，发现几乎没有人可以利用delphi中的现有窗口资源创建Thread窗体成功的案例(主要是form单元中大量使用了主线程的东西，当时发展VCL的时候没有考虑到界面子线程，因为delphi的界面线程都是放在主线程中，然后工作线程通过Synchronize方法完成与主线程的同步)。没有办法，只有使用最原始的方法了win32，下面是单元的源代码：
unit SundyWindow;
interface
uses
SysUtils, Classes, Windows, Messages, Forms, StdCtrls, ExtCtrls, Controls;
type
TriVertexSundy = record
x: DWORD;
y: DWORD;
Red: WORD;
Green: WORD;
Blue: WORD;
Alpha: WORD;
end;

SundyThread = class(TThread)
private
{ Private declarations }
FTimeOutEvent: TNotifyEvent;
protected
procedure Execute;
override;
proceduredo
Terminate;
override;
public
constructor CreateWithTimeOut(TimeOut: DWORD);
procedure SetText(text: string);
procedure ExitShow;
property OnTimeOut: TNotifyEvent read FTimeOutEvent write FTimeOutEvent;
end;

function SundyProc(hWnd: hWnd;
Msg: UINT;
wParam: wParam;
lParam: lParam): LRESULT;
stdcall;
function GradientFillEx(DC: HDC;
var Vertex: TriVertexSundy;
NumVertex: DWORD;
Mesh: Pointer;
NumMesh, Mode: DWORD): boolean;
stdcall;
external 'msimg32.dll' name 'GradientFill';
implementation
{ SundyThread }
var
FHandle: THandle;
index: integer = 0;
MemDC: HDC;
MemBmp, tmpbmp: HBitMap;
Flag: boolean = false;
FText: string;
TextFlag: boolean = false;
FTimeOut: DWORD = 0;
DrawFlag: boolean = false;
function SundyProc(hWnd: hWnd;
Msg: UINT;
wParam: wParam;
lParam: lParam): LRESULT;
var
DC: HDC;
fRect: TRect;
FontSize: TSize;
vert: array[0..3] of TriVertexSundy;
gTRi: array[0..1] of TGradientRect;
p1: TLogFont;
Font, oldfont: HFont;
tmpObj: SundyThread;
PS:PaintStruct;
procedure innerDraw(DC:HDC);
var RGN,trgn:HRGN;
begin
RGN:=CreateRectRgn(0,0,300,100);
trgn:=SelectObject(DC,RGN);
oldfont := SelectObject(DC, Font);
GetClientRect(FHandle, fRect);
GetTextExtentPoint32(FHandle, PChar('Gj'), 2, FontSize);
bitblt(DC, 0, (fRect.Bottom - fRect.Top) - 24, index, 10, memDC, 300 - index, 0, SRCCOPY);
bitblt(DC, index, (fRect.Bottom - fRect.Top) - 24, 300 - index, 10, memDC, 0, 0, SRCCOPY);
SetBkMode(DC, Transparent);
ExcludeClipRect(DC, 0, 0, 300, (fRect.Bottom - fRect.Top) - 24);
FillRect(DC, Rect(0, (fRect.Bottom - fRect.Top) - 14, 300, fRect.Bottom), HBRUSH(COLOR_BACKGROUND));
textout(DC, 6, (fRect.Bottom - fRect.Top)- 12, pchar(FText), length(FText));
index := (index + 10) mod 300;
Selectobject(DC, oldfont);
SelectObject(DC,trgn);
deleteobject(RGN);
end;
begin
Result:=0;
p1.lfHeight := 12;
p1.lfWidth := 6;
p1.lfEscapement := 0;
p1.lfOrientation := 0;
p1.lfWeight := FW_NORMAL;
p1.lfItalic := 0;
p1.lfUnderline := 0;
p1.lfStrikeOut := 0;
p1.lfCharSet := GB2312_CHARSET;
p1.lfOutPrecision := 0;
p1.lfQuality := 0;
p1.lfPitchAndFamily := 0;
p1.lfFaceName := '宋体' + Char(0);
Font := CreateFontIndirect(p1);
case Msg of
WM_ACTIVATE:
begin
DC := GetDC(0);
memDC := CreateCompatibleDC(DC);
memBmp := CreateCompatibleBitmap(DC, 300, 10);
releaseDC(0, DC);
tmpbmp := SelectObject(memDC, memBmp);
vert[0].x := 0;
vert[0].y := 0;
vert[0].Red := 0;
vert[0].Green := 0;
vert[0].Blue := 0;
vert[0].Alpha := 0;
vert[1].x := 150;
vert[1].y := 10;
vert[1].Red := 0;
vert[1].Green := 0;
vert[1].Blue := ＄FFFF;
vert[1].Alpha := 0;
vert[2].x := 150;
vert[2].y := 0;
vert[2].Red := 0;
vert[2].Green := 0;
vert[2].Blue := ＄FFFF;
vert[2].Alpha := 0;
vert[3].x := 300;
vert[3].y := 10;
vert[3].Red := 0;
vert[3].Green := 0;
vert[3].Blue := 0;
vert[3].Alpha := 0;
gTRi[0].UpperLeft := 0;
gTRi[0].LowerRight := 1;
gTRi[1].UpperLeft := 2;
gTRi[1].LowerRight := 3;
GradientFillEx(memDC, vert[0], 4, @gTRi, 2, GRADIENT_FILL_Rect_H);
SetTimer(FHandle, 1000, 100, nil);
if FTimeOut <> 0 then
SetTimer(FHandle, 1001, FTimeOut, nil);
Result := 0;
end;
WM_NCHITTEST:
Result := HTCLIENT;
WM_Paint:
begin
DC := HDC(WParam);
if DC = 0 then
DC := begin
Paint(FHandle, PS);
try
innerDraw(DC)
finally
if WParam = 0 then
EndPaint(FHandle, PS);
end;

end;
WM_Close:
begin
KillTimer(FHandle, 100);
if FTimeOut <> 0 then
KillTimer(FHandle, 101);
if memBmp <> 0 then
begin
SelectObject(memDC, tmpbmp);
deleteobject(memBmp);
memBmp := 0;
end;
if memDC <> 0 then
begin
DeleteDC(memDC);
memDC := 0;
end;
DestroyWindow(FHandle);
Result := 0;
end;
WM_Timer:
begin
if wParam = 1000 then
begin

invalidateRect(FHandle, nil, false);
result := 0;
end;
if wParam = 1001 then
begin
tmpObj := SundyThread(GetWindowLong(FHandle, GWL_USERDATA));
KillTimer(FHandle, 100);
if FTimeOut <> 0 then
KillTimer(FHandle, 101);
if assigned(tmpObj.FTimeOutEvent) then
begin
tmpObj.FTimeOutEvent(tmpObj);
end;
end;
end;
else
Result := DefWindowProc(hWnd, Msg, wParam, lParam);
end;
DeleteObject(Font);
end;

constructor SundyThread.CreateWithTimeOut(TimeOut: DWORD);
begin
inherited Create(false);
FTimeOut := TimeOut;
end;

procedure SundyThread.DoTerminate;
begin
inheriteddo
Terminate;
Flag := false;
end;

procedure SundyThread.Execute;
var
Msg: tagMsg;
WndClass: tagWNDCLASSA;
begin
WndClass.style := 0;
WndClass.lpfnWndProc := @SundyProc;
WndClass.cbClsExtra := 0;
WndClass.cbWndExtra := 0;
WndClass.hInstance := hInstance;
WndClass.hIcon := 0;
WndClass.hCursor := LoadCursor(hInstance, pchar(IDC_WAIT));
WndClass.hbrBackground := HBRUSH(COLOR_BACKGROUND);
WndClass.lpszMenuName := nil;
WndClass.lpszClassName := pchar('SundyWindow');
Windows.RegisterClass(WndClass);
FHandle := CreateWindowEx(WS_EX_TOOLWINDOW, WndClass.lpszClassName, pchar('请稍候...'),
WS_POPUP or WS_CAPTION or WS_CLIPSIBLINGS,
(GetSystemMetrics(SM_CXSCREEN) - 300) div 2,
(GetSystemMetrics(SM_CYSCREEN) - 100) div 2,
300, 100, 0, 0, hInstance, nil);
SetWindowLong(FHandle, GWL_USERDATA, integer(Self));
ShowWindow(FHandle, sw_normal);
UpdateWindow(FHandle);
while GetMessage(Msg, 0, 0, 0) and not Flagdo
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;

procedure SundyThread.ExitShow;
begin
if FHandle <> 0 then
SendMessage(FHandle, WM_Close, 0, 0);
Flag := true;
end;

procedure SundyThread.SetText(text: string);
begin
FText := ';
FText := Text;
TextFlag := true;
end;

end.

然后在主界面单元这样调用就可以了：
{主线程单元}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, jpeg;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
implementation
uses Sundywindow;
var ss:SundyThread;
{＄R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
if ss=nil then
begin
ss:=SundyThread.Create(false);
ss.FreeOnTerminate:=true;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var i:integer;
begin
Sleep(10000);//故意让主线程睡眠，测试界面子线程的响应！结果当然是Successful◎^◎
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
if assigned(ss) then
begin
ss.ExitShow;
ss:=nil;
end;
end;

end.
就这么个小玩意，花了我3个小时，大多耗费在想利用delphi现有的窗体类来创建，最后发现都是徒劳，delphi啊－－怎么说你呢？？咳！！
 
偶以前在CBuilder里做项目时，也作过类似的问题
其结构和楼主的不大一样，大致结构如下贴出来，仅供参考：
1、创建子线程后，传入一个CallBack函数，此函数在子线程中Sychronize实现。
2、这个函数是frmMain的一个子过程，其实体存在于frmMain中；子线程中仅仅声明为一个私有成员变量。
3、所有进度信息等的更新，均在这个CallBack实体里实现，因采用多线程，进度信息数据使用MultiReadExclusiveWrite来保护。
 
另外，楼主跟踪一下这里：
xc.Resume;
for i:=0 to 100do
begin
xc.Current:=i;
sleep(20);
end;
xc.Terminate;
代码到此处是否顺序执行呢？还是Resume后就跳到Thread循环里？问题应当就出在这里
---------------------------------------------------------
还有
procedure TRecGuage.Execute;
var
i: integer;
begin
inherited;
while not Terminateddo
//此处是否应当有个循环？C++Builder里面没有的话，线程执行一次后就Free了
Synchronize(Update);
end;
 
其实，晶晶已经说TForm里面已经使用的太多主线程里面的东西，所以TForm已经不适合用来做多线程的闪现窗体了。所以它自己用Windows的API自己创建了一个窗体，还做了一个自己的消息循环函数来处理消息。不过他的代码里面用了很多不规范的东西会产生内存泄漏，建议使用者把大部分的资源放到线程里面实现，然后在消息循环过程里面拿来使用。
他把线程的地址放到一个结构里面去
SetWindowLong(FHandle, GWL_USERDATA, integer(Self));
需要的时候在消息循环里面获取该对象
tmpObj := SundyThread(GetWindowLong(FHandle, GWL_USERDATA));
有了这样的处理，消息循环跟线程的沟通就完成了。
 
你结构就错了，应该把进度条放到主线程里，然后执行程序的部分放到子线程
然后由子线程放一个回调函数或者事件来控制主线程里进度条的移动
 
多人接受答案了。
 
您必须登录或注册才可回复。

Similar threads

T
我想辅线程退出时，一起关掉给辅线程使用的窗口；窗口可以关掉，但会报“非法句柄”的错(200分)
回复
5
查看
307
tanxi
T
小
多线程如何和窗体实现互动？？？(100分)
回复
3
查看
359
sogasoga
S
Q
多线程问题，请教。(50分)
回复
4
查看
370
穿越沦陷的爱
穿
T
线程中的execute是何时执行?(30分)
回复
5
查看
441
resun
R
B
IDFTP的多线程扫描问题？（200分相送）(100分)
回复
4
查看
423
bamfk1023
B
后退
顶部