Clase .... CToolTip

Un lugar dónde compartir funciones, procedimientos y aplicaciones
AngelMiguel
Nivel 2
Mensajes: 26
Registrado: Mar Nov 21, 2017 4:34 pm

Clase .... CToolTip

Mensajepor AngelMiguel » Lun Ene 14, 2019 4:52 pm

La clase CTooltip , el modulo BalancesToolTip y en tu form

Imagen

Probado en 32 Bits

la clase: CToolTip

Option Compare Database
Option Explicit

''' de entre otros:
''' http://binaryworld.net/Main/CodeDetail. ... evelopment
'''http://binaryworld.net/Main/
'''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 LINEA SUSTITUIDA POR BUG EN LA DE MAS ABAJO or
POR and

If mvarStyle = TTBalloon Then lWinStyle = lWinStyle And 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


El 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


En 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

AngelMiguel
Nivel 2
Mensajes: 26
Registrado: Mar Nov 21, 2017 4:34 pm

Re: Clase .... CToolTip actualización-revisión-reestructuración

Mensajepor AngelMiguel » Mar Mar 02, 2021 11:12 pm

Option Compare Database
Option Explicit

Notas: Win10 + Office 2016 32 64 bits
Temporizado + colorize

Descargas en:
https://drive.google.com/file/d/1cQmSqG1WhGM0VZGH_E_Wh4m9ihrfveTa/view?usp=sharing

1.- Al iniciar la aplicación
Call EnabledRegistroEnableBalloonTips in Mdl_RegistroWindows

Public Sub EnabledRegistroEnableBalloonTips()

mensaje = "Es posible que los mensajes ToolTip no se ejecuten si en el registro de windows no esta permitido." & vbCrLf & vbCrLf
mensaje = mensaje & "¿Autoriza a modificar el Registro de Windows para permitir los ToolTips?" & vbCrLf
respuesta = MsgBox(mensaje, vbYesNo, "Balances")
Select Case respuesta
Case vbYes
''
Case Else
Exit Sub
End Select

On Error GoTo EnabledRegistroEnableBalloonTips_Error

Dim i_RegKey As String
Dim i_Value As String
Dim i_Type As String
Dim myWS As Object

i_RegKey = "": i_Value = "": i_Type = ""
i_RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\ShowInfoTip"
i_Value = "00000001"
i_Type = "REG_DWORD"

If RegKeyExists(i_RegKey, i_Value, i_Type) Then
Else
Set myWS = CreateObject("WScript.Shell")
myWS.RegWrite i_RegKey, i_Value, i_Type
Set myWS = Nothing
End If

i_RegKey = "": i_Value = "": i_Type = ""
i_RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\FolderContentsInfoTip"
i_Value = "00000001"
i_Type = "REG_DWORD"

If RegKeyExists(i_RegKey, i_Value, i_Type) Then
Else
Set myWS = CreateObject("WScript.Shell")
myWS.RegWrite i_RegKey, i_Value, i_Type
Set myWS = Nothing
End If

i_RegKey = "": i_Value = "": i_Type = ""
i_RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\StartButtonBalloonTip"
i_Value = "00000001"
i_Type = "REG_DWORD"

If RegKeyExists(i_RegKey, i_Value, i_Type) Then
Else
Set myWS = CreateObject("WScript.Shell")
myWS.RegWrite i_RegKey, i_Value, i_Type
Set myWS = Nothing
End If

i_RegKey = "": i_Value = "": i_Type = ""
i_RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\EnableBalloonTips"
i_Value = "00000001"
i_Type = "REG_DWORD"

If RegKeyExists(i_RegKey, i_Value, i_Type) Then
Else
Set myWS = CreateObject("WScript.Shell")
myWS.RegWrite i_RegKey, i_Value, i_Type
Set myWS = Nothing
End If

