@会网络的老鼠

涂飞平的博客空间

多线程界面窗口的实现 [原]

12 年前 0

昨天(现在已经开始新的一天啦^_^)要将公司软件中开始的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;
procedure DoTerminate; 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 aintStruct;
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 := BeginPaint(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
inherited DoTerminate;
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 Flag do
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啊--怎么说你呢??咳!!

编写评论