MaximoAccess

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

Obrigado

Administração do MaximoAccess

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

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 : 2455
    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:
    #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:
    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 22/11/2020, 23:53, editado 6 vez(es)

    Eduardo Augusto gosta desta mensagem

    avatar
    Ismael Silva
    Super Avançado
    Super Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 662
    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 : 2455
    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 : 2455
    Registrado : 22/11/2016

    Nova MsgBox Empty Re: Nova MsgBox

    Mensagem  DamascenoJr. em 23/11/2020, 00:01

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


    .................................................................................
    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.
    Fernando Bueno
    Fernando Bueno
    Developer
    Developer

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 2097
    Registrado : 13/04/2012

    Nova MsgBox Empty Re: Nova MsgBox

    Mensagem  Fernando Bueno em 27/11/2020, 21:45

    Muito bom mestre obrigado!


    .................................................................................
    Um abraço
    Fernando Bueno


    O aumento do conhecimento é como uma esfera dilatando-se no espaço
    quanto maior a nossa compreensão,
    maior o nosso contacto com o desconhecido
    Nova MsgBox 16rzeq

      Data/hora atual: 2/12/2020, 13:32