DEFINE CLASS dlgThermo AS form
DoCreate = .T.
Caption = ""
ControlBox = .F.
FontSize = 10
Height = 107
Width = 301
DoCreate = .T.
AutoCenter = .T.
BorderStyle = 0
Caption = ""
Closable = .F.
MaxButton = .F.
MinButton = .F.
Movable = .F.
TitleBar = 0
AlwaysOnTop = .T.
WindowType = 0
*-- Numeric. Number of milliseconds to wait before displaying a bar.
interval = 100
*-- Numeric. An integer between 0 and 100 representing the completness of the task.
percent = 0
*-- Character. The text to display in Title label.
title = ""
*-- Character. Describes the task in progress.
task = ""
*-- Reference to the calling form. The form is activated in the Destroy event.
HIDDEN callingform
callingform = .NULL.
*-- Numeric. Number of muilliseconds to wait when the thermometer reaches a 100%.
timetostop = 100
Name = "dlgThermo"
*-- Logical. Specifies if the user clicked the Cancel button.
abort = .F.
*-- Logical. Specifies if the user is allowed to cancel the process.
allowcancel = .F.
ADD OBJECT shape1 AS shape WITH ;
Top = 0, ;
Left = 1, ;
Height = 107, ;
Width = 299, ;
BackStyle = 0, ;
SpecialEffect = 1, ;
ZOrderSet = 0, ;
Name = "shape1"
ADD OBJECT shpbar1 AS shape WITH ;
Top = 55, ;
Left = 12, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 1, ;
Name = "shpBar1"
ADD OBJECT linhb1 AS line WITH ;
Height = 0, ;
Left = 10, ;
Top = 53, ;
Width = 277, ;
BorderColor = RGB(128,128,128), ;
ZOrderSet = 2, ;
Name = "linHB1"
ADD OBJECT linhw1 AS line WITH ;
Height = 0, ;
Left = 10, ;
Top = 72, ;
Width = 277, ;
BorderColor = RGB(255,255,255), ;
ZOrderSet = 3, ;
Name = "linHW1"
ADD OBJECT linvb1 AS line WITH ;
Height = 18, ;
Left = 10, ;
Top = 54, ;
Width = 0, ;
BorderColor = RGB(128,128,128), ;
ZOrderSet = 4, ;
Name = "linVB1"
ADD OBJECT linvw1 AS line WITH ;
Height = 20, ;
Left = 287, ;
Top = 53, ;
Width = 0, ;
BorderColor = RGB(255,255,255), ;
ZOrderSet = 5, ;
Name = "linVW1"
ADD OBJECT shpbar2 AS shape WITH ;
Top = 55, ;
Left = 23, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 6, ;
Name = "shpBar2"
ADD OBJECT shpbar3 AS shape WITH ;
Top = 55, ;
Left = 34, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 7, ;
Name = "shpBar3"
ADD OBJECT shpbar4 AS shape WITH ;
Top = 55, ;
Left = 45, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 8, ;
Name = "shpBar4"
ADD OBJECT shpbar5 AS shape WITH ;
Top = 55, ;
Left = 56, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 9, ;
Name = "shpBar5"
ADD OBJECT shpbar6 AS shape WITH ;
Top = 55, ;
Left = 67, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 10, ;
Name = "shpBar6"
ADD OBJECT shpbar7 AS shape WITH ;
Top = 55, ;
Left = 78, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 11, ;
Name = "shpBar7"
ADD OBJECT shpbar8 AS shape WITH ;
Top = 55, ;
Left = 89, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 12, ;
Name = "shpBar8"
ADD OBJECT shpbar9 AS shape WITH ;
Top = 55, ;
Left = 100, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 13, ;
Name = "shpBar9"
ADD OBJECT shpbar10 AS shape WITH ;
Top = 55, ;
Left = 111, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 14, ;
Name = "shpBar10"
ADD OBJECT shpbar11 AS shape WITH ;
Top = 55, ;
Left = 122, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 15, ;
Name = "shpBar11"
ADD OBJECT shpbar12 AS shape WITH ;
Top = 55, ;
Left = 133, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 16, ;
Name = "shpBar12"
ADD OBJECT shpbar13 AS shape WITH ;
Top = 55, ;
Left = 144, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 17, ;
Name = "shpBar13"
ADD OBJECT shpbar14 AS shape WITH ;
Top = 55, ;
Left = 155, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 18, ;
Name = "shpBar14"
ADD OBJECT shpbar15 AS shape WITH ;
Top = 55, ;
Left = 166, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 19, ;
Name = "shpBar15"
ADD OBJECT shpbar16 AS shape WITH ;
Top = 55, ;
Left = 177, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 20, ;
Name = "shpBar16"
ADD OBJECT shpbar17 AS shape WITH ;
Top = 55, ;
Left = 188, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 21, ;
Name = "shpBar17"
ADD OBJECT shpbar18 AS shape WITH ;
Top = 55, ;
Left = 199, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 22, ;
Name = "shpBar18"
ADD OBJECT shpbar19 AS shape WITH ;
Top = 55, ;
Left = 210, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 23, ;
Name = "shpBar19"
ADD OBJECT shpbar20 AS shape WITH ;
Top = 55, ;
Left = 221, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 24, ;
Name = "shpBar20"
ADD OBJECT shpbar21 AS shape WITH ;
Top = 55, ;
Left = 232, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 25, ;
Name = "shpBar21"
ADD OBJECT shpbar22 AS shape WITH ;
Top = 55, ;
Left = 243, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 26, ;
Name = "shpBar22"
ADD OBJECT shpbar23 AS shape WITH ;
Top = 55, ;
Left = 254, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 27, ;
Name = "shpBar23"
ADD OBJECT shpbar24 AS shape WITH ;
Top = 55, ;
Left = 265, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 28, ;
Name = "shpBar24"
ADD OBJECT shpbar25 AS shape WITH ;
Top = 55, ;
Left = 276, ;
Height = 16, ;
Width = 10, ;
BorderStyle = 0, ;
FillStyle = 0, ;
FillColor = RGB(0,0,128), ;
ZOrderSet = 29, ;
Name = "shpBar25"
ADD OBJECT lbltask AS label WITH ;
FontBold = .F., ;
Caption = "Task", ;
Left = 10, ;
Top = 30, ;
Width = 280, ;
ZOrderSet = 30, ;
Name = "lblTask"
ADD OBJECT lbltitle AS label WITH ;
FontBold = .T., ;
Caption = "Title", ;
Left = 10, ;
Top = 10, ;
Width = 280, ;
ZOrderSet = 30, ;
Name = "lblTitle"
ADD OBJECT shape3 AS shape WITH ;
Top = 3, ;
Left = 3, ;
Height = 1, ;
Width = 294, ;
SpecialEffect = 1, ;
BorderColor = RGB(128,128,128), ;
ZOrderSet = 31, ;
Name = "shape3"
ADD OBJECT shape2 AS shape WITH ;
Top = 1, ;
Left = 1, ;
Height = 1, ;
Width = 297, ;
SpecialEffect = 1, ;
BorderColor = RGB(255,255,255), ;
ZOrderSet = 32, ;
Name = "shape2"
ADD OBJECT shape4 AS shape WITH ;
Top = 105, ;
Left = 1, ;
Height = 1, ;
Width = 297, ;
BackStyle = 0, ;
SpecialEffect = 1, ;
BorderColor = RGB(255,255,255), ;
ZOrderSet = 33, ;
Name = "shape4"
ADD OBJECT shape6 AS shape WITH ;
Top = 3, ;
Left = 3, ;
Height = 101, ;
Width = 1, ;
BackStyle = 0, ;
SpecialEffect = 1, ;
BorderColor = RGB(128,128,128), ;
ZOrderSet = 34, ;
Name = "shape6"
ADD OBJECT shape5 AS shape WITH ;
Top = 1, ;
Left = 1, ;
Height = 104, ;
Width = 1, ;
BackStyle = 0, ;
SpecialEffect = 1, ;
BorderColor = RGB(255,255,255), ;
ZOrderSet = 35, ;
Name = "shape5"
ADD OBJECT shape7 AS shape WITH ;
Top = 3, ;
Left = 296, ;
Height = 191, ;
Width = 1, ;
BackStyle = 0, ;
SpecialEffect = 1, ;
BorderColor = RGB(128,128,128), ;
ZOrderSet = 36, ;
Name = "shape7"
ADD OBJECT shape8 AS shape WITH ;
Top = 1, ;
Left = 298, ;
Height = 104, ;
Width = 1, ;
BackStyle = 0, ;
SpecialEffect = 1, ;
BorderColor = RGB(255,255,255), ;
ZOrderSet = 37, ;
Name = "shape8"
ADD OBJECT shape9 AS shape WITH ;
Top = 103, ;
Left = 3, ;
Height = 1, ;
Width = 294, ;
BackStyle = 0, ;
SpecialEffect = 1, ;
BorderColor = RGB(128,128,128), ;
ZOrderSet = 38, ;
Name = "shape9"
ADD OBJECT lblescape AS label WITH ;
FontBold = .F., ;
Caption = "Press the ESC key to cancel this process.", ;
Left = 10, ;
Top = 82, ;
Width = 280, ;
ZOrderSet = 30, ;
Name = "lblEscape"
*-- Returns a reference to one of the bar used to fill the thermometer.
PROCEDURE getbar
*==============================================================================
* GetBar
* ------
*
* Purpose.......: Retrieves a reference to a bar used to fill the
* thermometer
* Author........: Daniel Rouleau - Metro Information Services
* Last Revision.: 1999-04-28
*
* Syntax........: object.GetBar( tnBarNumber )
* Returns.......: object or null
* Arguments.....: tnBarNumber
* Specifies the number of th3e bar to return. An integer
* between 1 and 25.
*
* Remarks.......: Building a control array makes more sense. However, I
* don't know how to build one from the design environment.
*==============================================================================
LParameters tnBarNumber
Local loRetVal && Object reference returned by this method.
loRetVal = .Null.
If VarType(tnBarNumber) = 'N' Then
If Between(tnBarNumber, 1, 25) Then
loRetVal = Evaluate('Thisform.shpBar' + LTrim(Str(tnBarNumber, 2, 0)))
EndIf
EndIf
Return ( loRetVal )
ENDPROC
PROCEDURE percent_assign
*==============================================================================
* Percent_Assign
* --------------
*
* Purpose.......: Updates the Percent property and fills the thermometer.
* Author........: Daniel Rouleau - Metro Information Services
* Last Revision.: 1999-04-28
*
* Remarks.......:
*==============================================================================
LParameters tnNewValue
Local lnBar && Loop counter.
Local loBar && A reference to a bar object.
Local lcCursor && The current Cursor setting.
Local lnNewBars && Number of bars to display.
Local lnNewValue && New value to set.
Local lnOldBars && Number of bars previously displayed.
Local lnOldValue && Percentage current value.
Local lnTimeToStop && Number of milliseconds to wait when the
&& thermometer reaches 100%.
*---------------
*-- Early abort
*---------------
If LastKey() = 27 Then
If This.AllowCancel Then
This.OnCancel()
Return
EndIf
EndIf
With This
lnOldValue = Max(0, Min(100, .Percent))
lnOldBars = Int(lnOldValue / 4)
lnNewValue = Max(0, Min(100, tnNewValue))
lnNewBars = Int(lnNewValue / 4)
If lnNewBars > lnOldBars Then
*------------------------------
*-- Progress
*-- --------
*-- Wait a litle bit between
*-- display of each bar.
*--
*-- If showing 100%, wait a
*-- a little afterwards.
*------------------------------
For lnBar = lnOldBars + 1 To lnNewBars
loBar = .GetBar(lnBar)
If VarType(loBar) = 'O'
loBar.FillStyle = 0
.Refresh()
lcCursor = Set('Cursor')
Set Cursor Off
=Inkey(.Interval / 1000)
Set Cursor &lcCursor
EndIf
If lnNewValue = 100 Then
lcCursor = Set('Cursor')
Set Cursor Off
=Inkey(.TimeToStop / 1000)
Set Cursor &lcCursor
EndIf
EndFor
Else
*---------------------------
*-- Regress
*-- -------
*-- 'Hide' bar immediatly.
*---------------------------
For lnBar = lnNewBars + 1 TO 25
loBar = .GetBar(lnBar)
If VarType(loBar) = 'O'
loBar.FillStyle = 1
.Refresh()
If lnBar <= lnOldBars Then
lcCursor = Set('Cursor')
Set Cursor Off
=Inkey(.Interval / 1000)
Set Cursor &lcCursor
EndIf
EndIf
EndFor
EndIf
.Percent = lnNewValue
EndWith
ENDPROC
PROCEDURE title_assign
*==============================================================================
* Title_Assign
* ------------
*
* Purpose.......: Displays the new title.
* Author........: Daniel Rouleau - Metro Information Services
* Last Revision.: 1999-04-28
*
* Remarks.......:
*==============================================================================
LParameters tcTitle
If VarType(tcTitle) = 'C' Then
With This
.Title = tcTitle
.lblTitle.Caption = tcTitle
EndWith
EndIf
ENDPROC
*-- Resets all properties.
PROCEDURE reset
*==============================================================================
* Reset
* -----
*
* Purpose.......: Resets all properties to their default values.
* Author........: Daniel Rouleau - Metro Information Services
* Last Revision.: 1999-04-28
*
* Syntax........: object.Reset( )
* Returns.......: nothing
* Arguments.....: n/a
*
* Remarks.......: Setting .Percent = 0 restores all bars.
*
* See also......: Percent_Assign( )
*==============================================================================
Local llLockScreen && Current LockScreen status.
With This
*-----------------
*-- Lock Screen.
*-----------------
llLockScreen = .LockScreen
.LockScreen = .T.
*------------------
*-- Reset values.
*------------------
.Title = ''
.Task = ''
.Percent = 0
*------------------------
*-- Restore LockScreen.
*------------------------
.LockScreen = llLockScreen
EndWith
ENDPROC
PROCEDURE task_assign
*==============================================================================
* Task_Assign
* -----------
*
* Purpose.......: Displays the new task.
* Author........: Daniel Rouleau - Metro Information Services
* Last Revision.: 1999-04-28
*
* Remarks.......:
*==============================================================================
LParameters tcTask
If VarType(tcTask) = 'C' Then
With This
.Task = tcTask
.lblTask.Caption = tcTask
EndWith
EndIf
ENDPROC
PROCEDURE oncancel
*==============================================================================
* OnCancel
* --------
*
* Purpose.......: Actions to perform if Cancel is clicked.
* Author........: Daniel Rouleau - Metro Information Services
* Last Revision.: 2000-11-15
*
* Remarks.......:
*==============================================================================
With This
.Abort = .T.
.Hide()
EndWith
ENDPROC
PROCEDURE Init
*==============================================================================
* Init
* ----
*
* Purpose.......: Sets custom properties.
* Author........: Daniel Rouleau - Metro Information Services
* Last Revision.: 1999-04-28
*
* Arguments.....: toForm
* A reference to the form to activate when the
* thermometer is released.
*
* tlAllowCancel
* Specifies whether the user is allow to cancel the
* process. Default is False.
*
* Remarks.......:
*==============================================================================
LParameters toForm, tlAllowCancel
Local lnExtraHeight && Shrink by factor if the Cancel button is removed.
With This
*-- Save a reference to the calling form.
If (VarType(toForm) = 'O') And Lower(toForm.BaseClass) = 'form' Then
.CallingForm = toForm
Else
.CallingForm = .Null.
EndIf
*-- Remove Cancel biutton unless specifically told we can cancel the process.
If VarType(tlAllowCancel) <> 'L' Or Not tlAllowCancel Then
.RemoveObject('lblEscape')
.AllowCancel = .F.
lnExtraHeight = 20
.Shape1.Height = .Shape1.Height - lnExtraHeight
.Shape5.Height = .Shape5.Height - lnExtraHeight
.Shape6.Height = .Shape6.Height - lnExtraHeight
.Shape7.Height = .Shape7.Height - lnExtraHeight
.Shape8.Height = .Shape8.Height - lnExtraHeight
.Shape4.Top = .Shape4.Top - lnExtraHeight
.Shape9.Top = .Shape9.Top - lnExtraHeight
.Height = .Height - lnExtraHeight
Else
.AllowCancel = .T.
Keyboard '{SpaceBar}' Plain Clear
EndIf
*-- Reset values.
.Reset()
EndWith
Return ( DoDefault() )
ENDPROC
PROCEDURE Destroy
*==============================================================================
* Destroy
* -------
*
* Purpose.......: Activates the calling form.
* Author........: Daniel Rouleau - Metro Information Services
* Last Revision.: 1999-04-28
*
* Remarks.......:
*==============================================================================
Local loForm && Reference to the calling form.
Set Escape Off
loForm = This.CallingForm
If VarType(loForm) = 'O' Then
loForm.Activate()
EndIf
Return ( DoDefault() )
ENDPROC
ENDDEFINE