MaximoAccess

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

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração


Participe do fórum, é rápido e fácil

MaximoAccess

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

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração

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


2 participantes

    Deixar Msgbox em negrito

    avatar
    JOSEMORAES
    Avançado
    Avançado


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 220
    Registrado : 23/02/2011

    Deixar Msgbox em negrito Empty Deixar Msgbox em negrito

    Mensagem  JOSEMORAES 27/6/2012, 15:21

    Em um modulo cole.

    Option Explicit

    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, lParam As Any) As Long

    Private Const WH_CBT = 5
    Private Const HCBT_CREATEWND = 3
    Private Const HCBT_ACTIVATE = 5
    Private Const FW_BOLD = 700
    Private Const LF_FACESIZE = 32

    Private Const WM_SETFONT = &H30
    Private Const WM_GETFONT = &H31

    Private hHook As Long

    Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE) As Byte
    End Type

    Private Function MsgBoxHookProc(ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    If uMsg < 0 Then
    MsgBoxHookProc = CallNextHookEx(hHook, uMsg, wParam, lParam)
    End If

    Dim windowHandle As Long
    windowHandle = wParam

    Dim RetVal As Long, lpClassName As String
    lpClassName = Space(256)
    RetVal = GetClassName(windowHandle, lpClassName, 256)
    lpClassName = Left(lpClassName, RetVal)

    'Verifica se uma janela está sendo ativada e se é uma caixa de diálogo
    If uMsg = HCBT_ACTIVATE And lpClassName = "#32770" Then

    'Obtém o handle do Label na MsgBox
    Dim labelHandle As Long
    labelHandle = GetDlgItem(windowHandle, 65535)

    'Verifica se o Label foi encontrado
    If labelHandle Then

    'Altera o estilo da fonte
    Dim LF As LOGFONT
    Dim hCurrFont As Long
    Dim hHeaderFont As Long

    hCurrFont = SendMessage(labelHandle, WM_GETFONT, 0, ByVal 0)

    If GetObject(hCurrFont, Len(LF), LF) > 0 Then
    LF.lfWeight = FW_BOLD
    hHeaderFont = CreateFontIndirect(LF)
    SendMessage labelHandle, WM_SETFONT, hHeaderFont, ByVal True
    End If

    End If

    End If

    MsgBoxHookProc = CallNextHookEx(hHook, uMsg, wParam, lParam)

    End Function

    Public Sub InitializeHook()
    hHook = SetWindowsHookEx(WH_CBT, AddressOf MsgBoxHookProc, 0, GetCurrentThreadId())
    End Sub

    Public Sub TerminateHook()
    UnhookWindowsHookEx hHook
    End Sub


    Depois entre a mensagem

    InitializeHook
    MsgBox "Mensagem linha1" & vbCrLf & "Mensagem linha 2", vbYesNo
    TerminateHook


    fonte:http://www.vbmania.com.br


    .................................................................................
    Deixar Msgbox em negrito 10715412
    JPaulo
    JPaulo
    Moderador
    Moderador


    Respeito às regras : Respeito às Regras 100%

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

    Deixar Msgbox em negrito Empty Re: Deixar Msgbox em negrito

    Mensagem  JPaulo 27/6/2012, 15:58

    Valew pela contribuíção;

    Agora veja o simples:

    Dentro do VBA do formulario;




    Private Sub SeuBotão_Click()
    FormattedMsgBox "OLÁ JOSEMORAES!@Esta é a mensagem formatada.@Já tinha visto ?"
    End Sub


    Public Function FormattedMsgBox(Prompt As String, _
    Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
    Optional Title As String = vbNullString, _
    Optional HelpFile As Variant, _
    Optional Context As Variant) As VbMsgBoxResult
    If IsMissing(HelpFile) Or IsMissing(Context) Then
    FormattedMsgBox = Eval("MsgBox(""" & Prompt & _
    """, " & Buttons & ", """ & Title & """)")
    Else
    FormattedMsgBox = Eval("MsgBox(""" & Prompt & _
    """, " & Buttons & ", """ & Title & """, """ & _
    HelpFile & """, " & Context & ")")
    End If
    End Function


    .................................................................................
    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

    Deixar Msgbox em negrito Folder_announce_new Utilize o Sistema de Busca do Fórum...
    Deixar Msgbox em negrito Folder_announce_new 102 Códigos VBA Gratuitos...
    Deixar Msgbox em negrito Folder_announce_new Instruções SQL como utilizar...
    avatar
    JOSEMORAES
    Avançado
    Avançado


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 220
    Registrado : 23/02/2011

    Deixar Msgbox em negrito Empty Re: Deixar Msgbox em negrito

    Mensagem  JOSEMORAES 27/6/2012, 16:39

    Grande JPaulo.

    Já sim, esta no meu acervo.


    Abraços


    .................................................................................
    Deixar Msgbox em negrito 10715412

    Conteúdo patrocinado


    Deixar Msgbox em negrito Empty Re: Deixar Msgbox em negrito

    Mensagem  Conteúdo patrocinado


      Data/hora atual: 7/11/2024, 20:49