** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Access y VBA > Tus Funciones Favoritas & Aportaciones & Artí­culos
  Mensajes nuevos Mensajes nuevos RSS - Clase ....  CToolTip
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Clase .... CToolTip

 Responder Responder
Autor
Mensaje
VayaCaló Ver desplegable
Habitual
Habitual


Unido: 16/Septiembre/2008
Localización: España
Estado: Sin conexión
Puntos: 139
Opciones de entrada Opciones de entrada   Gracias (0) Gracias(0)   Cita VayaCaló Cita  ResponderRespuesta Enlace directo a este mensaje Tema: Clase .... CToolTip
    Enviado: 14/Enero/2019 a las 16:43
La clase  CTooltip , el modulo BalancesToolTip y en tu form 

CToolTip

Option Compare Database
Option Explicit

' de entre otros:
'http://www.vbforums.com/attachment.php?attachmentid=159019&d=1526240546
'http://www.thescarms.com/VBasic/tooltip.aspx
'https://www.developerfusion.com/code/3890/adding-real-win32-tooltips-for-windowless-controls/
'http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=72134&lngWId=1
'http://priyantoagoes.blogspot.com/2014/07/carabuat-ballontext-module-vb6.html#more

''Windows API Functions

Private Declare Sub InitCommonControls Lib "comctl32.dll" ()

Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long

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

Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long

''Windows API Constants

Private Const WM_USER = &H400
Private Const CW_USEDEFAULT = &H80000000

''Windows API Types

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

''Tooltip Window Constants

Private Const TTS_NOPREFIX = &H2
Private Const TTF_TRANSPARENT = &H100
Private Const TTF_CENTERTIP = &H2
Private Const TTM_ADDTOOLA = (WM_USER + 4)
Private Const TTM_ACTIVATE = WM_USER + 1
Private Const TTM_UPDATETIPTEXTA = (WM_USER + 12)
Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
Private Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
Private Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
Private Const TTM_SETTITLE = (WM_USER + 32)
Private Const TTS_BALLOON = &H40
Private Const TTS_ALWAYSTIP = &H1
Private Const TTF_SUBCLASS = &H10
Private Const TTF_IDISHWND = &H1
Private Const TTM_SETDELAYTIME = (WM_USER + 3)
Private Const TTDT_AUTOPOP = 2
Private Const TTDT_INITIAL = 3

Private Const TOOLTIPS_CLASSA = "tooltips_class32"

''Tooltip Window Types

Private Type TOOLINFO
    lSize As Long
    lFlags As Long
    hwnd As Long
    lId As Long
    lpRect As RECT
    hInstance As Long
    lpStr As String
    lParam As Long
End Type


Public Enum ttIconType
    TTNoIcon = 0
    TTIconInfo = 1
    TTIconWarning = 2
    TTIconError = 3
End Enum

Public Enum ttStyleEnum
    TTStandard
    TTBalloon
End Enum

'local variable(s) to hold property value(s)

Private mvarBackColor As Long
Private mvarTitle As String
Private mvarForeColor As Long
Private mvarIcon As ttIconType
Private mvarCentered As Boolean
Private mvarStyle As ttStyleEnum
Private mvarTipText As String
Private mvarVisibleTime As Long
Private mvarDelayTime As Long

'private data

Private m_lTTHwnd As Long    ' hwnd of the tooltip
Private m_lParentHwnd As Long    ' hwnd of the window the tooltip attached to
Private ti As TOOLINFO

Public Property Let Style(ByVal vData As ttStyleEnum)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.Style = 5
    mvarStyle = vData
End Property

Public Property Get Style() As ttStyleEnum
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.Style
    Style = mvarStyle
End Property

Public Property Let Centered(ByVal vData As Boolean)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.Centered = 5
    mvarCentered = vData
End Property

Public Property Get Centered() As Boolean
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.Centered
    Centered = mvarCentered
End Property

