books/multithread
1
0
Fork 0
mirror of https://github.com/loginov-dmitry/multithread.git synced 2024-11-24 16:53:48 +02:00
Code Issues Releases Activity
ab80b7e79d
multithread/CommonUtils/ProgressViewer.pas

1231 lines
38 KiB
ObjectPascal
Raw Blame History

{ *************************************************************************** }
{ }
{ }
{ }
{ Модуль ProgressViewer - модуль визуализации длительных операций }
{ (c) 2005 - 2008 Логинов Дмитрий Сергеевич }
{ Последнее обновление: 27.01.2008 }
{ Адрес сайта: http://matrix.kladovka.net.ru/ }
{ e-mail: loginov_d@inbox.ru }
{ }
{ Свои предложения по доработке модуля высылайте на указанный электронный }
{ ящик, либо пишите в гостевой книге сайта. Любые изменения в модуле должны }
{ быть согласованы с его автором. }
{ }
{ *************************************************************************** }
unit ProgressViewer;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, SyncObjs;
{
Класс-поток TProgressViewer выполняет визуализацию хода выполнения длительного
процесса, запущенного в другом (в частности в основном) потоке.
В начале процедуры Execute на API создается новое окошко, в котором собственно
и выполняется необходимая отрисовка (используется буфер TBitmap).
Для завершения работы процесса следует использовать метод Terminate.
Примеры использования
1) При визуализации хода процесса неопределенной длительности:
with TProgressViewer.Create('Визуализация без процентов', False) do
try
Sleep(10000); // Здесь выполняется длительная операция
finally
Terminate;
end;
2) При визуализации хода процесса с индикацией процента выполнения:
with TProgressViewer.Create('Визуализация с процентами', True) do
try
for I := 1 to 1000 do
begin
CurrentValue := I / 10;
if CancelByUser then Break;
//CheckCancelByUser;
Sleep(1); // Задержка, чтобы окно не исчезло сразу же
end;
finally
Terminate;
end;
}
{
16.12.2007
- исправлена ошибка, связанная с крахом отрисовки всей графики
приложения, если во время визуализации окна програсса происходит обновление
любой VCL-формы. Пришлось добавить методы LockCanvas и UnlockCanvas,
которые соответственно блокируют и разблокируют канву для всех используемых
в дополнительном потоке объектов TBitmap. Блокировку канвы в дополнительном
потоке необходимо делать при изменении любых ее свойств. Теперь утечки
GDI-ресурсов не возникает.
- добавлена кнопка "Отмена" и обработка клавиши "Escape". См. метод CancelByUser
- внедрен механизм вывода любой текстовой информации в окно прогресса. Для
этого следует использовать функцию AddStringInfo(). Для нее указываются номер строки,
определяющий порядок вывода текстовых сообщений, текст сообщение, а также
дополнительные аргументы, с помощью которых можно изменить любые свойства
шрифта. По умолчанию сообщение с номером -1 определяет название огранизации,
а сообщение с номером 0 - имя текущей операции.
17.12.2007
- добавлен метод SetWndWidth, позволяющий изменить размер окна визуализации.
Работает в асинхронном режиме, т.е. не посылает сообщение на изменение размеров,
а уведомляет основной цикл потока о том, что при очередной итерации
требуется изменить размер окна.
25.12.2007
- добавлена функция RegisterProgressWndClass, выполняющая регистрацию класса
окна при старте программы.
- исправлен метод SetCancelBtnVisible. Теперь в нем нет вызовов SendMessage,
а просто-напросто устанавливается флаг FNewBtnVisible, который учитывается в
функции CheckWidthAndVisible. В какой бы момент пользователь не изменил видимость
кнопки, программа обязательно на это в свое время отреагирует.
- теперь для отрисовки изображения вместо WM_PAINT посылается пользовательское
сообщение WM_DOPAINT. Разницы нет никакой, зато это меньше будет путать программистов.
- создание и удаление объектов TBitmap перенесено туда, где и положено -
в конструктор и деструктор.
26.12.2007
- добавлен метод ChangeStringInfo(), позволяющий изменить произвольный
параметр текстовой строки.
27.12.2007
- добавлены переменные ProgressWaitLabel1 и ProgressWaitLabel2, определяющие
текстовые сообщение, которые всегда выводятся над строкой прогресса. Теперь
эти строки можно отключить либо изменить любые их атрибуты. Их индексы:
1001 и 1002 соответственно.
- теперь в целях локализации можно поменять любой текст.
- сообщения об ошибках перенесены в секцию RESOURCESTRING
- добавлен перегруженный метод AddStringInfo(), в который вместо списка
параметров передается запись TStringInfo.
27.01.2008
- добавлены возможность задания значений по умолчанию для шрифта (цвет, размер,
имя, стиль) (со шрифтом есть проблема неоднозначности, решаемая с помощью
директивы CanUseDefaultFontStyle.).
- исправлена ошибка, связанная с неправильной прорисовкой текста. Границы
прямоугольника сужалить с краев на 10 пикселей 2 раза вместо одного. В результате
текст мог обрезаться (даже при переносе строк).
- добавлен свой класс исключения - EProgressException
- добавлен метод CheckCancelByUser, генерирующий исключение EProgressCancelByUser
в случае отмены операции пользователем. В ходе выполнения длительной операции
достаточно периодически вызывать данный метод и он прервет при необходимости
операцию благодаря генерации исключения.
}
{ Разрешает генерацию исключения в наиболее опасных местах кода. По-умолчанию
выключено. Включать не рекомендую, но если очень хочется, то я не против}
{.$DEFINE CanRaiseException}
{ Разрешает использовать стиль шрифта по умолчанию. Если при вызове функции
AddStringInfo() аргумент AFontStyle не указывается, или равен
[fsBold, fsItalic, fsUnderline, fsStrikeOut], то берется значение по умолчанию,
т.е. FDefaultFontStyle или GlobalDefaultFontStyle. В случае же, если данная
опция отключена, то значение, что указывается при вызове функции
AddStringInfo(), будет использоваться }
{$DEFINE CanUseDefaultFontStyle}
const
{$IFDEF CanUseDefaultFontStyle}
FontStyleNone = [fsBold, fsItalic, fsUnderline, fsStrikeOut];
{$ELSE}
FontStyleNone = [];
{$ENDIF}
type
TProgressViewer = class;
TAdditionalThread = class;
EProgressException = class(Exception);
EProgressCancelByUser = class(EProgressException);
TProgressMethod = procedure(AThread: TProgressViewer) of Object;
TStringInfo = record
sLineNumber: Integer; // Номер строки
sText: string; // Текст строки
sAlignment: TAlignment; // Выравнивание
sLineBreak: Boolean; // Перенос строк
sFontName: TFontName; // Имя шрифта
sFontSize: Integer; // Размер шрифта
sFontStyle: TFontStyles; // Стиль шрифта
sFontColor: TColor; // Цвет шрифта
sLineHeight: Integer; // Высота строки. Временное поле
end;
TStringInfoParams = (sipText, sipAlignment, sipLineBreak, sipFontName,
sipFontSize, sipFontStyles, sipFontColor);
TProgressViewer = class(TThread)
private
FCurrentValue: Double;
FShowAsPercentBar: Boolean;
FFormLeftTop: TPoint;
FBitmap: TBitmap;
FFonBitmap: TBitmap;
FTextBitmap: TBitmap;
FBMPLine: TBitmap;
FhWindow: HWND;
FhButton: HWND;
FForegroundWindow: HWND;
FStartTime: TDateTime;
FAdditionalThread: TAdditionalThread;
FStringInfoCS: TCriticalSection;
FDataCS: TCriticalSection;
FStringInfo: array of TStringInfo;
FBufferIsReady: Boolean;
FWndWidth: Integer;
FWndHeight: Integer;
FNewWidth: Integer; // Новое значение ширины экрана
FNewBtnVisible: Boolean;
FCancelByUser: Boolean;
FCancelBtnVisible: Boolean;
FBGColor: TColor;
FText: string;
FOnCancelByUser: TNotifyEvent;
FDefaultFontColor: TColor;
FDefaultFontSize: Integer;
FDefaultFontStyle: TFontStyles;
FDefaultFontName: string;
procedure DrawProgress;
{ Создает API-шкое окошко с кнопочкой }
procedure CreateNewWnd;
{ Возвращает индекс элемента в массиве FStringInfo по sLineNumber }
function GetLineNumberIndex(LineNumber: Integer): Integer;
procedure SetText(const Value: string);
{ Блокирует канву всех используемых объектов TBitmap }
procedure LockCanvas;
{ Снимает блокировку канвы всех используемых объектов TBitmap }
procedure UnLockCanvas;
{ Регистрирует созданное окно и поток в списке }
procedure RegisterWnd;
{ Удаляет информацию о потоке и окне из списка регистрации }
procedure UnRegisterWnd;
procedure SetCancelBtnVisible(const Value: Boolean);
{ Устанавливает новые размеры окна визуализации. }
procedure SetWndSize(NewWidth: Integer; NewHeight: Integer = -1);
{ Выполняет сортировку массива FStringInfo }
procedure SortStringInfoArray;
procedure SetOnCancelByUser(const Value: TNotifyEvent);
procedure DoCancelByUser;
public
{ Создает объект визуализации.
- AText - имя выполняемой операции
- ShowAsPercentBar - режим отрисовки строки прогресса
- CancelBtnVisible - определяет, следует ли отображать кнопку "Отмена"
- ProgressMethod - позволяет выполнить обработку данных в доп. потоке }
constructor Create(AText: string; ShowAsPercentBar: Boolean = False;
CancelBtnVisible: Boolean = False; ProgressMethod: TProgressMethod = nil);
{ Удаляет объекты, созданные в конструкторе. Не вызывайте метод Free или
Destroy напрямую. Гораздо быстрее вызвать метод Terminate и не дожидаться,
когда объект уничтожится полностью. }
destructor Destroy; override;
{ Завершает прогресс и ожидает, пока не уничтожится окно визуализации.
После этого возвращает ActiveWindow }
procedure TerminateProgress;
{ Текущее значение прогресса. Если в конструкторе ShowAsPercentBar=True,
то строка прогресса отображает текущее значение. В противном случае
в ней слева-направо непрерывно перемещается прямоугольник }
property CurrentValue: Double read FCurrentValue write FCurrentValue;
{ Основной текст окна визуализации. Т.е. операция, которая выполняется
в данный момент }
property Text: string read FText write SetText;
{ Задает цвет шрифта по умолчанию }
property DefaultFontColor: TColor read FDefaultFontColor write FDefaultFontColor;
{ Размер шрифта по умолчанию }
property DefaultFontSize: Integer read FDefaultFontSize write FDefaultFontSize;
{ Стиль шрифта по умолчанию }
property DefaultFontStyle: TFontStyles read FDefaultFontStyle write FDefaultFontStyle;
{ Имя шрифта по умолчанию }
property DefaultFontName: string read FDefaultFontName write FDefaultFontName;
{ Добавляет текстовую строку с указанным номером. Строки с номерами
0 и -1 зарезервированы и добавляются автоматически при создании объекта }
procedure AddStringInfo(LineNumber: Integer; AText: string;
TextAlignment: TAlignment = taRightJustify; ALineBreak: Boolean = False;
AFontColor: TColor = clDefault; AFontStyle: TFontStyles = FontStyleNone;
AFontSize: Integer = -1; AFontName: string = ''); overload;
procedure AddStringInfo(LineNumber: Integer; StringInfo: TStringInfo); overload;
{ Позволяет получить информацию о строке с заданным номером }
function GetStringInfo(LineNumber: Integer): TStringInfo;
{ Позволяет изменить произвольный параметр указанной текстовой строки.
Массив параметров и массив значений должны заполняться синхронно.
Для передачи стиля шрифта необходимо его сперва преобразовать в байт с
помощью функции FontStylesToInt(). Если нет строки с указанным номером,
то будет сгенерировано исключение. }
procedure ChangeStringInfo(LineNumber: Integer;
StringParams: array of TStringInfoParams; Values: array of Variant);
{ Удаляет из FStringInfo элемент с номером LineNumber }
procedure DeleteStringInfo(LineNumber: Integer);
{ При нажатии на кнопку "Отмена" или клавишу "Escape" эта переменная
устанавливается в True. Цикл обработки периодически проверяет
данный флаг, и если он = True, по цикл прерывается и вызывается Terminate}
property CancelByUser: Boolean read FCancelByUser write FCancelByUser;
{ Генерирует исключение "Прервано пользователем", если выставлен флаг FCancelByUser }
procedure CheckCancelByUser;
{ Включает или выключает видимость кнопки "Отмена". Обработка клавиши
"Escape" работает в любом случае, даже если кнопка "Отмена" невидима}
property CancelBtnVisible: Boolean read FCancelBtnVisible write SetCancelBtnVisible;
{ Цвет фона окна прогресса }
property BGColor: TColor read FBGColor write FBGColor;
{ Позволяет изменить размер окна визуализации. Работает в асинхронном режиме,
т.е. не посылает сообщение на изменение размеров, а уведомляет основной
цикл потока о том, что при очередной итерации требуется изменить размер окна }
procedure SetWndWidth(NewWidth: Integer);
{ Данный обработчик вызывается при нажатии пользователем кнопки "Отмена" или "Esc".
Помните, что данный метод вызывается из дополнительного потока!}
property OnCancelByUser: TNotifyEvent read FOnCancelByUser write SetOnCancelByUser;
protected
procedure Execute; override;
end;
TAdditionalThread = class(TThread)
private
FOwnerThread: TProgressViewer;
FProgressMethod: TProgressMethod;
protected
procedure Execute; override;
end;
{ Конвертирует стиль шрифта в Integer для возможности использования в
функции ChangeStringParams }
function FontStylesToInt(AFontStyles: TFontStyles): Integer;
var
SProductName: string = 'Ваше приложение';
DrawPercentLabel: Boolean = True;
SleepTime: Integer = 50;
DrawTimeLabel: Boolean = True;
ProgressColor: TColor = clAqua;
CancelButtonText: string = 'Отмена (Esc)';
CancelByUserMessage: string = 'Прервано пользователем!';
ProgressWaitLabel1: string = 'Выполняется длительная операция. Она может';
ProgressWaitLabel2: string = 'продлиться несколько минут. Пожалуйста, подождите!';
ProgressCommonTime: string = 'Общее время: %s';
GlobalDefaultFontName: string = 'MS Sans Serif'; // Имя шрифта по умолчанию
GlobalDefaultFontColor: TColor = clBlack; // Цвет шрифта по умолчанию
GlobalDefaultFontSize: Integer = 8; // Размер шрифта по умолчанию
GlobalDefaultFontStyle: TFontStyles = []; // Стиль шрифта по умолчанию
const
{ Индекс строки, по которому записывается свойство Text }
TEXT_INDEX = 0;
WAIT_TEXT_INDEX = 1000;
implementation
const
ProgressWindowClassName = 'ProgressViewerFormClass';
DefWndWidth = 450;
DefWndHeight = 70; // Минимальная высота окна (без единой текстовой строки)
DefBGColor = clBtnFace;
WM_DOPAINT = WM_USER + 1;
resourcestring
ErrorRegWndMsg = 'Класс окна визуализации "' + ProgressWindowClassName + '" не зарегистрирован!';
ErrorStringNotFound = 'Строка с номером %d не найдена!';
ErrorWrongDimension = 'Количество параметров и соответствующих им значений не совпадают!';
var
{ Синхронные списки, позволяющие по Handle окна определить породивший
его объект TProgressViewer }
WndHandleList: TThreadList;
ThreadsList: TList;
ClearStringInfo: TStringInfo; // Запись с нулевыми полями
WndClassIsReg: Boolean;
function FontStylesToInt(AFontStyles: TFontStyles): Integer;
begin
Result := Byte(AFontStyles);
end;
{ Для указанного окна отыскивает породивший его поток }
function FindProgressViewerForWindow(AWndHandle: HWND): TProgressViewer;
var
Index: Integer;
begin
Result := nil;
with WndHandleList.LockList do
try
Index := IndexOf(Pointer(AWndHandle));
if Index >= 0 then
Result := ThreadsList[Index];
finally
WndHandleList.UnlockList;
end;
end;
function MainWndProc(hWindow: HWND; Msg: UINT; wParam: wParam;
lParam: lParam): LRESULT; stdcall;
var
ps: TPaintStruct;
pw: TProgressViewer;
begin
Result := 0;
pw := nil;
if (Msg = WM_DOPAINT) or (Msg = WM_COMMAND) or (Msg = WM_KEYDOWN) then
pw := FindProgressViewerForWindow(hWindow);
case Msg of
WM_DOPAINT:
// В параметре wParam должна находиться ссылка на объект TBitmap,
// в котором уже хранится подготовленное изображение
if wParam <> 0 then
begin
BeginPaint(hWindow, ps);
with TCanvas.Create do
try
Lock;
Handle := GetDC(hWindow);
Draw(0, 0, TProgressViewer(wParam).FBitmap); // Ошибка может возникнуть только здесь (хотя вряд-ли)
finally
ReleaseDC(hWindow, Handle);
UnLock;
Free;
EndPaint(hWindow, ps);
end;
end else
Result := DefWindowProc(hWindow, Msg, wParam, lParam);
WM_COMMAND:
if lParam <> 0 then
if pw <> nil then
pw.DoCancelByUser;
WM_KEYDOWN:
if wParam = VK_ESCAPE then
if pw <> nil then
pw.DoCancelByUser;
WM_DESTROY: PostQuitMessage(0);
WM_CLOSE:; // Запрещаем закрытие окна визуализации на Alt+F4
else
Result := DefWindowProc(hWindow, Msg, wParam, lParam);
end;
end;
{ TProgressViewer }
procedure TProgressViewer.AddStringInfo(LineNumber: Integer; AText: string;
TextAlignment: TAlignment = taRightJustify; ALineBreak: Boolean = False;
AFontColor: TColor = clDefault; AFontStyle: TFontStyles = FontStyleNone;
AFontSize: Integer = -1; AFontName: string = '');
var
Index: Integer;
begin
FStringInfoCS.Enter;
try
Index := GetLineNumberIndex(LineNumber);
if Index < 0 then
begin
Index := Length(FStringInfo);
SetLength(FStringInfo, Index + 1);
end;
if AFontColor = clDefault then
if FDefaultFontColor = clDefault then
AFontColor := GlobalDefaultFontColor
else
AFontColor := FDefaultFontColor;
if AFontSize = -1 then
if FDefaultFontSize = -1 then
AFontSize := GlobalDefaultFontSize
else
AFontSize := FDefaultFontSize;
{$IFDEF CanUseDefaultFontStyle}
if AFontStyle = FontStyleNone then
if FDefaultFontStyle = FontStyleNone then
AFontStyle := GlobalDefaultFontStyle
else
AFontStyle := FDefaultFontStyle;
{$ENDIF}
if AFontName = '' then
if FDefaultFontName = '' then
AFontName := GlobalDefaultFontName
else
AFontName := FDefaultFontName;
with FStringInfo[Index] do
begin
sLineNumber := LineNumber;
sText := AText;
sAlignment := TextAlignment;
sLineBreak := ALineBreak;
sFontName := AFontName;
sFontSize := AFontSize;
sFontStyle := AFontStyle;
sFontColor := AFontColor;
end;
// Осуществляем сортировку массива
SortStringInfoArray;
FBufferIsReady := False;
finally
FStringInfoCS.Leave;
end;
end;
procedure TProgressViewer.AddStringInfo(LineNumber: Integer;
StringInfo: TStringInfo);
begin
AddStringInfo(LineNumber, StringInfo.sText, StringInfo.sAlignment,
StringInfo.sLineBreak, StringInfo.sFontColor, StringInfo.sFontStyle,
StringInfo.sFontSize, StringInfo.sFontName);
end;
procedure TProgressViewer.ChangeStringInfo(LineNumber: Integer;
StringParams: array of TStringInfoParams; Values: array of Variant);
var
I, Index: Integer;
StringInfo: TStringInfo;
begin
FStringInfoCS.Enter;
try
try
Index := GetLineNumberIndex(LineNumber);
if Index < 0 then
raise EProgressException.CreateFmt(ErrorStringNotFound, [Index])
else
StringInfo := FStringInfo[Index];
if Length(StringParams) <> Length(Values) then
raise EProgressException.Create(ErrorWrongDimension);
for I := 0 to High(StringParams) do
case StringParams[I] of
sipText: StringInfo.sText := Values[I];
sipAlignment: StringInfo.sAlignment := Values[I];
sipLineBreak: StringInfo.sLineBreak := Values[I];
sipFontName: StringInfo.sFontName := Values[I];
sipFontSize: StringInfo.sFontSize := Values[I];
sipFontStyles: StringInfo.sFontStyle := TFontStyles(Byte(Values[I]));
sipFontColor: StringInfo.sFontColor := Values[I];
end;
FStringInfo[Index] := StringInfo;
except
on E: Exception do
raise EProgressException.Create('TProgressViewer.ChangeStringParams -> ' + E.Message);
end;
FBufferIsReady := False;
finally
FStringInfoCS.Leave;
end;
end;
procedure TProgressViewer.CheckCancelByUser;
begin
if FCancelByUser then
raise EProgressCancelByUser.Create(CancelByUserMessage);
end;
constructor TProgressViewer.Create(AText: string; ShowAsPercentBar: Boolean = False;
CancelBtnVisible: Boolean = False; ProgressMethod: TProgressMethod = nil);
var
ScreenRect: TRect;
begin
if not WndClassIsReg then
raise EProgressException.Create(ErrorRegWndMsg);
inherited Create(False);
FForegroundWindow := GetForegroundWindow;
FStringInfoCS := TCriticalSection.Create;
FDataCS := TCriticalSection.Create;
FBitmap := TBitmap.Create;
FFonBitmap := TBitmap.Create;
FTextBitmap := TBitmap.Create;
FBMPLine := TBitmap.Create;
FShowAsPercentBar := ShowAsPercentBar;
FWndWidth := DefWndWidth;
FNewWidth := DefWndWidth;
FWndHeight := DefWndHeight;
FCancelBtnVisible := CancelBtnVisible;
FNewBtnVisible := CancelBtnVisible;
FBGColor := DefBGColor;
FreeOnTerminate := True;
SystemParametersInfo(SPI_GETWORKAREA, 0, @ScreenRect, 0);
FFormLeftTop.X := (ScreenRect.Right - ScreenRect.Left - FWndWidth) div 2;
FFormLeftTop.Y := ScreenRect.Bottom - FWndHeight - 100;
FDefaultFontColor := clDefault;
FDefaultFontSize := -1;
FDefaultFontStyle := FontStyleNone;
if AText = '' then AText := ' ';
Text := AText;
{ Включаем название организации }
AddStringInfo(-1, SProductName, taCenter, False, clBlack, [fsBold], 12, GlobalDefaultFontName);
{ Включаем метки с текстом "Пожалуйста, подождите!" }
AddStringInfo(WAIT_TEXT_INDEX, ' ', taCenter, False, clBlack, [fsBold], 8);
AddStringInfo(WAIT_TEXT_INDEX + 1, ProgressWaitLabel1, taCenter, False, clBlack, [fsBold], 10, GlobalDefaultFontName);
AddStringInfo(WAIT_TEXT_INDEX + 2, ProgressWaitLabel2, taCenter, False, clBlack, [fsBold], 10, GlobalDefaultFontName);
if Assigned(ProgressMethod) then
begin
FAdditionalThread := TAdditionalThread.Create(True);
FAdditionalThread.FProgressMethod := ProgressMethod;
FAdditionalThread.FOwnerThread := Self;
FAdditionalThread.FreeOnTerminate := True;
end;
end;
procedure TProgressViewer.CreateNewWnd;
var
WndHandle: HWND;
begin
WndHandle := CreateWindowEx(
WS_EX_TOOLWINDOW or WS_EX_TOPMOST, // Чтобы не было кнопки на панели задач
ProgressWindowClassName,
'ProgressWnd',
WS_VISIBLE or WS_POPUP,
FFormLeftTop.X, FFormLeftTop.Y,
FWndWidth, FWndHeight,
0,
0,
hInstance, // Адрес модуля, предоставляющего оконную функцию
nil);
// Дальнейшие действия следует выполнять только при успешном создании окна
// Если по какой-то причине окно создать не удалось, то приложение все-равно
// не свалится - просто не будет никакой отрисовки.
if WndHandle <> 0 then
begin
// Показ окна на экране
ShowWindow(WndHandle, SW_SHOW);
FhWindow := WndHandle; // Запоминает дескриптор созданного окна
RegisterWnd; // Регистрируем созданное окно
// Создаем кнопку "Отмена"
FhButton := CreateWindow ('BUTTON', PChar(CancelButtonText), WS_CHILD,
FWndWidth - 120, FWndHeight - 30, 100, 25, WndHandle, 0, hInstance, nil );
if FhButton <> 0 then
begin
if FCancelBtnVisible then
begin
ShowWindow(FhButton, SW_SHOW);
UpdateWindow(FhButton);
end;
end;
end;
end;
procedure TProgressViewer.DeleteStringInfo(LineNumber: Integer);
var
Index, I: Integer;
begin
FStringInfoCS.Enter;
try
Index := GetLineNumberIndex(LineNumber);
if Index >= 0 then
begin
if Index < High(FStringInfo) then
for I := Index + 1 to High(FStringInfo) do
FStringInfo[I - 1] := FStringInfo[I];
SetLength(FStringInfo, High(FStringInfo));
FBufferIsReady := False;
end;
finally
FStringInfoCS.Leave;
end;
end;
destructor TProgressViewer.Destroy;
begin
FreeOnTerminate := False;
inherited Destroy;
FStringInfoCS.Free;
FBitmap.Free;
FFonBitmap.Free;
FTextBitmap.Free;
FBMPLine.Free;
FDataCS.Free;
end;
procedure TProgressViewer.DoCancelByUser;
begin
FCancelByUser := True;
if Assigned(FOnCancelByUser) then
try
FOnCancelByUser(Self);
except
{$IFDEF CanRaiseException}raise;{$ENDIF}
end;
end;
procedure TProgressViewer.DrawProgress;
var
S: string;
TxtWidth: Integer;
begin
LockCanvas;
try
FBitmap.Assign(FFonBitmap);
FBMPLine.FreeImage;
FBMPLine.Width := FBitmap.Width - 40;
FBMPLine.Height := 20;
FBMPLine.Canvas.Brush.Style := bsSolid;
FBMPLine.Canvas.Brush.Color := clWhite;
FBMPLine.Canvas.Rectangle(FBMPLine.Canvas.ClipRect);
FBMPLine.Canvas.Brush.Color := ProgressColor;
if not FShowAsPercentBar then
begin
FCurrentValue := FCurrentValue + 10;
if FCurrentValue > FBMPLine.Width then
FCurrentValue := -40;
FBMPLine.Canvas.Rectangle(Trunc(FCurrentValue), 2,
Trunc(FCurrentValue) + 40, FBMPLine.Height - 2);
end else
begin
if FCurrentValue > 100 then FCurrentValue := 100 else
if FCurrentValue < 0 then FCurrentValue := 0;
FBMPLine.Canvas.Rectangle(2, 2, 2 + Trunc(FCurrentValue *
(FBMPLine.Width - 4) / 100), FBMPLine.Height - 2);
// Выводим проценты
if DrawPercentLabel then
begin
S := IntToStr(Trunc(FCurrentValue)) + ' %';
TxtWidth := FBMPLine.Canvas.TextWidth(S);
FBMPLine.Canvas.Brush.Style := bsClear;
FBMPLine.Canvas.Font.Style := [fsBold];
FBMPLine.Canvas.TextOut((FBMPLine.Width - TxtWidth) div 2, 4, S);
end;
end;
if DrawTimeLabel then
begin
S := Format(ProgressCommonTime, [TimeToStr(Time - FStartTime)]);
FBitmap.Canvas.Font.Style := [];
FBitmap.Canvas.Brush.Style := bsClear;
TxtWidth := FBitmap.Canvas.TextWidth(S);
if FCancelBtnVisible then
FBitmap.Canvas.TextOut(20, FWndHeight - 25, S)
else
FBitmap.Canvas.TextOut(FWndWidth - TxtWidth - 20, FWndHeight - 25, S);
end;
Windows.BitBlt(FBitmap.Canvas.Handle, 20, FWndHeight - 60, FBMPLine.Width, FBMPLine.Height,
FBMPLine.Canvas.Handle, 0, 0, SRCCOPY);
finally
SendMessage(FhWindow, WM_DOPAINT, Integer(Self), 0);
UnLockCanvas;
end;
end;
procedure TProgressViewer.Execute;
var
Msg: TMsg;
procedure DrawText;
begin
LockCanvas;
try
FBitmap.FreeImage;
FFonBitmap.FreeImage;
FBitmap.Width := FWndWidth;
FBitmap.Height := FWndHeight;
FBitmap.Canvas.Brush.Color := clBtnFace;
FBitmap.Canvas.Rectangle(FBitmap.Canvas.ClipRect);
FFonBitmap.Assign(FBitmap);
if FTextBitmap.Height > 0 then
FFonBitmap.Canvas.Draw(10, 2, FTextBitmap);
finally
UnLockCanvas;
end;
end;
// Рисует текст из массива FStringInfo в буфере FTextBitmap
procedure PrepareTextRegion;
var
tbWidth, tbHeight, I, tmp: Integer;
ARect: TRect;
AlignValue: Cardinal;
WordBreak: Cardinal;
begin
LockCanvas;
FStringInfoCS.Enter;
try
tbWidth := FWndWidth - 20;
// Определяем высоту блока текстовых надписей
tbHeight := 0;
FTextBitmap.Height := 0;
for I := 0 to High(FStringInfo) do
begin
with FTextBitmap.Canvas, FStringInfo[I] do
begin
Font.Name := sFontName;
Font.Size := sFontSize;
Font.Style := sFontStyle;
ARect.Left := 0;
ARect.Top := 0;
ARect.Right := tbWidth;
ARect.Bottom := 0;
if sLineBreak then
WordBreak := DT_WORDBREAK
else
WordBreak := 0;
Windows.DrawText(Handle, PChar(sText), Length(sText), ARect,
DT_CALCRECT or WordBreak);
tmp := TextWidth(sText);
inttostr(tmp);
sLineHeight := ARect.Bottom;
tbHeight := tbHeight + sLineHeight;
end;
end;
FTextBitmap.Width := tbWidth;
FTextBitmap.Height := tbHeight;
FTextBitmap.Canvas.Brush.Color := FBGColor;
FTextBitmap.Canvas.FillRect(FTextBitmap.Canvas.ClipRect);
// Выполняем отрисовку на FTextBitmap
tbHeight := 0;
for I := 0 to High(FStringInfo) do
begin
with FTextBitmap.Canvas, FStringInfo[I] do
begin
Font.Name := sFontName;
Font.Size := sFontSize;
Font.Style := sFontStyle;
Font.Color := sFontColor;
ARect.Left := 0;
ARect.Top := tbHeight;
ARect.Right := tbWidth;
ARect.Bottom := tbHeight + sLineHeight;
case sAlignment of
taLeftJustify: AlignValue := DT_LEFT;
taRightJustify: AlignValue := DT_RIGHT;
else
AlignValue := DT_CENTER;
end;
if sLineBreak then
WordBreak := DT_WORDBREAK
else
WordBreak := 0;
Windows.DrawText(Handle, PChar(sText), Length(sText), ARect,
AlignValue or WordBreak);
tbHeight := tbHeight + sLineHeight;
if sLineNumber = 0 then
tbHeight := tbHeight;
end;
end;
// Отрисовываем на FBitmap
if FTextBitmap.Height > 0 then
SetWndSize(-1, DefWndHeight + FTextBitmap.Height);
finally
UnLockCanvas;
FStringInfoCS.Leave;
end;
end;
procedure PrepareImageForWindow;
begin
PrepareTextRegion;
DrawText;
end;
procedure ProcessMessages;
begin
if FhWindow <> 0 then
while PeekMessage(Msg, FhWindow, 0, 0, PM_REMOVE) do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
procedure UpdateButton;
begin
if FhButton <> 0 then
begin
InvalidateRect(FhButton, nil, False);
ProcessMessages;
end;
end;
procedure CheckWidthAndVisible;
begin
FDataCS.Enter;
try
if FNewWidth <> FWndWidth then
SetWndSize(FNewWidth, -1);
// Попутно проверяем видимость кнопки "Отмена"
if FNewBtnVisible <> FCancelBtnVisible then
begin
if FhButton <> 0 then
begin
if FCancelBtnVisible then
ShowWindow(FhButton, SW_SHOW)
else
ShowWindow(FhButton, SW_HIDE);
end;
FCancelBtnVisible := FNewBtnVisible;
end;
finally
FDataCS.Leave;
end;
end;
begin
// Обрабатываем случай, когда перед созданием окна пользователь успел
// вызвать метод SetWndWidth
CheckWidthAndVisible;
// Сооздаем в данном потоке новое окошко, в котором и будем выполнять отрисовку
CreateNewWnd;
// Запоминаем время старта
FStartTime := Time;
if Assigned(FAdditionalThread) then
FAdditionalThread.Resume;
while not Terminated do
begin
// Если пользователь изменил значение ширины окна или видимость кнопки
// "отмена", то обрабатываем это
CheckWidthAndVisible;
// Реагируем на возможную смену ширины окна
ProcessMessages;
// Подготавливаем изображение
FStringInfoCS.Enter;
try
if not FBufferIsReady then
begin
try
PrepareImageForWindow;
except
{$IFDEF CanRaiseException}raise;{$ENDIF}
end;
FBufferIsReady := True;
end;
finally
FStringInfoCS.Leave;
end;
if FhWindow <> 0 then
try
DrawProgress;
except
{$IFDEF CanRaiseException}raise;{$ENDIF}
end;
// Выполняем перерисовку кнопки
UpdateButton;
Sleep(SleepTime);
end;
if Assigned(FAdditionalThread) then
FAdditionalThread.Terminate;
// Прячем окошко, после чего дестроим его
if FhWindow <> 0 then
begin
ShowWindow(FhWindow, SW_HIDE);
SendMessage(FhWindow, WM_DESTROY, 0, 0);
UnRegisterWnd;
//if FForegroundWindow <> 0 then
// SetForegroundWindow(FForegroundWindow);
//FForegroundWindow := 0;
FhWindow := 0;
end;
end;
function TProgressViewer.GetLineNumberIndex(LineNumber: Integer): Integer;
var
I: Integer;
begin
Result := -1;
for I := 0 to High(FStringInfo) do
if FStringInfo[I].sLineNumber = LineNumber then
begin
Result := I;
Exit;
end;
end;
function TProgressViewer.GetStringInfo(LineNumber: Integer): TStringInfo;
var
Index: Integer;
begin
FStringInfoCS.Enter;
try
Result := ClearStringInfo;
Index := GetLineNumberIndex(LineNumber);
if Index >= 0 then
Result := FStringInfo[Index];
finally
FStringInfoCS.Leave;
end;
end;
procedure TProgressViewer.LockCanvas;
begin
FBitmap.Canvas.Lock;
FFonBitmap.Canvas.Lock;
FTextBitmap.Canvas.Lock;
FBMPLine.Canvas.Lock;
end;
procedure TProgressViewer.RegisterWnd;
begin
if FhWindow <> 0 then
with WndHandleList.LockList do
try
if IndexOf(Pointer(FhWindow)) < 0 then
begin
Add(Pointer(FhWindow));
ThreadsList.Add(Self);
end;
finally
WndHandleList.UnlockList;
end;
end;
procedure TProgressViewer.SetCancelBtnVisible(const Value: Boolean);
begin
FDataCS.Enter;
FNewBtnVisible := Value;
FDataCS.Leave;
end;
procedure TProgressViewer.SetOnCancelByUser(const Value: TNotifyEvent);
begin
FOnCancelByUser := Value;
end;
procedure TProgressViewer.SetText(const Value: string);
begin
FText := Value;
if GetLineNumberIndex(TEXT_INDEX) < 0 then
AddStringInfo(TEXT_INDEX, Value, taCenter, False, clBlack, [fsBold], 14)
else
ChangeStringInfo(TEXT_INDEX, [sipText], [Value]);
end;
procedure TProgressViewer.SetWndSize(NewWidth, NewHeight: Integer);
var
ScreenRect: TRect;
begin
if NewHeight = -1 then NewHeight := FWndHeight;
if NewWidth = -1 then NewWidth := FWndWidth;
if NewHeight < DefWndHeight then
NewHeight := DefWndHeight;
if NewWidth < DefWndWidth div 2 then
NewWidth := DefWndWidth div 2;
if (FWndHeight <> NewHeight) or (FWndWidth <> NewWidth) then
begin
SystemParametersInfo(SPI_GETWORKAREA, 0, @ScreenRect, 0);
FWndHeight := NewHeight;
FWndWidth := NewWidth;
FFormLeftTop.X := (ScreenRect.Right - ScreenRect.Left - FWndWidth) div 2;
FFormLeftTop.Y := ScreenRect.Bottom - FWndHeight - 100;
if FhWindow <> 0 then
SetWindowPos(FhWindow, HWND_TOPMOST, FFormLeftTop.X, FFormLeftTop.Y, FWndWidth,
FWndHeight, SWP_SHOWWINDOW);
if FhButton <> 0 then
begin
SetWindowPos(FhButton, HWND_TOP, FWndWidth - 120, FWndHeight - 30,
100, 25, SWP_HIDEWINDOW);
if FCancelBtnVisible then
begin
ShowWindow(FhButton, SW_SHOW);
UpdateWindow(FhButton);
end;
end;
FBufferIsReady := False;
end;
end;
procedure TProgressViewer.SetWndWidth(NewWidth: Integer);
begin
if NewWidth < DefWndWidth div 2 then
NewWidth := DefWndWidth div 2;
FDataCS.Enter;
FNewWidth := NewWidth;
FDataCS.Leave;
end;
procedure TProgressViewer.SortStringInfoArray;
var
I, J: Integer;
AStringInfo: TStringInfo;
begin
for I := 0 to High(FStringInfo) - 1 do
for J := High(FStringInfo) downto I + 1 do
if FStringInfo[I].sLineNumber > FStringInfo[J].sLineNumber then
begin
AStringInfo := FStringInfo[I];
FStringInfo[I] := FStringInfo[J];
FStringInfo[J] := AStringInfo;
end;
end;
procedure TProgressViewer.TerminateProgress;
begin
Free;
if FForegroundWindow <> 0 then
SetForegroundWindow(FForegroundWindow);
end;
procedure TProgressViewer.UnLockCanvas;
begin
FBitmap.Canvas.Unlock;
FFonBitmap.Canvas.Unlock;
FTextBitmap.Canvas.Unlock;
FBMPLine.Canvas.Unlock;
end;
procedure TProgressViewer.UnRegisterWnd;
var
Index: Integer;
begin
with WndHandleList.LockList do
try
Index := IndexOf(Pointer(FhWindow));
if Index >= 0 then
begin
Delete(Index);
ThreadsList.Delete(Index);
end;
finally
WndHandleList.UnlockList;
end;
end;
{ TAdditionalThread }
procedure TAdditionalThread.Execute;
begin
FProgressMethod(FOwnerThread);
while not Terminated do
Sleep(50);
end;
procedure RegisterProgressWndClass;
var
WndClass: TWndClass;
begin
WndClass.lpszClassName := ProgressWindowClassName;
WndClass.lpfnWndProc := @MainWndProc;
WndClass.Style := CS_VREDRAW or CS_HREDRAW;
{Адрес модуля (EXE или DLL), в котором находится MainWndProc. В дальнейшем
функция CreateWindowEx в списке классов с одинаковым именем ProgressWindowClassName
благодаря hInstance сможет найти требуемый класс окна }
WndClass.hInstance := hInstance;
WndClass.hIcon := LoadIcon(0, IDI_APPLICATION);
WndClass.hCursor := LoadCursor(0, IDC_ARROW);
WndClass.hbrBackground := (COLOR_WINDOW + 1);
WndClass.lpszMenuName := nil;
WndClass.cbClsExtra := 0;
WndClass.cbWndExtra := 0;
WndClassIsReg := Windows.RegisterClass(WndClass) <> 0;
if not WndClassIsReg then
WndClassIsReg := GetLastError = ERROR_CLASS_ALREADY_EXISTS;
end;
initialization
WndHandleList := TThreadList.Create;
ThreadsList := TList.Create;
RegisterProgressWndClass;
finalization
WndHandleList.Free;
ThreadsList.Free;
end.
Reference in New Issue View Git Blame Copy Permalink