Я использую индикатор выполнения, созданный Эджазом Ахмедом (http://strugglingtoexcel.wordpress.com/), который прост в работе, прост в реализации и использовании в любом коде. Я люблю это! Моя проблема в том, что я перепробовал все, что нашел в Google / StackOverflow / MrExcel, который вы назвали, и все же я не могу заставить пользовательскую форму оставаться поверх всего, над чем работает VBA, открывая SAP, другой файл, PowerPoint. и др. c. Я хочу, чтобы загрузка шла поверх всех остальных окон / программ, открытых или открытых.
Внутри пользовательской формы он имеет следующий код:
'##########################################################################
'##########################################################################
'Module Name: ProgressBar
'Module Type: Class
'Purpose : Define a Progressbar Object
'##########################################################################
'Author : Ejaz Ahmed
'Email : StrugglingToExcel@outlook.com
'Website : http://strugglingtoexcel.wordpress.com/
'Date : 26 August 2014
'##########################################################################
'Module Options
'##########################################################################
Option Explicit
'##########################################################################
'##########################################################################
'Private Variables and Objects
'##########################################################################
'Private variables for storing the Main Properties of the Object
'Assigned to Caption Property of the Form.
Private cFormTitle As String
'Set to Ture if you'd like the Excel Status bar to also Show status.
Private cExcelStatusBar As Boolean
'Used to set to total number of actions the user wishes to perform.
Private cTotalActions As Long
'Remembers the number of completed actions. This variable can be overriddin
'by setting a number to the ActionNumber Property.
Private cActionNumber As Long
'Remembers the message that the user wishes to display in the Progressbar's
'Status bar.
Private cStatusMessage As String
'Remembers the Initial Width of the Progressbar Label.
Private cBarWidth As Double
'Remembers the Percentage of Actions Completed. Assigned to the Percent
'indicator in the ProgressBar form.
Private cPercentComplete As String
'Private Variables to Remember if certain properties were set
Private cFormShowStatus As Boolean
Private cTotalActionsSet As Boolean
'Private Variables to Handle the Colour Changes
Private cStartColourSet As Boolean
Private cEndColourSet As Boolean
Private cChangeColours As Boolean
Private cStartColour As XlRgbColor
Private cEndColour As XlRgbColor
Private cStartRed As Long, cEndRed As Long
Private cStartGreen As Long, cEndGreen As Long
Private cStartBlue As Long, cEndBlue As Long
'##########################################################################
'##########################################################################
'Error Numbers and Description:
'##########################################################################
' 1 - Set this Property before Running the Show Method.
' 2 - Set TotalActions Property First.
' 3 - Current Action number is greater than Total Actions.
' 4 - TotalActions cannot be changed after it has been set.
' 5 - Run the Show Method First
' 6 - Run the Complete Method only after all the actions have been completed.
' 7 - Progress Bar has already been Loaded.
' 8 - Set StartColour First.
'##########################################################################
'##########################################################################
'Class Events
'##########################################################################
'This Procedure is Run when the Form in Initiated
Private Sub UserForm_Initialize()
TopMostForm Me, True
'Set Default Values for all the Variables
cActionNumber = 0
cTotalActions = 0
cStatusMessage = "Pronto"
cFormTitle = "Atualizando Slides..."
cExcelStatusBar = False
cFormShowStatus = False
cTotalActionsSet = False
cPercentComplete = "0%"
cStartColourSet = False
cEndColourSet = False
cStartColour = rgbDodgerBlue
cChangeColours = False
Me.Title = cFormTitle
Me.StatusMessageBox.Caption = " " & cStatusMessage
Me.PercentIndicator.Caption = cPercentComplete
End Sub
'This Sub is run when the class is terminated
Private Sub UserForm_Terminate()
Application.StatusBar = False
If Not Me.PercentIndicator = "100%" Then
Application.ScreenUpdating = True
Application.EnableEvents = True
End
End If
End Sub
'##########################################################################
'Properties
'##########################################################################
'This Procedure is Executed when the Title Propoerty is Set
Public Property Let Title(value As String)
'Proceed only if the Form has not been loaded already
If cFormShowStatus Then
Err.Raise 1, cFormTitle, "Ajustar esse parâmetro antes de rodar o Show Metod."
Else
'Proceed if the user did not send a blank string
If Not value = vbNullString Then
'Initialize the private class variable
cFormTitle = value
'Update the Form's title if it has already been loaded
If Not Me Is Nothing Then
'Do Events makes sure the rest of your macro keeps running
DoEvents
Me.Caption = cFormTitle
End If
End If
End If
End Property
'This Procedure lets the User tries to access the Title Property.
Public Property Get Title() As String
Title = cFormTitle
End Property
'This Procedure is Executed when the ExcelStatusBar Propoerty is Set.
Public Property Let ExcelStatusBar(value As Boolean)
'Proceed only if the Form has not been loaded already
If cFormShowStatus Then
Err.Raise 1, cFormTitle, "Ajustar esse parâmetro antes de rodar o Show Metod."
Else
'Initialize the private class variable
cExcelStatusBar = value
'If the user wants to see the Status messages in Excel's
'Status bar also, make sure it is displayed.
If value Then
Application.DisplayStatusBar = True
End If
End If
End Property
'This Procedure lets the User tries to access the ExcelStatusBar Property.
Public Property Get ExcelStatusBar() As Boolean
ExcelStatusBar = cExcelStatusBar
End Property
'This Procedure is Executed when the TotalActions Propoerty is Set.
Public Property Let TotalActions(value As Long)
'Proceed only if the Form has not been loaded already
If cFormShowStatus Then
Err.Raise 1, cFormTitle, "Ajustar esse parâmetro antes de rodar o Show Metod."
Else
'Proceed if the User has not set the TotalActions property
'Else Display an error message
If cTotalActionsSet Then
Err.Raise 4, cFormTitle, "TotalActions cannot be changed after it has been set."
Else
'Initialize the private class variables
cTotalActions = value
'This is used to make sure the user does not change this later
cTotalActionsSet = True
End If
End If
End Property
'This Procedure lets the User tries to access the ActionNumber Property.
Public Property Get TotalActions() As Long
TotalActions = cTotalActions
End Property
'This Procedure is Executed when the StartColour Propoerty is Set.
Public Property Let StartColour(value As XlRgbColor)
'Proceed only if the Form has not been loaded already
If cFormShowStatus Then
Err.Raise 1, cFormTitle, "Set this Property before Running the Show Method."
Else
cStartColourSet = True
cStartColour = value
cStartRed = GetPrimaryColour(cStartColour, "R")
cStartGreen = GetPrimaryColour(cStartColour, "G")
cStartBlue = GetPrimaryColour(cStartColour, "B")
End If
End Property
'This Procedure is Executed when the EndColour Propoerty is Set.
Public Property Let EndColour(value As XlRgbColor)
'Proceed only if the Form has not been loaded already
If cFormShowStatus Then
Err.Raise 1, cFormTitle, "Set this Property before Running the Show Method."
Else
If Not cStartColourSet Then
Err.Raise 8, cFormTitle, "Set StartColour First."
Else
cEndColourSet = True
cEndColour = value
cEndRed = GetPrimaryColour(cEndColour, "R")
cEndGreen = GetPrimaryColour(cEndColour, "G")
cEndBlue = GetPrimaryColour(cEndColour, "B")
cChangeColours = Not CBool(cStartColour = cEndColour)
End If
End If
End Property
'This Procedure is Executed when the ActionNumber Propoerty is Set.
Public Property Let ActionNumber(value As Long)
'Update the private class variable
cActionNumber = value
'Call the Sub that Checks if the inputs are valid
'and refreshes the Progressbar
Call UpdateTheBar
End Property
'This Procedure lets the User tries to access the ActionNumber Property.
Public Property Get ActionNumber() As Long
ActionNumber = cActionNumber
End Property
'This Procedure is Executed when the ProgressStatusMessage Propoerty is Set.
Public Property Let StatusMessage(value As String)
'Update the private class variable
cStatusMessage = value
'Call the Sub that Checks if the inputs are valid
'and refreshes the Progressbar
Call UpdateTheBar
End Property
'This Procedure lets the User tries to access the ProgressStatusMessage Property.
Public Property Get StatusMessage() As String
StatusMessage = cStatusMessage
End Property
'##########################################################################
'Public Methods
'##########################################################################
Public Sub ShowBar()
If cFormShowStatus Then
Err.Raise 7, cFormTitle, "Progress Bar has already been Loaded."
Else
'Do Events makes sure the rest of your macro keeps running
DoEvents
'Remember the Initial Width of the ProgressBar
cBarWidth = Me.ProgressBar.Width
'Set the Width of the Progressbar to Zero
Me.ProgressBar.Width = 0
'Update the Title of the Form
Me.Caption = cFormTitle
'Initialize the Private Class Variable
cFormShowStatus = True
'Change the Colour of the Progressbar to StartColour
Me.ProgressBar.BackColor = cStartColour
Me.ProgressBox.BorderColor = cStartColour
'Show the Form
Me.Show
'Repaint the Form
Me.Repaint
End If
End Sub
'NextAction:Let the Progressbar know an action has been completed. I recommend using this
'method over manually overriding the ProgressStatusMessage and CurrentAction Properties
Public Sub NextAction(Optional ByVal ProgressStatusMessage As String, _
Optional ByVal ShowActionCount As Boolean = True)
cActionNumber = cActionNumber + 1
If ShowActionCount Then
cStatusMessage = "Ação " & cActionNumber & " de " _
& cTotalActions & " | " & ProgressStatusMessage
Else
cStatusMessage = ProgressStatusMessage
End If
Call UpdateTheBar
End Sub
'Complete: This Method Can be used to Let the User Know that the Run Has
'been Completed. It Changes the statues message to the message specified
'and releases the control this object has over the excel status bar.
Public Sub Complete(Optional ByVal WaitForSeconds As Long = 0, _
Optional ByVal Prompt As String = "Completo")
Dim Counter As Long
'Proceed if the ProgressBar has already been loaded
'Display an error message otherwise
If cFormShowStatus Then
'Display an error message if the CurrentAction numeber is lesser than the Number of
'TotalActions. Otherwise, Change the Status Message to the desired message.
If cActionNumber < cTotalActions Then
Err.Raise 6, cFormTitle, _
"Run the Complete Method only after all the actions have been completed."
Else
'Release control over Excel's status bar
If cExcelStatusBar Then
Application.StatusBar = False
End If
If WaitForSeconds > 0 Then
For Counter = WaitForSeconds To 1 Step -1
DoEvents
Me.StatusMessageBox.Caption = " " & Prompt & _
" | Esta janela será fechada em " & Counter & " " & _
IIf(Counter = 1, "segundos.", "ssegundos.")
Application.Wait (Now() + TimeValue("00:00:01"))
Next Counter
Call Terminate
Else
'Do Events makes sure the rest of your macro keeps running
DoEvents
'Update the Status Message
Me.StatusMessageBox.Caption = " " & Prompt
End If
End If
Else
Err.Raise 5, cFormTitle, "Run the Show Method First"
End If
End Sub
'Terminate: Let the user Terminate Manually if they prefer
Public Sub Terminate()
'Terminate the Form if it is already loaded. Display an Error Message
'Otherwise
If cFormShowStatus Then
'If the Form is Loaded, Unload it
If cFormShowStatus Then
Me.Hide
cFormShowStatus = False
cTotalActionsSet = False
cActionNumber = 0
cTotalActions = 0
End If
'Return the Appliation StatusBar control to Excel
If cExcelStatusBar Then
Application.StatusBar = False
End If
Else
Err.Raise 5, cFormTitle, "Run the Show Method First"
End If
End Sub
'##########################################################################
'##########################################################################
'Private Subs needed by this Class
'##########################################################################
Private Sub UpdateTheBar()
'Proceed only if the user has already set the TotalActions property
'Else Display an error message
If cTotalActionsSet Then
'Proceed only if the CurrentAction number is lesser than or equal to
'the Total Actions
If cActionNumber > cTotalActions Then
Err.Raise 3, cFormTitle, _
"Current Action number is greater than Total Actions."
Else
'Proceed only if the Form has already been Showed. Display an
'error message otherwise
If cFormShowStatus Then
'Call the Procedure that Updates the Bar
Call UpdateProgress
Else
Err.Raise 5, cFormTitle, "Run the Show Method First"
End If
End If
Else
Err.Raise 2, cFormTitle, "Set TotalActions Property First."
End If
End Sub
Private Sub UpdateProgress()
'Declare Sub Level Variables
Dim FractionComplete As Double
Dim ProgressPercent As String
Dim BarWidth As Double
Dim BarColour As XlRgbColor
'Initialize Variables
FractionComplete = cActionNumber / cTotalActions
BarWidth = cBarWidth * FractionComplete
cPercentComplete = Format(FractionComplete * 100, "0") & "%"
'Do Events makes sure the rest of your macro keeps running
DoEvents
'Change the Width of the Label
Me.ProgressBar.Width = BarWidth
'Update the Percent Indicator
Me.PercentIndicator.Caption = cPercentComplete
'Change the Colour of the Progressbar if needed
If cChangeColours Then
BarColour = RGB( _
cStartRed + (cEndRed - cStartRed) * FractionComplete, _
cStartGreen + (cEndGreen - cStartGreen) * FractionComplete, _
cStartBlue + (cEndBlue - cStartBlue) * FractionComplete)
Me.ProgressBar.BackColor = BarColour
End If
'Set the Status Bar Message
Me.StatusMessageBox.Caption = " " & cStatusMessage
'Update Excel's Status Bar if needed
If cExcelStatusBar Then
Application.StatusBar = ProgressText(cActionNumber, cTotalActions) & _
" | " & cPercentComplete & " | " & cStatusMessage
End If
'Repaint the Form
Me.Repaint
End Sub
'##########################################################################
'##########################################################################
'Private Functions Needed by this Class Module
'##########################################################################
'##########################################################################
'GetPrimaryColour: Function used to extract the numerical value of each
'of the promary colours in a colour. Every colour is a mixture of three
'primary colours: Red, Blue and Green. In Excel, colours are represented
'as Hexadecimal Numbers of the Format "00BBGGRR", but they are stored as
'Decimal numbers. This function converts the Long Variable into Hexadicamal
'first, and then extracts the two characters that represent the primary
'colour and then converts it back to long.
'##########################################################################
'Author : Ejaz Ahmed
'Email : StrugglingToExcel@outlook.com
'Website : http://strugglingtoexcel.wordpress.com/
'Date : 26 August 2014
'##########################################################################
Private Function GetPrimaryColour(ByVal WhichColour As XlRgbColor, _
ByVal RedBlueGreen As String) As Long
'Declate Function Level Variables
Dim HexString As String
'Convert Decimal to HexaDecimal
HexString = CStr(Hex(WhichColour))
'Prefix 0's so the string is always 8 Characters in length
HexString = String(8 - Len(HexString), "0") & HexString
'Extract the Red Blue or Green part of the Hexadecimal Number
'stored in HexString. Remember, that we need to prefix "&H"
'to tell excel that the number is Hexadecimal, so we can use
'the cLng function to convert it into the Decimal System Later.
Select Case StrConv(RedBlueGreen, vbUpperCase)
Case "R"
HexString = "&H" & Mid(HexString, 7, 2)
Case "G"
HexString = "&H" & Mid(HexString, 5, 2)
Case "B"
HexString = "&H" & Mid(HexString, 3, 2)
Case Else
HexString = "-100"
End Select
'Return the colour value in the 0 to 225 format.
GetPrimaryColour = CLng(HexString)
End Function
'##########################################################################
'ProgressText: Function to generate the Text, using unicode characters, to
'show a progress bar on Excel's Status Bar
'##########################################################################
'Author : Ejaz Ahmed
'Email : StrugglingToExcel@outlook.com
'Website : http://strugglingtoexcel.wordpress.com/
'Date : 22 September 2014
'##########################################################################
Function ProgressText(ByVal ActionNumber As Long, _
ByVal TotalActions As Long, _
Optional ByVal BarLength As Long = 15)
Dim BarComplete As Long
Dim BarInComplete As Long
Dim BarChar As String
Dim SpaceChar As String
Dim TempString As String
BarChar = ChrW(&H2589)
SpaceChar = ChrW(&H2000)
BarLength = Round(BarLength / 2, 0) * 2
BarComplete = Fix((ActionNumber * BarLength) / TotalActions)
BarInComplete = BarLength - BarComplete
ProgressText = String(BarComplete, BarChar) & String(BarInComplete, SpaceChar)
End Function
Внутри модуля, который я вызываю Форма, у меня есть это:
'Declare the ProgressBar Object
Dim MyProgressbar As ProgressBar
'Initialize a New Instance of the Progressbars
Set MyProgressbar = New ProgressBar
With MyProgressbar
'Set the Title
.Title = "Aguarde " & Application.UserName & ", rodando a captação das " & Time() & "!"
'Set this to true if you want to update
'Excel's Status Bar Also
.ExcelStatusBar = True
'Set the colour of the bar in the Beginning
.StartColour = rgbMediumSeaGreen
'Set the colour of the bar at the end
.EndColour = rgbGreen
End With
MyProgressbar.TotalActions = 10
MyProgressbar.ShowBar
Для каждого действия, которое я хочу показать прогресс, я использую:
'Progress Bar
MyProgressbar.NextAction "Colando a Captação Anterior"
Сумма, установленная на Всего действий, должна быть равна сумме NextAction Я собираюсь использовать внутри кода отслеживание прогресса.
После того, как работа завершена, есть небольшой код, чтобы закрыть его:
'ProgressBar
MyProgressbar.Complete 3
Спасибо!