Public Function Create(ByVal ParentHwnd As Long) As Boolean
    Dim lWinStyle As Long

    If m_lTTHwnd <> 0 Then
        DestroyWindow m_lTTHwnd
    End If

    m_lParentHwnd = ParentHwnd

    lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX

    ''create baloon style if desired
    If mvarStyle = TTBalloon Then lWinStyle = lWinStyle Or TTS_BALLOON

    m_lTTHwnd = CreateWindowEx(0&, _
                               TOOLTIPS_CLASSA, _
                               vbNullString, _
                               lWinStyle, _
                               CW_USEDEFAULT, _
                               CW_USEDEFAULT, _
                               CW_USEDEFAULT, _
                               CW_USEDEFAULT, _
                               0&, _
                               0&, _
                               Access.hWndAccessApp, _
                               0&)

    ''now set our tooltip info structure
    With ti
        ''if we want it centered, then set that flag
        If mvarCentered Then
            .lFlags = TTF_SUBCLASS Or TTF_CENTERTIP Or TTF_IDISHWND
        Else
            .lFlags = TTF_SUBCLASS Or TTF_IDISHWND
        End If

        ''set the hwnd prop to our parent control's hwnd
        .hwnd = m_lParentHwnd
        .lId = m_lParentHwnd    '0
        .hInstance = Access.hWndAccessApp
        '.lpstr = ALREADY SET
        '.lpRect = lpRect
        .lSize = Len(ti)
    End With

    ''add the tooltip structure
    SendMessage m_lTTHwnd, TTM_ADDTOOLA, 0&, ti

    ''if we want a title or we want an icon
    If mvarTitle <> vbNullString Or mvarIcon <> TTNoIcon Then
        SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), ByVal mvarTitle
    End If

    If mvarForeColor <> Empty Then
        SendMessage m_lTTHwnd, TTM_SETTIPTEXTCOLOR, mvarForeColor, 0&
    End If

    If mvarBackColor <> Empty Then
        SendMessage m_lTTHwnd, TTM_SETTIPBKCOLOR, mvarBackColor, 0&
    End If

    SendMessageLong m_lTTHwnd, TTM_SETDELAYTIME, TTDT_AUTOPOP, mvarVisibleTime
    SendMessageLong m_lTTHwnd, TTM_SETDELAYTIME, TTDT_INITIAL, mvarDelayTime
End Function

Public Property Let Icon(ByVal vData As ttIconType)
    On Error GoTo Icon_Error
    
    mvarIcon = vData
    If m_lTTHwnd <> 0 And mvarTitle <> Empty And mvarIcon <> TTNoIcon Then
        SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), ByVal mvarTitle
    End If
    
    On Error GoTo 0
    Exit Property
Icon_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure Icon, line " & Erl & "."
End Property

Public Property Get Icon() As ttIconType
    On Error GoTo Icon_Error
    
    Icon = mvarIcon
    
    On Error GoTo 0
    Exit Property
Icon_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure Icon, line " & Erl & "."
End Property

Public Property Let ForeColor(ByVal vData As Long)
    On Error GoTo ForeColor_Error
    
    mvarForeColor = vData
    If m_lTTHwnd <> 0 Then
        SendMessage m_lTTHwnd, TTM_SETTIPTEXTCOLOR, mvarForeColor, 0&
    End If
    
    On Error GoTo 0
    Exit Property
ForeColor_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure ForeColor, line " & Erl & "."
End Property

Public Property Get ForeColor() As Long
    On Error GoTo ForeColor_Error
    
    ForeColor = mvarForeColor
    
    On Error GoTo 0
    Exit Property
ForeColor_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure ForeColor, line " & Erl & "."
End Property

Public Property Let title(ByVal vData As String)
    On Error GoTo title_Error
    
    mvarTitle = vData
    If m_lTTHwnd <> 0 And mvarTitle <> Empty And mvarIcon <> TTNoIcon Then
        SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), ByVal mvarTitle
    End If
    
    On Error GoTo 0
    Exit Property
title_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure title, line " & Erl & "."
End Property

Public Property Get title() As String
    On Error GoTo title_Error
    
    title = ti.lpStr
    
    On Error GoTo 0
    Exit Property
title_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure title, line " & Erl & "."
End Property

Public Property Let BackColor(ByVal vData As Long)
    mvarBackColor = vData
    If m_lTTHwnd <> 0 Then
        SendMessage m_lTTHwnd, TTM_SETTIPBKCOLOR, mvarBackColor, 0&
    End If
End Property

Public Property Get BackColor() As Long
    BackColor = mvarBackColor
End Property

Public Property Let TipText(ByVal vData As String)
    mvarTipText = vData
    ti.lpStr = vData
    If m_lTTHwnd <> 0 Then
        SendMessage m_lTTHwnd, TTM_UPDATETIPTEXTA, 0&, ti
    End If
