Nova MsgBox

Algo que sempre me incomodou foi a permanência do ponteiro de ocupado (famosa ampulheta) mesmo quando uma mensagem está sendo exibida e aguardando uma ação do usuário. Se a mensagem estiver encoberta por outra tela então talvez o usuário pode passar um bom tempo aguardando e achando que o programa ainda está ocupado.

Para livrar-me desse incômodo, resolvi criar uma função que desativa o ponteiro de ocupado enquanto uma mensagem está sendo exibida. Também aproveitei para unir com a função de mensagem temporizada (MsgBoxTimer) e a função que deixa uma parte do texto da mensagem em negrito (FormattedMsgBox), ambas disponibilizadas aqui no fórum.

Código:

#If VBA7 Then
    Declare PtrSafe Function MessageBeep Lib "user32" Alias "MessageBeep" (ByVal wType As Long) As Long
#Else
    Declare Function MessageBeep Lib "user32" (ByVal wType As Long) As Long
#End If

Public Function fncMsgBox(Optional ByVal strTextoDestaque As String, _
                          Optional ByVal strMensagem As String, _
                          Optional ByVal vbEstilo As VbMsgBoxStyle = vbOKOnly, _
                          Optional ByVal strTitulo As String = "", _
                          Optional ByVal bytTempoEmSegundos As Byte = 0) _
                          As VbMsgBoxResult
'---------------------------------------------------------------------------------------
' Autor     : DamascenoJr. (contato@damascenojr.com.br)
' Data      : 03/05/2020
' Propósito : Emitir mensagem garantindo a desativação do ponteiro ampulheta.
'---------------------------------------------------------------------------------------

    Dim bytBkpPonteiro  As Byte
    Dim vbResultado     As VbMsgBoxResult
    Dim vbEstiloTemp    As VbMsgBoxStyle
    
    bytBkpPonteiro = Screen.MousePointer
    Screen.MousePointer = 0

    If ((bytTempoEmSegundos > 0) Or (InStr(strTextoDestaque, "@") > 0)) And (strTextoDestaque <> "") Then
        strMensagem = strTextoDestaque & vbNewLine & vbNewLine & strMensagem
        strTextoDestaque = ""
    End If
    
    If strTextoDestaque <> "" Then
    
        strMensagem = strTextoDestaque & "@@" & strMensagem
        strMensagem = Replace(strMensagem, """", """""")
        strTitulo = Replace(strTitulo, """", """""")

        GoTo beep
continua1:
        vbResultado = Eval("MsgBox(""" & strMensagem & """," & vbEstilo & ",""" & strTitulo & " "")")
        
    Else
    
        GoTo beep
continua2:

        If bytTempoEmSegundos > 0 Then
            vbResultado = CreateObject("WScript.Shell").PopUp(strMensagem, bytTempoEmSegundos, strTitulo, vbEstilo)
        Else
            vbResultado = MsgBox(strMensagem, vbEstilo, strTitulo)
        End If

    End If
    
    Screen.MousePointer = bytBkpPonteiro
    fncMsgBox = vbResultado
    Exit Function

beep:
    vbEstiloTemp = vbEstilo

    'modalidade da caixa de mensagem
    Select Case vbEstiloTemp
        Case Is >= vbMsgBoxRtlReading: vbEstiloTemp = vbEstiloTemp - vbMsgBoxRtlReading
        Case Is >= vbMsgBoxRight: vbEstiloTemp = vbEstiloTemp - vbMsgBoxRight
        Case Is >= vbMsgBoxSetForeground: vbEstiloTemp = vbEstiloTemp - vbMsgBoxSetForeground
        Case Is >= vbMsgBoxHelpButton: vbEstiloTemp = vbEstiloTemp - vbMsgBoxHelpButton
        Case Is >= vbSystemModal: vbEstiloTemp = vbEstiloTemp - vbSystemModal
    End Select

    'botão padrão
    Select Case vbEstiloTemp
        Case Is >= vbDefaultButton4: vbEstiloTemp = vbEstiloTemp - vbDefaultButton4
        Case Is >= vbDefaultButton3: vbEstiloTemp = vbEstiloTemp - vbDefaultButton3
        Case Is >= vbDefaultButton2: vbEstiloTemp = vbEstiloTemp - vbDefaultButton2
    End Select

    If strTextoDestaque = "" Then
        If Eval(vbEstiloTemp & " between " & vbQuestion & " and " & (vbQuestion + 5)) Then Call beep 'MessageBeep(vbQuestion)
        GoTo continua2
    Else
        Select Case vbEstiloTemp
            Case Is >= vbInformation: Call MessageBeep(vbInformation)
            Case Is >= vbExclamation: Call MessageBeep(vbExclamation)
            Case Is >= vbQuestion: Call beep 'MessageBeep(vbQuestion)
            Case Is >= vbCritical: Call MessageBeep(vbCritical)
            Case Else: Call MessageBeep(vbOKOnly)
        End Select
        GoTo continua1
    End If

End Function

Quem usar, basta trocar

Código:

MsgBox "Olá"

ou

Código:

Call MsgBox("Olá")

por

Código:

fncMsgBox , "Olá"

ou

Código:

Call fncMsgBox(, "Olá")

Mensagem durando 3 segundos

Código:

fncMsgBox , "Olá", , , 3

ou

Código:

Call fncMsgBox(, "Olá", , , 3)

Mensagem com texto formatado

Código:

fncMsgBox "Parte negritada opcional.", "Parte normal.", vbInformation, "Título"

ou

Código:

Call fncMsgBox("Parte negritada opcional.", "Parte normal.", vbInformation, "Título")

Resultado

DamascenoJr,

Testei aqui e deu certo.

Obrigado.

Agradeço o retorno.

Função atualizada: garantia do beep diferenciado para mensagens do tipo vbCritical com textos negritados.

Muito bom mestre obrigado!