gourdol@imag.imag.fr (Gourdol Arnaud) (06/10/91)
Hi all !
Here is the source code that defines an Object Pascal
class displaying a progress bar in a movable modal
dialog box, very much like the one used by the 7.0
Finder.
It uses a library called HIK which provides
some utilies I used here, but I think you can
figure them by yourself and use some equivalents.
Also, this unit is distributed under the GNU
copyleft distribution scheme. It means you can
use this code to your heart's content, but
should you make any improvement or adaptation
(suggestions: adapting it to MacApp, TCL, writting
it in C++) you have the (legal and moral)
obligation to send me a copy of the modified code,
provide appropriate credit and make it publicly
available.
Here it is, enjoy.
Arno.
------------------------ Cut Here ---------------------------------
{ Project : The Application Factory }
{ File : UProgress.p }
{ Date : April 1991 }
{ Copyright 1991, Arnaud Gourdol and Odyssey Software}
{ All Rights Reserved }
{This program is free software; you can redistribute it and/or modify }
{ it under the terms of the GNU General Public License as published }
{ by the Free Software Foundation; version 1.}
{This program is distributed in the hope that it will be useful ,}
{ but WITHOUT ANY WARRANTY; without even the implied warranty of }
{ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. }
{ See the GNU General Public License for more details. }
{ You should have received a copy of the GNU General Public}
{ License along with this program; if not, write to: }
{ The Free Software Foundation, Inc .}
{ 675 Mass Ave, Cambridge, MA 02139, USA . }
{ Courier 10, indent 2 spaces, tabs at 3 spaces }
unit UProgress;
interface
uses
(* Group 1 *)
Types, QuickDraw, Script,
(* Group 2 *)
Controls, Errors, Events, OSUtils, Memory, TextEdit, ToolUtils,
(* Group 3 *)
Windows,
(* Group 4 *)
Dialogs, ObjIntf, UHIK;
type
TProgress = object(TObject)
{* Public }
fTaskName: Str255; { Name of the current task (should be short) }
fMessage: Str255; { Message to display (longer than task name) }
fThreshold: Longint; { Time to wait before displaying the dialog }
fLast: Longint; { Value to reach when ended (0 based)}
{* Private }
fDlog: WindowPtr; { The pointer to the dialog displayed }
fCur: Longint; { Current progress }
fStart: Longint; { Time at which the job started }
fButton: ControlHandle; { The stop/cancel button }
fCanCancel: Boolean; { True if the task can be cancelled, else stopped }
fCurWindow: WindowPtr;
fOldMask: integer; { Saved event mask }
{* Public }
procedure IProgress (last: Longint; taskName: Str255);
function TProgress.Progress (cur: Longint; message: Str255; canCancel: Boolean): OSErr;
procedure Free;
override;
{* Private }
procedure DisplayDialog;
procedure UpdateDialog;
function DoEvent: Boolean;
procedure DrawBar;
procedure DrawMessage;
end;
implementation
{$S SMisc }
procedure IdleEvent;
external;
procedure ProcessEvent;
external;
procedure CheckGraphicEnv;
external;
procedure PrepareMenu;
external;
{DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD}
{ TProgress.IProgress }
{DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD}
procedure TProgress.IProgress (last: Longint; taskName: Str255);
begin
fTaskName := taskName;
fMessage := '';
fThreshold := 15 * 60; { Wait 15 seconds before displaying }
fLast := last;
fDlog := nil;
fCur := -1;
fStart := TickCount;
fButton := nil;
fCanCancel := true;
fCurWindow := nil;
fOldMask := gAppl.evtMask;
gAppl.evtMask := everyEvent - activateEvt;
NSetCursor(kWatch);
end;
{DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD}
{ TProgress.Progress }
{DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD}
function TProgress.Progress (cur: Longint; message: Str255; canCancel: Boolean): OSErr;
{ If cur <> -1, tells the progress that the task has progressed and that it is}
{ completed by cur/fLast %.}
{ CanCancel is true if the task can be canceled, that is completely }
{ reversed as if never done. Else it can only be stopped }
{ If message is not empty, then it is the new message to display in the }
{ progress box }
{ Returns userCanceledErr if the user required the stop or cancel of the task }
var
oldPort: GrafPtr;
btnTitle: Str255;
begin
{* Get port and set it to the dialog }
GetPort(oldPort);
if fDlog <> nil then
SetPort(fDlog);
{$IFC qDebug }
if (cur <> -1) & (cur < fCur) then
DebugStr('TProgress.Progress : cur < fCur');
if cur > fLast then
DebugStr('TProgress.Progress : cur > fLast');
{$ENDC}
{* Update fCur and fMessage }
if fDlog <> nil then
begin
if (cur <> -1) & (fCur <> cur) then
begin
fCur := cur;
DrawBar;
end;
if (length(message) <> 0) then
begin
fMessage := message;
DrawMessage;
end;
if fCanCancel <> canCancel then
begin
fCanCancel := canCancel;
if canCancel then
GetIndString(btnTitle, 260, 2)
else
GetIndString(btnTitle, 260, 1);
SetCTitle(fButton, btnTitle);
end;
end
else
begin
if cur <> -1 then
fCur := cur;
if (length(message) <> 0) then
fMessage := message;
fCanCancel := canCancel;
end;
{* Save the window of the doc behind us }
if gDoc = nil then
fCurWindow := nil
else
fCurWindow := DocWPtr;
{* Get an event }
if DoEvent then
Progress := userCanceledErr
else
Progress := noErr;
{* If no dialog is displayed yet }
if (fDlog = nil) then
begin
{** Don't display it if time has not come yet }
{ or if the application is in the background }
if ((TickCount - fStart) < fThreshold) | (gAppl.isInBackground) then
Exit(Progress);
DisplayDialog; { Display dialog now }
SetPort(fDlog);
UpdateDialog;
ValidRect(fDlog^.portRect);
end;
{* Restore grafPort }
SetPort(oldPort);
end;
{DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD}
{ TProgress.DisplayDialog }
{DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD}
procedure TProgress.DisplayDialog;
var
bounds: Rect;
s: Str255;
begin
{* Create new window }
SetRect(bounds, 98, 114, 400, 180);
s := fTaskName;
if gAppl.hasColorQD then
fDlog := NewCWindow(nil, bounds, s, false, 5, pointer(-1), true, 0)
else
fDlog := NewWindow(nil, bounds, s, false, 5, pointer(-1), true, 0);
{* Create the button control }
if fDlog <> nil then
begin
{* Set the windowkind to 9, ie semi-modal window }
WindowPeek(fDlog)^.windowKind := 9;
{* Create the button control }
SetRect(bounds, 234, 38, 293, 58);
if fCanCancel then
GetIndString(s, 260, 2)
else
GetIndString(s, 260, 1);
fButton := NewControl(fDlog, bounds, s, true, 0, 0, 1, btnCtrl, 0);
ShowWindow(fDlog);
SelectWindow(fDlog);
{* Change the cursor to an arrow }
NSetCursor(kArrow);
end;
end;
{DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD}
{ TProgress.DrawBar }
{DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD}
procedure TProgress.DrawBar;
var
barRect: Rect;
blueRect: Rect;
grayRect: Rect;
begin
if fCur = -1 then
Exit(DrawBar);
SetRect(barRect, 13, 42, 221, 53);
blueRect := barRect;
InsetRect(blueRect, 1, 1);
grayRect := blueRect;
with grayRect do
right := left + ((longint(right - left) * fCur) div fLast);
blueRect.left := grayRect.right;
{* Draw the remaining part of the progress bar }
if gAppl.colorDepth <= 4 then
SetGray64(0)
else
SetRGBColor(17408, 17408, 17408);
PaintRect(grayRect);
{* Draw the done part of the progress bar }
if gAppl.colorDepth <= 4 then
SetGray64(64)
else
SetRGBColor(52224, 52224, 65535);
PaintRect(blueRect);
{* Draw the frame of the progress bar }
ForeColor(blackColor);
PenPat(black);
FrameRect(barRect);
end;
{DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD}
{ TProgress.DrawMessage }
{DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD}
procedure TProgress.DrawMessage;
var
textRect: Rect;
i: integer;
s: Str255;
begin
SetRect(textRect, 13, 10, 293, 26);
TextFont(0);
TextSize(0);
EraseRect(textRect);
i := DrawStringFitsBox(fMessage, textRect, teJustLeft);
end;
{DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD}
{ TProgress.UpdateDialog }
{DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD}
procedure TProgress.UpdateDialog;
begin
{* Draw the button }
Draw1Control(fButton);
{* Draw the text }
DrawMessage;
{* Draw the progress bar }
DrawBar;
end;
{DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD}
{ TProgress.DoEvent }
{DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD}
function TProgress.DoEvent: Boolean;
var
aborted: Boolean;
c: Char;
par: Integer;
window: WindowPtr;
oldPort: GrafPtr;
localClick: Point;
aCtrl: ControlHandle;
code: Integer;
part: integer;
tix: Longint;
procedure RestoreWindow;
begin
UpdateDoc(fCurWindow);
if (gAppl.curDoc > 0) then
Focus(kFocusContent);
end;
begin
DoEvent := false;
UpdateDoc(fDlog);
{* Process an event }
if not GetAnEvent(0) then
{** There is no event available, just idle }
begin
IdleEvent;
end
else
begin
if fDlog = nil then
begin
with gAppl do
if (evt.what = keyDown) | (evt.what = mouseDown) then
DisplayDialog
else
ProcessEvent;
RestoreWindow;
Exit(DoEvent);
end;
{** There is an event available. If it is a keyboard event. }
{* Assume user does not want to abort }
aborted := false;
with gAppl do
begin
if (evt.what = keyDown) | (evt.what = autoKey) then
begin
{*** Abort if the command key is down and a dot has been typed }
c := char(BAND(evt.message, $FF));
aborted := (BAND(evt.message, $FF00) = $3500) | ((isCmdKey) & ((c = '.') | (c = ',') | (c = ';')));
if aborted & (fButton <> nil) then
begin
HiliteControl(fButton, 1);
Delay(8, tix);
HiliteControl(fButton, 0);
DoEvent := true;
end;
end;
{** Check if this event concerns the progress dialog }
{*** A mouse down event ? }
if (fDlog <> nil) & (evt.what = mouseDown) then
begin
part := FindWindow(evt.where, window);
if (fDlog <> nil) & (window = fDlog) then
begin
if (part = inDrag) then
begin
GetPort(oldPort);
SetPort(fDlog);
DragWindow(window, evt.where, dragRect);
SetPort(oldPort);
end
else if (part = inContent) then
begin
GetPort(oldPort);
SetPort(window);
localClick := evt.where;
GlobalToLocal(localClick);
code := FindControl(localClick, window, aCtrl);
if (code <> 0) & (aCtrl = fButton) then
begin
DoEvent := (TrackControl(aCtrl, localClick, nil) <> 0);
end;
SetPort(oldPort);
end;
RestoreWindow;
Exit(DoEvent);
end;
if (part <> inDesk) & (part <> inMenuBar) then
begin
RestoreWindow;
Exit(DoEvent);
end;
end;
{*** An update event }
if (evt.what = updateEvt) then
begin
window := WindowPtr(evt.message);
if window = fDlog then
begin
CheckGraphicEnv;
GetPort(oldPort);
SetPort(window);
BeginUpdate(window);
UpdateDialog;
EndUpdate(window);
SetPort(oldPort);
RestoreWindow;
Exit(DoEvent);
end;
end;
end;
{** Do what is necessary to process this event }
ProcessEvent;
end;
RestoreWindow;
end;
{DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD}
{ TProgress.Free }
{DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD}
procedure TProgress.Free;
begin
gAppl.evtMask := fOldMask;
if fDlog <> nil then
begin
DisposeControl(fButton);
CloseWindow(fDlog);
UpdateDoc(fCurWindow);
if (gAppl.curDoc > 0) then
Focus(kFocusContent);
PrepareMenu;
{* Redisplay a watch }
NSetCursor(kWatch);
end;
end;
end.--
/=============================//===================================/
/ Arno Gourdol. // On the Netland: Gourdol@imag.fr /
/ "A keyboard ! How quaint !" -- Scott, Star Trek /
/=============================//===================================/