End Property

Public Property Get TipText() As String
    TipText = mvarTipText
End Property

Private Sub Class_Initialize()
    InitCommonControls
    mvarDelayTime = 500
    mvarVisibleTime = 5000
End Sub

Private Sub Class_Terminate()
    Destroy
End Sub

Public Sub Destroy()
    If m_lTTHwnd <> 0 Then
        DestroyWindow m_lTTHwnd
    End If
End Sub

Public Property Get VisibleTime() As Long
    VisibleTime = mvarVisibleTime
End Property

Public Property Let VisibleTime(ByVal lData As Long)
    mvarVisibleTime = lData
End Property

Public Property Get DelayTime() As Long
    DelayTime = mvarDelayTime
End Property

Public Property Let DelayTime(ByVal lData As Long)
    mvarDelayTime = lData
End Property


Modulo BalancesToolTip

Option Compare Database
Option Explicit

Public TT As CTooltip

Public Sub BalancesToolTip(ByVal fctl As Long, msj As String, ftitle As String, fStyle As Long, fIcon As Long)
    On Error GoTo BalancesToolTip_Error
        
    Set TT = New CTooltip
    With TT
      TT.Style = TTBalloon
      TT.Icon = TTIconInfo
      TT.title = ftitle
      TT.TipText = msj
      TT.Create fctl
    End With
    
    On Error GoTo 0
    Exit Sub
BalancesToolTip_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure BalancesToolTip, line " & Erl & "."
End Sub

Public Sub BalancesToolTipdestroy()
    On Error GoTo BalancesToolTipdestroy_Error
  
    With TT
     .Destroy
    End With
    
    On Error GoTo 0
    err.Clear
    Exit Sub
BalancesToolTipdestroy_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure BalancesToolTipdestroy, line " & Erl & "."
End Sub


Tu Form


Private m_bInLable As Boolean


Private Sub EncabezadoDelFormulario_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo EncabezadoDelFormulario_MouseMove_Error
    
    If m_bInLable Then
        m_bInLable = False
        BalancesToolTipdestroy
    End If
    
    On Error GoTo 0
    Exit Sub
EncabezadoDelFormulario_MouseMove_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure EncabezadoDelFormulario_MouseMove, line " & Erl & "."
End Sub

Private Sub Detalle_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo Detalle_MouseMove_Error
    
    If m_bInLable Then
        m_bInLable = False
        BalancesToolTipdestroy
    End If
    
    On Error GoTo 0
    Exit Sub
Detalle_MouseMove_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure Detalle_MouseMove, line " & Erl & "."
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo Form_MouseMove_Error
    
    If m_bInLable Then
        m_bInLable = False
         BalancesToolTipdestroy
    End If
    
    On Error GoTo 0
    Exit Sub
Form_MouseMove_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure Form_MouseMove, line " & Erl & "."
End Sub

Private Sub PieDelFormulario_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo PieDelFormulario_MouseMove_Error
    
    If m_bInLable Then
        m_bInLable = False
         BalancesToolTipdestroy
    End If
    
    On Error GoTo 0
    Exit Sub
PieDelFormulario_MouseMove_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure PieDelFormulario_MouseMove, line " & Erl & "."
End Sub

Private Sub Form_Close()
    On Error GoTo Form_Close_Error
    
    BalancesToolTipdestroy

    On Error GoTo 0
    Exit Sub
Form_Close_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure Form_Close of Documento VBA Form__01_PresupuestosAlta"
End Sub


Private Sub CmdColor_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo CmdColor_MouseMove_Error

    BalancesToolTip fhWnd(Me.CmdColor), "Modifica el patron del formulario.", "Balances", TTBalloon, TTIconInfo

    On Error GoTo 0
    Exit Sub
CmdColor_MouseMove_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure CmdColor_MouseMove of Documento VBA Form__01_PresupuestosFiltroBusca"
End Sub

funciones varias

Public Declare Function GetFocus Lib "user32.dll" () As Long

Public Function fhWnd(ctl As Access.Control) As Long
On Error Resume Next
  ctl.SetFocus
  If err Then
  fhWnd = 0
  Else
  fhWnd = GetFocus
  End If
On Error GoTo 0
End Function


Editado por VayaCaló - 18/Enero/2019 a las 09:38
Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable