codice:
Option Explicit
Private Enum TT_FLAGS
TTF_IDISHWND = &H1
TTF_SUBCLASS = &H10
End Enum
Private Enum TT_Msgs
#If UNICODE Then
TTM_ADDTOOL = (WM_USER + 50)
TTM_DELTOOL = (WM_USER + 51)
TTM_UPDATETIPTEXT = (WM_USER + 57)
TTM_ENUMTOOLS = (WM_USER + 58)
#Else
TTM_ADDTOOL = (&H400 + 4)
TTM_DELTOOL = (&H400 + 5)
TTM_UPDATETIPTEXT = (&H400 + 12)
TTM_ENUMTOOLS = (&H400 + 14)
#End If
TTM_SETTIPBKCOLOR = (&H400 + 19)
TTM_SETTIPtextCOLOR = (&H400 + 20)
TTM_GETDELAYTIME = (&H400 + 21)
TTM_GETTIPBKCOLOR = (&H400 + 22)
TTM_SETMAXTIPWIDTH = (&H400 + 24)
TTM_GETMAXTIPWIDTH = (&H400 + 25)
End Enum
Enum Style
WinStandard = 0
Fumetto = 1
End Enum
Public Enum ttIconType
TTNoIcon = 0
TTIconInfo = 1
TTIconWarning = 2
TTIconError = 3
End Enum
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type TOOLINFO
cbSize As Long
uFlags As TT_FLAGS
hwnd As Long
uId As Long
RECT As RECT
hinst As Long
lpszText As String
lParam As Long
End Type
Private §Hwnd As Long
Private §MaxFumetti As Long
Private §HelpOk As Boolean
Private §Stile As Style
Private §Titolo As String
Private §Icona As Long
Private §TempoRitardo As Long
Private §TempoVisualizzazione As Long
Private TI As TOOLINFO
Dim §Help As String
Rem _
inizializzazione della classe _
Private Sub Class_Initialize()
' azzeramento della memoria
api_AzzeraMemoria TI, Len(TI)
If §Hwnd <> 0 Then Call api_DistruggeFinestra(§Hwnd)
' inizializzazione variabili
§HelpOk = False
§Stile = Fumetto
§Titolo = " " ' importante che la stringa non sia vuota
§Icona = 0
§TempoRitardo = 0
§TempoVisualizzazione = 5000
End Sub
Rem _
crea un nuovo help _
INPUT: controllo maschera _
nome del campo _
OUTPUT: true se andato a buon fine _
Public Function NuovoHelp(§_Frm As Form, _
§_Nome As String) _
As Boolean
Dim lWinStyle As Long
On Error GoTo Errore
§Help = §_Nome
§retVal = api_InviaMessaggioLong(§Hwnd, (&H400 + 3), 2, §TempoVisualizzazione)
§retVal = api_InviaMessaggioLong(§Hwnd, (&H400 + 3), 3, §TempoRitardo)
lWinStyle = &H1 Or &H2
If §Stile = Fumetto Then lWinStyle = lWinStyle Or &H40
If (§Hwnd = 0) Then
Call api_IniziaControlli
§Hwnd = api_CreaWindow(0&, "tooltips_class32", vbNullString, lWinStyle, 0, _
0, 0, 0, §_Frm.hwnd, 0, App.hInstance, 0)
End If
§HelpOk = CBool(§Hwnd)
If §HelpOk = False Then
NuovoHelp = False
Else
NuovoHelp = True
§retVal = api_InviaMessaggioAny(§Hwnd, (&H400 + 4), 0&, TI)
§retVal = api_InviaMessaggioAny(§Hwnd, (&H400 + 32), CLng(§Icona), ByVal §Titolo)
End If
Exit Function
Errore:
§HelpOk = False
NuovoHelp = False
Err.Clear
End Function
'#############################################################
'# termina la classe #
'##############################################################
Private Sub Class_Terminate()
Dim nItems As Long
If §Hwnd Then
nItems = ToolCount
Do Until nItems = 0
If api_InviaMessaggioAny(§Hwnd, TTM_ENUMTOOLS, (0), TI) Then
RemoveToolHwnd TI.uId
End If
nItems = ToolCount
Loop
api_AzzeraMemoria TI, Len(TI)
api_DistruggeFinestra (§Hwnd)
End If
End Sub
Rem imposta il tempo di ritardo _
INPUT: numero di millisecondi _
Public Property Let TempoRitardo(§_Ritardo As Long)
If §Hwnd <> 0 Then Exit Property ' help gia' creato; impossibile modificare
§TempoRitardo = §_Ritardo
api_InviaMessaggioAny §Hwnd, (&H400 + 3), 3, §TempoRitardo
End Property
Rem
imposta il tempo di visualizzazione _
INPUT: numero di millisecondi _
Public Property Let TempoVisualizzazione(§_Visualizzazione As Long)
§TempoVisualizzazione = §_Visualizzazione
api_InviaMessaggioAny §Hwnd, (&H400 + 3), 2, §TempoRitardo
End Property
Rem imposta il titolo dei fumetti _
INPUT: titolo dell' help _
Public Property Let Titolo(§_Titolo As String)
If §_Titolo = "" Then §_Titolo = " "
§Titolo = §_Titolo
api_InviaMessaggioAny §Hwnd, (&H400 + 32), CLng(§Icona), ByVal §Titolo
End Property
Rem imposta l' icona dei fumetti _
INPUT: icona dell' help _
Public Property Let Icona(§_Icona As ttIconType)
§Icona = §_Icona
If §Titolo = "" Then §Titolo = " "
api_InviaMessaggioAny §Hwnd, (&H400 + 32), CLng(§Icona), ByVal §Titolo
End Property
Rem
aggiunge una voce di help _
INPUT: controllo su cui associare l' help _
OPT testo dell' help _
Public Function Add(§_Ctrl As Control, _
Optional §_Text As String = "") _
As Boolean
Dim §Visibile As Long
Dim §Ritardo As Long
Dim §BackColor As Long
Dim §ForeColor As Long
If §HelpOk = False Or _
§Hwnd = 0 Or _
GetToolInfo(§_Ctrl.hwnd, TI) = True Then Exit Function
With TI
.cbSize = Len(TI)
.uFlags = TTF_SUBCLASS Or &H1
.hwnd = §_Ctrl.Container.hwnd
.uId = §_Ctrl.hwnd
If Len(§_Text) Then
.lpszText = §_Text
Else
.lpszText = ""
End If
§MaxFumetti = Max(§MaxFumetti, Len(.lpszText) + 1)
End With
' imposta i parametri corrispondenti al tipo di help
Select Case §Help
Case "Form"
§Visibile = £PVM(PVM_HelpFormVisible)
§Ritardo = £PVM(PVM_HelpFormRitardo)
§BackColor = £PVM(PVM_HelpFormBackColor)
§ForeColor = £PVM(PVM_HelpFormForeColor)
Case "Barra"
§Visibile = £PVM(PVM_HelpBarraVisible)
§Ritardo = £PVM(PVM_HelpBarraRitardo)
§BackColor = £PVM(PVM_HelpBarraBackColor)
§ForeColor = £PVM(PVM_HelpBarraForeColor)
Case "Opzione"
§Visibile = £PVM(PVM_HelpOpzioneVisible)
§Ritardo = £PVM(PVM_HelpOpzioneRitardo)
§BackColor = £PVM(PVM_HelpOpzioneTitoloBackColor)
§ForeColor = £PVM(PVM_HelpOpzioneTitoloForeColor)
End Select
Add = api_InviaMessaggioAny(§Hwnd, TTM_ADDTOOL, 0, TI)
§retVal = api_InviaMessaggioLong(§Hwnd, (&H400 + 3), 2, §Visibile)
§retVal = api_InviaMessaggioLong(§Hwnd, (&H400 + 3), 3, §Ritardo)
§retVal = api_InviaMessaggioLong(§Hwnd, TTM_SETTIPBKCOLOR, §BackColor, 0)
§retVal = api_InviaMessaggioLong(§Hwnd, TTM_SETTIPtextCOLOR, §ForeColor, 0)
End Function
'##############################################################
'# legge informazioni fumetto #
'##############################################################
Private Function GetToolInfo(hwndTool As Long, _
TI As TOOLINFO, _
Optional fGetText As Boolean = False) As Boolean
Dim nItems As Integer
Dim I As Integer
TI.cbSize = Len(TI)
If fGetText Then TI.lpszText = String$(§MaxFumetti, 0)
nItems = ToolCount
For I = 0 To nItems - 1
If api_InviaMessaggioAny(§Hwnd, TTM_ENUMTOOLS, (I), TI) Then
If (hwndTool = TI.uId) Then
GetToolInfo = True
Exit Function
End If
End If
Next
End Function
'##############################################################
'# trova il parametro massimo #
'##############################################################
Private Function Max(param1 As Long, _
param2 As Long) _
As Long
If param1 > param2 Then _
Max = param1 Else Max = param2
End Function
'##############################################################
'# ricava il numero di fumetti presenti nella classe #
'##############################################################
Public Property Get ToolCount() As Integer
If (§Hwnd = 0) Then Exit Property
ToolCount = api_InviaMessaggioAny(§Hwnd, (&H400 + 13), 0, 0)
End Property
'##############################################################
'# rimuove tutti i fumetti #
'##############################################################
Public Function RemoveToolHwnd(CTRLHwnd As Long) _
As Boolean
If (hwnd = 0) Then Exit Function
If GetToolInfo(CTRLHwnd, TI) Then
api_InviaMessaggioAny §Hwnd, TTM_DELTOOL, 0, TI
RemoveToolHwnd = True
End If
End Function
'##############################################################
'# ricava identificativo del fumetto #
'##############################################################
Public Property Get hwnd() As Long
hwnd = §Hwnd
End Property
'##############################################################
'# cancella una voce #
'##############################################################
Public Function Del(CTRL As Control) As Boolean
On Error Resume Next
If (§Hwnd > 0) And GetToolInfo(CTRL.hwnd, TI) Then _
Call api_InviaMessaggioAny(§Hwnd, 1029, 0, TI)
On Error GoTo 0
End Function
Permessi di invio
Rispondi quotando