VBA - Mensagem para fazer o usuário esperar

Maio 2017


Pequeno aplicativo para exibir uma mensagem de espera, quando o processo é demorado.
E, em anexo, retirar o quadro do UserForm

Introdução

Disponibilidades: mensagem "corrida" e um ícone "animado".
  • Mensagem e ícone fixos

  • Mensagem "corrida" e ícone móvel



Todas as propriedades são configuráveis.
  • Dois comandos...
    • Iniciar > ampulheta. Show vbModeless
    • Stop > Animar = False
  • Três propriedades...
    • O texto corrido > TxtLab = "O texto corrido" (por exemplo)
    • Velocidade da imagem > VelocidadeS = 3500 por padrão = 3500
    • Velocidade do texto > VelocidadeT = 1000 por padrão = 1000
    • Impedir a rolagem do ícone > VelocidadeS = -1
    • Impedir a rolagem do texto > VelocidadeT = -1


Para alterar a imagem, é preciso ter uma imagem GIF decomposta e
alterar ou adicionar uma "ListImage" com suas imagens.

Também é preciso mudar o "Const NbImage" com base na quantidade de
imagens que haverá em sua "ListImage".

UserForm

No UserForm nomear Ampulheta
Option Explicit   
Dim TempsS As Long
Dim TempsT As Long
Dim NumImg As Byte
Dim LG3 As Integer
Dim Deb As Integer

Private Sub UserForm_Activate()
Animation
End Sub

Private Sub UserForm_Inicialize()
'------------------------------------------------------------------
'Os dados por padrão
If TxtLab = "" Then
TxtLab = "Processamento em curso, favor esperar..."
End If
If VitesseS = 0 Then
VitesseS = 3500
End If
If VitesseT = 0 Then
VitesseT = 1000
End If
'------------------------------------------------------------------
OteTitleBarre Me.Caption, False
Me.Height = 43
NumImg = 1
ImgAmpulheta.Picture = ListAmpulheta.ListImagens(NumImg).Picture
LabAmpulheta.Caption = TxtLab
LG3 = LabAmpulheta.Width
Animar = True

End Sub
Sub Animation()
While Animer
If VelocidadeS <> -1 Then
TempoS = TempoS + 1
If TempoS = VelocidadeS Then
TempoS = 0
NumImg = NumImg + 1: If NumImg > NbImage Then NumImg = 1
ImgAmpulheta.Picture = ListAmpulheta.ListImagens(NumImg).Picture
End If
End If
If VelocidadeT <> -1 Then
TempoT = TempoT + 1
If TempsT = VelocidadeT Then
TempoT = 0
If Abs(Deb) > LG3 Then Deb = Frame1.Width
LabAmpulheta.Left = Deb
Deb = Deb - 1
End If
End If
DoEvents
Wend
Unload Me
End Sub

Módulo público

Option Explicit   

Coloque FALSE para fechar o UserForm
Public Animer As Boolean

'O texto que rola no UserForm,
Public TxtLab As String

'Para adaptar a velocidade de rolagem da ampulheta
Public VelocidadeS As Integer

'Para adaptar a velocidade de rolagem do texto
Public VelocidadeT As Integer

Public Const NbImage = 12

'----------------------------------------------------------------
'Para retirar a barra de título do UserForm
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Const GWL_STYLE = (-16)
Const WS_CAPTION = &HC00000
Const SWP_FRAMECHANGED = &H20

Public Declare Function FindWindowA Lib "user32" _
As Long

Public Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long

Public Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Public Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long

Public Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, _
ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) As Long
Public Type POINTAPI
X As Long
Y As Long
End Type
Public m_CursorPos As POINTAPI
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Public Afficher As Boolean

Sub OteTitleBarre(stCaption As String, pbVisible As Boolean)
Dim vrWin As RECT
Dim style As Long
Dim lHwnd As Long
'- Busca do « handle » da janela por seu « Caption »
lHwnd = FindWindowA(vbNullString, stCaption)
If lHwnd = 0 Then
MsgBox "Handle de " & stCaption & "Não foi encontrado", vbCritical
Exit Sub
End If

GetWindowRect lHwnd, vrWin
style = GetWindowLong(lHwnd, GWL_STYLE)
If pbVisible Then
SetWindowLong lHwnd, GWL_STYLE, style Or WS_CAPTION
Else
SetWindowLong lHwnd, GWL_STYLE, style And Not WS_CAPTION
End If
SetWindowPos lHwnd, 0, vrWin.Left, vrWin.Top, vrWin.Right - vrWin.Left, _
vrWin.Bottom - vrWin.Top, SWP_FRAMECHANGED
End Sub

Exemplo de uso

Em uma planilha Excel, dois botões.
No módulo da planilha.
Private Sub CommandButton1_Click()   
'Iniciar
Ampulheta.Show vbModeless
End Sub

Private Sub CommandButton2_Click()
'Terminar
Animar = False
End Sub

Mais informações

Ampulheta no Excel

Veja também

Artigo original publicado por . Tradução feita por pintuda. Última modificação: 12 de outubro de 2016 às 21:13 por ninha25.
Este documento, intitulado 'VBA - Mensagem para fazer o usuário esperar', está disponível sob a licença Creative Commons. Você pode copiar e/ou modificar o conteúdo desta página com base nas condições estipuladas pela licença. Não se esqueça de creditar o CCM (br.ccm.net) ao utilizar este artigo.