A class module named: ctooltip, the code is as follows:
Option expedition
Private Declare Sub INITCOMMONCONTROLS LIB "COMCTL32.DLL" ()
'' Windows API FunctionsPrivate 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 LongPrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPrivate Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPrivate Declare Function DestroyWindow Lib " User32 "(Byval Hwnd As Long) As long
'' Windows API constantsprivate const wm_user = & h400Private const cw_usedefault = & h80000000
'' Windows API Typesprivate Type Rect Left As Long Top As Long Right As Long Bottom as Longend Type
'' Tooltip Window ConstantsPrivate Const TTS_NOPREFIX = & H2Private Const TTF_TRANSPARENT = & H100Private Const TTF_CENTERTIP = & H2Private Const TTM_ADDTOOLA = (WM_USER 4) Private Const TTM_ACTIVATE = WM_USER 1Private 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 = & H40Private const TTS_ALWAYSTIP = & H1Private const TTF_SUBCLASS = & H10Private const TTF_IDISHWND = & H1Private const TTM_SETDELAYTIME = (WM_USER 3 ) Private const ttdt_autopop = 2Private const ttdt_initial = 3Private const tooltips_classa = "Tooltips_Class32"
'' Tooltip Window Typesprivate Type Toolinfo Lsize As Long LFLAGS AS Long Hwnd As Long Lid AS Long LPSTR AS STRING LPARAM AS LONGEND TYPE
Public enum tticondype ttnio = 0 tticonifo = 1 TTICONWARNING = 2 tticonerror = 3END ENUM
Public Enum TTStyleenum Ttstandard TTBalloonend Enum
'Local variable (s) to hold property value (s) Private mvarBackColor As LongPrivate mvarTitle As StringPrivate mvarForeColor As LongPrivate mvarIcon As ttIconTypePrivate mvarCentered As BooleanPrivate mvarStyle As ttStyleEnumPrivate mvarTipText As StringPrivate mvarVisibleTime As LongPrivate mvarDelayTime As Long
'Private dataPrivate m_lTTHwnd As Long' hwnd of the tooltipPrivate m_lParentHwnd As Long 'hwnd of the window the tooltip attached toPrivate ti As TOOLINFOPublic 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 = vDataEnd Property
Public Property Get Style () AS TTSTYLEENUM 'Used When Retrieving Value of A Property, on the right side of an assocignment.' Syntax: debug.print x.style style = mvarstyleend print
Public property let center (byval vdata as boolean) 'used when assigning a value to the property, on the left side of an associnment.' Syntax: x.cented = 5 mvarcentered = vDataEnd Property
Public property get centered () as boolean 'used When Retrieving value of a property, on the right side of an assocignment.' Syntax: debug.print x.Centered Center
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 &, _ App.hInstance, _ 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 = app.hinstance '.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 <> TTNOCION THEN SendMessage M_ltthwnd, TTM_SETTITITLE, CLNG (Mvaricon), Byval Mvartitle Endix
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, mvarDelayTimeEnd FunctionPublic Property Let Icon (ByVal vData As ttIconType) mvarIcon = vData If m_lTTHwnd <> 0 And mvartitle <> EMPTY AND MVARICON <> TTNOICON TEN DENDMESSAGE M_LTTHWND, TTM_SETTILE, CLNG (Mvaricon), BYVAL MVARTILE End IFEND Property
Public property get icon () as tticondype icon = mvariconend property
Public Property Let Forecolor (Byval VData As Long) MvarForeColor = VDATA IF M_LTTHWND <> 0 Then SendMessage M_ltthwnd, TTM_SETTIPTEXTCOLOR, MVARFORECOLOR, 0 & End IFEnd Property
Public property Get Forecolor () as long forecolor = mvarforeColorend Property
Public Property Let Title (ByVal vData As String) mvarTitle = vData If m_lTTHwnd <> 0 And mvarTitle <> Empty And mvarIcon <> TTNoIcon Then SendMessage m_lTTHwnd, TTM_SETTITLE, CLng (mvarIcon), ByVal mvarTitle End IfEnd Property
Public property get title () as string title = ti.lpstrend property
Public Property Let BackColor (Byval Vdata As Long) MVARBACKCOLOR = VDATA IF M_LTTHWND <> 0 Then SendMessage M_ltthwnd, TTM_SettipBkcolor, MvarbackColor, 0 & End IFEND Property
Public property get backcolor () as long backcolor = mvarbackColorend Property
Public Property Let Tiptext (Byval VData As String) Mvartiptext = VDATA TI.LPSTR = VDATA IF M_LTTHWND <> 0 THEN SENDMESSAGE M_LTTHWND, TTM_UPDATETEXTA, 0 &, TI End IFEND Property
Public property get tiptext () AS string tiptext = mvartiptextend print = mvartiptextendeprivate sub coplass_initialize () initcommontrols mvardelaytime = 500 mvarvisibletime = 5000END SUB
Private sub coplass_terminate () DestroyEnd Sub
Public Sub Destroy () if m_ltthwnd <> 0 Then DestroyWindow M_ltthWnd End Ifend Sub
Public property get visibletime () as long visibletime = mvarvisibletimend property
Public property Let Visibletime (Byval LData As Long) MVARVisibleTime = LDATAEND Property
Public property get delaytime () as long delaytime = mvardlaytimeend property
Public Property Let DelayTime (Byval Ldata As Long) MvardLaytime = LDataEnd Property
A form, a list of a listView control, the code is as follows:
Option expedition
Private Declare Function SendMessage Lib "User32" Alias "SendMessagea" _ (Byval Hwnd As Long, Byval WMSG As Long, Byval WParam As Long, LParam As An) AS LONG
Const LVM_First = & H1000 & const LVM_HITTEST = LVM_FIRST 18
Private Type Pointapi X As Long Y As Longend Type
Private type lvhitteinfo PT As Pointapi Flags As Long IIIM As Long Isubitem as LONGEND TYPE
DIM TT AS CTooltipdim M_LcuriteMindex As Long
Private Sub Form_Load () with listview1.listitems .add text: = "TEST ITEM # 1" .add text: = "Test item # 2" .add text: = "long long test item # 3" end with
Set tt = new ctooltip tt.style = ttballoon tt.icon = TTICIONFOEND SUB
