MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

Obrigado

Administração do MaximoAccess

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    Nova MsgBox

    DamascenoJr.
    DamascenoJr.
    Moderador
    Moderador

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 1851
    Registrado : 22/11/2016

    Nova MsgBox Empty Nova MsgBox

    Mensagem  DamascenoJr. em 31/3/2020, 02:32

    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:
    Public Function fncMensagem(Optional ByVal strTextoDestaque As String, _
                                Optional ByVal strMensagem As String, _
                                Optional vbEstilo As VbMsgBoxStyle = vbOKOnly, _
                                Optional ByVal strTitulo As String = "", _
                                Optional bytTempoEmSegundos As Byte = 0) _
                                As VbMsgBoxResult
    '---------------------------------------------------------------------------------------
    ' Procedimento : fncMensagem
    ' Autor        : DamascenoJr. (contato@damascenojr.com.br)
    ' Data         : 10/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, """", """""")
            Call Beep
            vbResultado = Eval("MsgBox(""" & strMensagem & """," & vbEstilo & ",""" & strTitulo & " "")")
            
        Else
        
            GoTo beepSeQuestion
    continua:

            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
        fncMensagem = vbResultado
        Exit Function

    beepSeQuestion:
        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 Eval(vbEstiloTemp & " between 32 and 37") Then Call Beep
        GoTo continua

    End Function

    Quem usar, basta trocar
    Código:
    MsgBox "Olá"
    ou
    Código:
    Call MsgBox("Olá")

    por
    Código:
    fncMensagem , "Olá"
    ou
    Código:
    Call fncMensagem(, "Olá")

    Mensagem durando 3 segundos
    Código:
    fncMensagem , "Olá", , , 3
    ou
    Código:
    Call fncMensagem(, "Olá", , , 3)

    Mensagem com texto formatado
    Código:
    fncMensagem "Parte negritada opcional.", "Parte normal.", vbInformation, "Título"
    ou
    Código:
    Call fncMensagem("Parte negritada opcional.", "Parte normal.", vbInformation, "Título")
    Resultado
    Nova MsgBox Msgbox10


    Última edição por DamascenoJr. em 11/5/2020, 12:14, editado 5 vez(es)
    avatar
    Ismael Silva
    Super Avançado
    Super Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 610
    Registrado : 11/12/2017

    Nova MsgBox Empty Re: Nova MsgBox

    Mensagem  Ismael Silva em 19/4/2020, 16:31

    DamascenoJr,

    Testei aqui e deu certo.

    Obrigado.
    DamascenoJr.
    DamascenoJr.
    Moderador
    Moderador

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 1851
    Registrado : 22/11/2016

    Nova MsgBox Empty Re: Nova MsgBox

    Mensagem  DamascenoJr. em 19/4/2020, 18:32

    Agradeço o retorno.


    .................................................................................
    Ajude-se a ser ajudado, anexe seu projeto.
    Sempre tente entender o código,
    não somente copie e cole.
    Positive as mensagens que achar útil clicando no '+' no canto superior direito delas.
    DamascenoJr.
    DamascenoJr.
    Moderador
    Moderador

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 1851
    Registrado : 22/11/2016

    Nova MsgBox Empty Re: Nova MsgBox

    Mensagem  DamascenoJr. em 11/5/2020, 06:23

    Função atualizada.


    .................................................................................
    Ajude-se a ser ajudado, anexe seu projeto.
    Sempre tente entender o código,
    não somente copie e cole.
    Positive as mensagens que achar útil clicando no '+' no canto superior direito delas.

      Data/hora atual: 25/5/2020, 22:37