i_RegKey = "": i_Value = "": i_Type = ""
i_RegKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\ShowInfoTip"
i_Value = "00000001"
i_Type = "REG_DWORD"

If RegKeyExists(i_RegKey, i_Value, i_Type) Then
Else
Set myWS = CreateObject("WScript.Shell")
myWS.RegWrite i_RegKey, i_Value, i_Type
Set myWS = Nothing
End If

i_RegKey = "": i_Value = "": i_Type = ""
i_RegKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\EnableBalloonTips"
i_Value = "00000001"
i_Type = "REG_DWORD"

If RegKeyExists(i_RegKey, i_Value, i_Type) Then
Else
Set myWS = CreateObject("WScript.Shell")
myWS.RegWrite i_RegKey, i_Value, i_Type
Set myWS = Nothing
End If

i_RegKey = "": i_Value = "": i_Type = ""
i_RegKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\StartButtonBalloonTip"
i_Value = "00000001"
i_Type = "REG_DWORD"

If RegKeyExists(i_RegKey, i_Value, i_Type) Then
Else
Set myWS = CreateObject("WScript.Shell")
myWS.RegWrite i_RegKey, i_Value, i_Type
Set myWS = Nothing
End If

i_RegKey = "": i_Value = "": i_Type = ""
i_RegKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\FolderContentsInfoTip"
i_Value = "00000001"
i_Type = "REG_DWORD"

If RegKeyExists(i_RegKey, i_Value, i_Type) Then
Else
Set myWS = CreateObject("WScript.Shell")
myWS.RegWrite i_RegKey, i_Value, i_Type
Set myWS = Nothing
End If

i_RegKey = "": i_Value = "": i_Type = ""
i_RegKey = "HKEY_CURRENT_USER\SOFTWARE\Policies\Microsoft\Windows\Explorer\EnableLegacyBalloonNotifications"
i_Value = "00000001"
i_Type = "REG_DWORD"

If RegKeyExists(i_RegKey, i_Value, i_Type) Then
Else
Set myWS = CreateObject("WScript.Shell")
myWS.RegWrite i_RegKey, i_Value, i_Type
Set myWS = Nothing
End If

On Error GoTo 0
Exit Sub
EnabledRegistroEnableBalloonTips_Error:
MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure EnabledRegistroEnableBalloonTips, line " & Erl & "."
End Sub



