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

    MsgBox personalizada

    leoni_dias
    leoni_dias
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 180
    Registrado : 14/08/2011

    MsgBox personalizada Empty MsgBox personalizada

    Mensagem  leoni_dias em 13/5/2013, 12:30

    Bom dia, amigos e mestres.

    Em contínua busca pela MsgBox modal perfeita, encontrei esse código que me atendeu perfeitamente.
    Além de mudar os textos dos botões ao meu gosto, muda os ícones.
    Espero que sirva a todos.

    '-------Início do código para um módulo qualquer------------------

    '*********************************************************
    ' Código escrito originalmente por Juan M Afán de Ribera.
    ' Estás autorizado a utilizarlo dentro de una aplicación
    ' siempre que esta nota de autor permanezca inalterada.
    ' En el caso de querer publicarlo en una página Web,
    ' por favor, contactar con el autor en
    '
    ' accessvba@ya.com
    '
    ' Este código se brinda por cortesía de
    ' Juan M. Afán de Ribera
    '
    '---------------------------------------------------------
    ' Nombre : MsgBoxEx
    ' Creación : 18/11/2004
    ' Autor : Juan M. Afán de Ribera
    ' Propósito : Extender las posibilidades del MsgBox de
    ' Visual Basic, pudiendo mostrar iconos
    ' personalizados en la barra de título, iconos
    ' y cursores animados en la ventana de cliente,
    ' así como cambiar el texto de los botones.
    '
    '*********************************************************
    Option Compare Database
    Option Explicit

    ' Función que establece el texto de una ventana
    Private Declare Function SetWindowText Lib "user32" _
    Alias "SetWindowTextA" _
    (ByVal hwnd As Long, _
    ByVal lpString As String) As Long

    ' Función que devuelve el manipulador de una ventana
    Private Declare Function GetWindow Lib "user32" _
    (ByVal hwnd As Long, _
    ByVal wCmd As Long) As Long

    ' Función que devuelve el nombre de clase de una ventana
    Private Declare Function GetClassName Lib "user32" _
    Alias "GetClassNameA" _
    (ByVal hwnd As Long, _
    ByVal lpClassName As String, _
    ByVal nMaxCount As Long) As Long

    ' Función que devuelve el ID del control de un cuadro de diálogo
    Private Declare Function GetDlgCtrlID Lib "user32" _
    (ByVal hwnd As Long) As Long

    ' Función que envía un mensaje al control de un cuadro de diálogo
    Private Declare Function SendDlgItemMessage Lib "user32" _
    Alias "SendDlgItemMessageA" _
    (ByVal hDlg As Long, _
    ByVal nIDDlgItem As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Any) As Long

    ' Función que devuelve el manipulador de una imagen
    Private Declare Function LoadImage Lib "user32" _
    Alias "LoadImageA" _
    (ByVal hInst As Long, _
    ByVal lpsz As String, _
    ByVal un1 As Long, _
    ByVal n1 As Long, _
    ByVal n2 As Long, _
    ByVal un2 As Long) As Long

    ' Función que envía un mensaje a una ventana
    Private Declare Function SendMessage Lib "user32" _
    Alias "SendMessageA" _
    (ByVal hwnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    lParam As Any) As Long

    ' Función que devuelve el manipulador de la ventana activa en ese momento
    Private Declare Function GetForegroundWindow Lib "user32" () As Long

    ' Función que devuelve información de una ventana
    Private Declare Function GetWindowLong Lib "user32" _
    Alias "GetWindowLongA" _
    (ByVal hwnd As Long, _
    ByVal nIndex As Long) As Long

    ' Función que crea un Timer de sistema
    Private Declare Function SetTimer Lib "user32" _
    (ByVal hwnd As Long, _
    ByVal nIDEvent As Long, _
    ByVal uElapse As Long, _
    ByVal lpTimerFunc As Long) As Long

    ' Función que destruye un timer de sistema
    Private Declare Function KillTimer Lib "user32" _
    (ByVal hwnd As Long, _
    ByVal nIDEvent As Long) As Long

    ' constante para escribir un texto
    Private Const WM_SETTEXT = &HC
    ' constante para establecer un icono
    Private Const WM_SETICON = &H80
    ' constante para establecer la imagen de un control Static
    Private Const STM_SETIMAGE = &H172
    ' constante que indica que se llama a una imagen tipo icono
    Private Const IMAGE_ICON = 1
    ' constante que indica que la imagen proviene de un fichero
    Private Const LR_LOADFROMFILE = &H10
    ' constante para llamar a una ventana hija
    Private Const GW_CHILD = 5&
    ' constante para llamar a la siguiente ventana
    Private Const GW_HWNDNEXT = 2&
    ' constante de estilo para poder contener un icono
    Private Const SS_ICON = &H3&
    ' constante para devolver información del estilo de una ventana
    Private Const GWL_STYLE = (-16)

    ' variables globales de MsgBoxEx
    Private hMsgBox As Long
    Private hIconWindow As Long
    Private hIconBar As Long
    Private Title2 As String
    Private ButtonsText(1 To 7) As String

    Public Function MsgBoxEx( _
    Prompt, _
    Optional buttons As VbMsgBoxStyle = vbOKOnly, _
    Optional Title, _
    Optional HelpFile, _
    Optional Context, _
    Optional IconBar As String, _
    Optional IconWindow As String, _
    Optional BtOk As String, _
    Optional BtCancel As String, _
    Optional BtAbort As String, _
    Optional BtRetry As String, _
    Optional BtIgnore As String, _
    Optional BtYes As String, _
    Optional BtNo As String) As VbMsgBoxResult

    If hMsgBox = 0 Then
    ButtonsText(1) = BtOk ' Texto botón Ok - IDControl = vbOk = 1
    ButtonsText(2) = BtCancel ' Texto botón Cancelar/Aceptar - IDControl = vbCancel = 2
    ButtonsText(3) = BtAbort ' Texto botón Anular - IDControl = vbAbort = 3
    ButtonsText(4) = BtRetry ' Texto botón Reintentar - IDControl = vbRetry = 4
    ButtonsText(5) = BtIgnore ' Texto botón Ignorar - IDControl = vbIgnore = 5
    ButtonsText(6) = BtYes ' Texto botón Sí - IDControl = vbYes = 6
    ButtonsText(7) = BtNo ' Texto botón No - IDControl = vbNo = 7

    ' si se ha indicado un icono para la barra de título
    If IconBar <> "" Then
    ' se obtiene un manipulador de la imagen
    hIconBar = hIcon(IconBar, 16&)
    ' añadimos unos cuantos blancos para hacer sitio
    ' en la barra de título para el icono, pues el
    ' MsgBox no está originalmente preparado para ello
    Title2 = Title
    Title = Title & String(6, Chr(32))
    Else
    ' si no, ponemos posibles valores anteriores de hIconBar a 0
    hIconBar = 0
    End If

    ' necesitamos comprobar que se puede cargar la imagen
    ' correspondiente a la ventana cliente del MsgBox, para
    ' configurar el espacio correspondiente al icono. Si la
    ' ruta fuera incorrecta y no se comprobara, quedaría un
    ' espacio en blanco correspondiente al control Static
    ' que contiene estos iconos.

    If IconWindow <> "" Then
    hIconWindow = hIcon(IconWindow, 32&)
    ' si se ha podido cargar la imagen, anulamos cualquier
    ' llamada del usuario a los iconos de mensaje
    ' predeterminados ...
    If hIconWindow Then
    If (buttons And vbCritical) = vbCritical Then
    buttons = buttons - vbCritical
    ElseIf (buttons And vbExclamation) = vbExclamation Then
    buttons = buttons - vbExclamation
    ElseIf (buttons And vbInformation) = vbInformation Then
    buttons = buttons - vbInformation
    ElseIf (buttons And vbQuestion) = vbQuestion Then
    buttons = buttons - vbQuestion
    End If
    ' y ponemos nosotros uno cualquiera de ellos.
    ' De esta manera aseguramos que existirá un control
    ' Static para contener nuestro icono/imagen personalizado.
    buttons = buttons + vbCritical
    End If
    Else
    hIconWindow = 0
    End If

    ' Creamos un timer que se ejecutará a la décima de segundo
    Call SetTimer(hWndAccessApp, 0&, 10, AddressOf TimerProc)
    ' llamamos al MsgBox de manera normal
    On Error GoTo AnularTimer
    ' llamamos al MsgBox de VBA con los parámetros normales
    MsgBoxEx = MsgBox(Prompt, buttons, Title, HelpFile, Context)
    End If

    Exit Function

    AnularTimer:
    ' si ha habido algún error, se cancela la operación
    Call KillTimer(hWndAccessApp, 0&)
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description

    End Function

    ' Esta función se ejecutará una décima de segundo después de llamar
    ' al MsgBox (en modo asíncrono) y "capturará" el cuadro de diálogo
    ' y sus controles para poder manipularlos
    '
    Private Sub TimerProc( _
    ByVal hwnd As Long, _
    ByVal uMsg As Long, _
    ByVal idEvent As Long, _
    ByVal dwTime As Long)

    Dim cnt As Long

    ' capturamos el manipulador del MsgBox
    hMsgBox = GetForegroundWindow

    ' si se ha indicado un icono para la barra de título
    If hIconBar Then
    ' se carga
    Call SendMessage(hMsgBox, WM_SETICON, 0&, ByVal hIconBar)
    Call SetWindowText(hMsgBox, Title2)
    End If

    ' si se ha indicado un icono para la ventana de cliente
    If hIconWindow Then
    ' se carga - CtrlId devolverá el ID del control que contiene el icono
    Call SendDlgItemMessage(hMsgBox, CtrlId, STM_SETIMAGE, IMAGE_ICON, hIconWindow)
    End If

    ' ponemos el texto a los botones (si lo hay)
    For cnt = 1 To 7
    ' si se ha indicado un texto para alguno de los botones
    If ButtonsText(cnt) <> "" Then
    ' se cambia su texto.
    ' cnt = número de ID de control de cada uno de los botones
    ' dentro del cuadro de diálogo
    Call SendDlgItemMessage(hMsgBox, cnt, WM_SETTEXT, 0&, ButtonsText(cnt))
    End If
    Next

    ' anulamos el timer, ya que sólo se ejecutará una vez (de momento)
    Call KillTimer(hWndAccessApp, 0&)
    hMsgBox = 0

    End Sub

    ' función que devuelve el manipulador de una imagen
    ' para este código me he basado en el ejemplo que amablemente proporciona
    ' Klaus Probst en http://www.mvps.org/access/api/api0043.htm
    '
    Function hIcon(IconPath As String, IconSize As Long) As Long
    hIcon = LoadImage(0&, IconPath, IMAGE_ICON, IconSize, IconSize, LR_LOADFROMFILE)
    End Function

    ' Esta función devuelve el ID del control Static que contiene los iconos
    ' de la ventana cliente del MsgBox.
    ' El ID de este control, junto con el ID del control Static que contiene
    ' el texto del MsgBox varía entre versiones, tanto de Access como del sistema
    ' operativo, así que he tenido que crear una función que lo localizara.
    ' Se le puede localizar, primero por el tipo de control (Static) y
    ' después por el estilo SS_ICON, que es un estilo (atributo) que permite al
    ' control contener un icono y expandirse según su tamaño
    '
    Function CtrlId() As Long
    Dim buffer As String * 100
    Dim hwnd As Long
    Dim CurStyle As Long

    ' obtenemos la primera ventana hija del MsgBox
    hwnd = GetWindow(hMsgBox, GW_CHILD)
    Do While hwnd
    ' obtenemos el nombre de la clase de ventana
    GetClassName hwnd, buffer, 100
    ' si es de la clase Static
    If UCase(Left(buffer, 6)) = "STATIC" Then
    CurStyle = GetWindowLong(hwnd, GWL_STYLE)
    ' si tiene el estilo SS_ICON
    If (CurStyle And SS_ICON) = SS_ICON Then
    ' obtenemos el número de ID del control
    CtrlId = GetDlgCtrlID(hwnd)
    Exit Function
    End If
    End If
    hwnd = GetWindow(hwnd, GW_HWNDNEXT)
    Loop

    End Function


    '-------Final do código para um módulo qualquer------------------

    '-------Início da chamada da MsgBoxPessoal------------------

    Dim PerText As String
    PerText = MsgBoxEx("Qual o Processo a ser utilizado?", _
    vbYesNoCancel, _
    "Projeto Teen's", _
    , _
    , _
    "Caminho para o ícone", _
    "Caminho para o ícone", _
    "oK", _ '--------Botão VbOk
    "Cancelar", _ '--------Botão VbCancel
    "Abortar", _
    "Repetir", _
    "Ignorar", _
    "Atualizar", _ '--------Botão VbYes
    "Novo registro")'--------Botão VbNo

    '---------- Mude o texto para os botões


    Select Case PerText
    Case "7" '------Botão VbNo
    '----Aqui o código

    Case "6" '------Botão VbYes------ Botões numerados no módulo
    '----Aqui o código

    End Select

    '-------Final da chamada da MsgBoxPessoal------------------
    JPaulo
    JPaulo
    Moderador
    Moderador

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 10605
    Registrado : 04/11/2009

    MsgBox personalizada Empty Re: MsgBox personalizada

    Mensagem  JPaulo em 13/5/2013, 12:35

    Obrigado pela contribuíção, vai ajudar em muitas duvidas aqui.


    .................................................................................
    Contribua com o maximoaccess nos links abaixo, ajude a melhorar este que é o seu site na NET.

    Pay-Pal R$ Aqui
    Pay-Pal € Aqui

    Ou ainda: Aqui (Novo)

    Sucesso e Bons Estudos
    Success and Good Studies

    MsgBox personalizada Folder_announce_new Utilize o Sistema de Busca do Fórum...
    MsgBox personalizada Folder_announce_new 102 Códigos VBA Gratuitos...
    MsgBox personalizada Folder_announce_new Instruções SQL como utilizar...
    Fernando Bueno
    Fernando Bueno
    Developer
    Developer

    Respeito às Regras 100%

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

    MsgBox personalizada Empty Re: MsgBox personalizada

    Mensagem  Fernando Bueno em 13/5/2013, 12:37

    Obrigado pelo compartilhamento


    .................................................................................
    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
    MsgBox personalizada 16rzeq
    leoni_dias
    leoni_dias
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 180
    Registrado : 14/08/2011

    MsgBox personalizada Empty Re: MsgBox personalizada

    Mensagem  leoni_dias em 13/5/2013, 12:48

    Bom dia, mestres.

    Apenas tentando devolver um pouco da ajuda que já recebi desse Fórum.

    Cumprimentos.
    avatar
    Wallace Lima
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 82
    Registrado : 29/04/2014

    MsgBox personalizada Empty Re: MsgBox personalizada

    Mensagem  Wallace Lima em 5/5/2014, 02:44

    Obrigado por postar.
    Gosto muito desse Forum pois muita gente ajuda mesmo.
    Abrçs.

      Data/hora atual: 29/11/2020, 16:07