2.- Name: Mdl_ShowTooltip
'-------------------------------------------------------------------------------------------------------------------------
' basado en Module : mdlToolTip
' Auther : Jim jose
' Credits : Fred.cpp, for the basic code
' : Dana Seaman, for unicode support
' Purpose : Simple and efficient tooltip generation with baloon style and Icon.
' Advantage : Designed for ur projects which not using Subclassing technique
' Modif : AngelMiguel 31/01/2021
'-------------------------------------------------------------------------------------------------------------------------
'despues de probar en..
'http://read.pudn.com/downloads505/sourcecode/windows/2102815/Play78Assistant/mdlTooltip.bas__.htm
'https://winaero.com/blog/enable-balloon-notifications-in-windows-10-using-a-registry-tweak/
'https://winaero.com/blog/enable-balloon-notifications-in-windows-10-and-disable-toasts/
'https://www.msftnext.com/enable-balloon-notifications-windows-10/
'https://www.vbarchiv.net/workshop/details.php?id=41
'https://forum.html.it/forum/showthread/t-782182.html
'https://binaryworld.net/Main/CodeDetail.aspx?CodeId=3603
'https://www.codeproject.com/Articles/12322/Balloon-ToolTip-Control
'https://wasm.in/threads/skazki-djadjushki-rimusa.31832/page-6
'http://volcanosoft.narod.ru/tt_mess.html
'http://read.pudn.com/downloads165/sourcecode/windows/control/753052/XPStylemanifestmaker/BalloonTooltip.bas__.htm
'https://www.autoitscript.com/autoit3/docs/libfunctions/_WinAPI_SetWindowTheme.htm
'https://delphisources.ru/forum/showthread.php?t=23420
'http://bbs.vbstreets.ru/viewtopic.php?f=1&t=23253
'la solución para win server...
'https://www.howtogeek.com/howto/windows-vista/disable-all-notification-balloons-in-windows-vista/
'''''''''[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced] "EnableBalloonTips"=1

'AÑADIDO
Private Declare PtrSafe Sub InitCommonControls Lib "comctl32.dll" ()
'FIN

'[APIs]
Private Declare PtrSafe 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 LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, LParam As Any) As Long
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare PtrSafe Function SetWindowPos Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare PtrSafe Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, ByVal LParam As Long) As LongPtr
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Public Declare PtrSafe Function InitCommonControlsEx Lib "comctl32.dll" (ByRef iccInit As ICCEX) As Long
Private Declare PtrSafe Function ActivateWindowTheme Lib "uxtheme" Alias "SetWindowTheme" (ByVal hwnd As LongPtr, ByVal _
pszSubAppName As Long, ByVal pszSbuIdList As Long) As Long
Private Declare PtrSafe Function DeactivateWindowTheme Lib "uxtheme" Alias "SetWindowTheme" (ByVal hwnd As LongPtr, ByRef _
pszSubAppName As String, ByRef pszSubIdList As String) As Long

'[Types]
Public Type ICCEX
dwSize As Long
dwICC As Long
End Type


Private Type POINTAPI
X As Long
Y As Long
End Type

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

Private Type TOOLINFO
lSize As Long
lFlags As Long
lHwnd As LongPtr
lId As LongPtr
lpRect As RECT
hInst As LongPtr
lpStr As LongPtr
LParam As Long
End Type

'[Enums]
Public Enum ToolTipStyleEnum
[Tip_Normal] = 0
[Tip_Balloon] = 1
End Enum

Public Enum ToolTipTypeEnum
[Tip_None] = 0
[Tip_Info] = 1
[Tip_Warning] = 2
[Tip_Error] = 3
End Enum

'[Local variables]
Private m_MousePos As POINTAPI
Private m_ToolTipHwnd As LongPtr
Private m_ToolTipInfo As TOOLINFO
Private mvarVisibleTime As Long
Private mvarDelayTime As Long

'[Required constants]
Private Const WM_USER As Long = &H400
Private Const CW_USEDEFAULT As Long = &H80000000
Private Const HWND_TOPMOST As Long = -&H1
Private Const SWP_NOACTIVATE As Long = &H10
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOSIZE As Long = &H1
Private Const TOOLTIPS_CLASSA As String = "tooltips_class32"
Private Const TTF_IDISHWND As Long = &H1&
Private Const TTF_SUBCLASS As Long = &H10
Private Const TTF_TRACK = &H20
Private Const TTM_ACTIVATE = (WM_USER + 1)
Private Const TTM_ADDTOOLW = (WM_USER + 50&)
Private Const TTM_ADDTOOLA = (WM_USER + 4&)
Private Const TTM_DELTOOLW As Long = (WM_USER + 51)
Private Const TTM_GETTIPBKCOLOR = WM_USER + 22
Private Const TTM_GETTIPTEXTCOLOR = WM_USER + 23
Private Const TTM_SETDELAYTIME As Long = (WM_USER + 3)
Private Const TTDT_AUTOPOP = 2
Private Const TTDT_INITIAL = 3
Private Const TTDT_RESHOW = 1
Private Const TTDT_AUTOMATIC = 0
Private Const TTM_SETTIPBKCOLOR As Long = (WM_USER + 19)
Private Const TTM_SETTIPTEXTCOLOR As Long = (WM_USER + 20)
Private Const TTM_SETTITLEW As Long = (WM_USER + 33)
Private Const TTM_TRACKPOSITION As Long = (WM_USER + 18)
Private Const TTF_CENTERTIP As Long = &H2
Private Const TTM_TRACKACTIVATE = WM_USER + 17
Private Const TTM_UPDATETIPTEXTA = (WM_USER + 12)
Private Const TTS_ALWAYSTIP As Long = &H1
Private Const TTS_BALLOON As Long = &H40
Private Const TTS_NOPREFIX As Long = &H2
Private Const WS_POPUP As Long = &H80000000
Private Const COLOR_INFOBK = 24
Private Const TTF_TRANSPARENT As Long = &H100
Public Const ICC_WIN95_CLASSES As Long = &HFF
Private Const TVM_SETBKCOLOR = 4381&
Private Const TTM_GETTOOLINFO = (WM_USER + 8)
Private Const TTM_SETTITLE = WM_USER + 32
Private Const TTM_UPDATETIPTEXT = (WM_USER + 12)
Private Const TTM_UPDATETIPTEXTW = (WM_USER + 57)
Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
Private Const TTM_UPDATE = (WM_USER + 29)
Private Const GWL_EXSTYLE = (-20)
Private Const LWA_ALPHA = &H2
Private Const WS_EX_LAYERED = &H80000

Public Sub ShowToolTip(ByVal hwnd As Long, ByVal mToolTipText As String, ByVal mToolTipHead As String, _
Optional ByVal mToolTipStyle As ToolTipStyleEnum = Tip_Balloon, _
Optional ByVal mToolTipType As ToolTipTypeEnum = Tip_None, _
Optional ByVal mBackColor As Long = -1, _
Optional ByVal mTextColor As Long = -1)
Dim lpRect As RECT
Dim lWinStyle As Long
Dim MousePos As POINTAPI
Dim Retval As Long
Dim ICEx As ICCEX

With ICEx
.dwSize = Len(ICEx)
.dwICC = ICC_WIN95_CLASSES
End With

'añadido 09-01-2020
Static bCommonControlsInitialized As Boolean
If Not bCommonControlsInitialized Then
InitCommonControlsEx ICEx
bCommonControlsInitialized = True
End If
'fin

mvarDelayTime = 3000
mvarVisibleTime = 4000
mTextColor = vbWhite
mBackColor = vbBlack

GetCursorPos MousePos
If m_MousePos.X = MousePos.X And m_MousePos.Y = MousePos.Y Then Exit Sub

RemoveToolTip
If mToolTipText = vbNullString Then Exit Sub

lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX

If lWinStyle = Tip_Normal Then
lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX
Else
lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX Or TTS_BALLOON
End If

m_ToolTipHwnd = CreateWindowEx(0&, _
TOOLTIPS_CLASSA, _
StrPtr(vbNullString), _
lWinStyle, _
CW_USEDEFAULT, _
CW_USEDEFAULT, _
CW_USEDEFAULT, _
CW_USEDEFAULT, _
hwnd, _
0&, _
Application.hWndAccessApp, _
0&)

Call SetWindowPos(m_ToolTipHwnd, HWND_TOPMOST, 0&, 0&, 0&, 0&, SWP_NOACTIVATE Or SWP_NOSIZE Or SWP_NOMOVE)
GetClientRect hwnd, lpRect

With m_ToolTipInfo
.lSize = Len(m_ToolTipInfo)
.lFlags = TTF_SUBCLASS Or TTF_TRANSPARENT Or WS_EX_LAYERED
.lHwnd = hwnd
.lId = 0
.hInst = Application.hWndAccessApp
.lpStr = StrPtr(mToolTipText)
.lpRect = lpRect
End With

Call SendMessage(m_ToolTipHwnd, TTM_ADDTOOLW, 0&, m_ToolTipInfo)
Call DeactivateWindowTheme(m_ToolTipHwnd, 0, 0)

If Not mTextColor = -1 Then
Call SendMessage(m_ToolTipHwnd, TTM_SETTIPTEXTCOLOR, ByVal mTextColor, 0&)
End If

If Not mBackColor = -1 Then
Call SendMessage(m_ToolTipHwnd, TTM_SETTIPBKCOLOR, ByVal mBackColor, 0&)
End If

If Not mToolTipHead = vbNullString Then
Call SendMessage(m_ToolTipHwnd, TTM_SETTITLEW, mToolTipType, ByVal StrPtr(mToolTipHead))
End If

Retval = SendMessage(m_ToolTipHwnd, TTM_ACTIVATE, True, m_ToolTipInfo)

Call SendMessageLong(m_ToolTipHwnd, TTM_SETDELAYTIME, TTDT_AUTOPOP, ByVal mvarVisibleTime)
Call SendMessageLong(m_ToolTipHwnd, TTM_SETDELAYTIME, TTDT_INITIAL, ByVal mvarDelayTime)
Call SendMessageLong(m_ToolTipHwnd, TTM_SETDELAYTIME, TTDT_RESHOW, ByVal 200)

Call SendMessage(m_ToolTipHwnd, TTM_ADDTOOLW, 0&, m_ToolTipInfo)
Call SendMessage(m_ToolTipHwnd, TTM_UPDATE, 0&, 0&)

Do
m_MousePos.X = MousePos.X: m_MousePos.Y = MousePos.Y
GetCursorPos MousePos
If Not m_MousePos.X = MousePos.X Or Not m_MousePos.Y = MousePos.Y Then
RemoveToolTip
Call ActivateWindowTheme(m_ToolTipHwnd, 0, 0)
Exit Do
End If
DoEvents
Loop

Exit Sub
ErrHandler:
Debug.Print "Error " & err.Description
End Sub

Public Sub ModifyTip(ByVal NewText As String)
''http://rusproject.narod.ru/winapi/bycat.html api api api
'Call ModifyTip("lololololololol")
Dim modTip As TOOLINFO
With m_ToolTipInfo
.lHwnd = m_ToolTipHwnd
.lId = 0
.lpStr = StrPtr(NewText)
.lSize = Len(modTip)
End With
Call SendMessage(m_ToolTipHwnd, TTM_SETTITLE, &H0, ByVal NewText)
End Sub

'[Important. If not included, tooltips don't change when you try to set the toltip text]
Public Sub RemoveToolTip()
Dim Ir As Long
If m_ToolTipHwnd <> 0 Then
Ir = SendMessage(m_ToolTipInfo.lHwnd, TTM_DELTOOLW, 0, m_ToolTipInfo)
DestroyWindow m_ToolTipHwnd
m_ToolTipHwnd = 0
End If
End Sub

'[OleColor code to Long color conversion]
Public Function TranslateColor(ByVal lColor As Long) As Long
If OleTranslateColor(lColor, 0, TranslateColor) Then
TranslateColor = -1
End If
End Function

'https://www.vbarchiv.net/workshop/details.php?id=41
Private Function SysColorToRGB(ByVal lColor As OLE_COLOR) As Long
If (lColor And &HFF000000) = &H80000000 Then _
lColor = GetSysColor(lColor And &HFFFFFF)
SysColorToRGB = lColor
End Function

3.- En el form

Private Sub CmdMenuAsc_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo CmdMenuAsc_MouseMove_Error

Call ShowToolTip(DameWndDelControl(CmdMenuAsc), "Click ordena el menu ASC o DSC !!!", "Balances", Tip_Balloon, Tip_Warning)

On Error GoTo 0
Exit Sub
CmdMenuAsc_MouseMove_Error:
MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure CmdMenuAsc_MouseMove, line " & Erl & "."
End Sub
Adjuntos
ToolTip 2021-03-02 230547.png


Volver a “Almacén Accesiano”

¿Quién está conectado?

Usuarios navegando por este Foro: No hay usuarios registrados visitando el Foro y 2 invitados