clstooltip.cls

一个clock的 vb 源码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsTooltip"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
'   English                          | 中文
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
'   API For Tooltip Control          | API Tooltip 控制
'   Code Number: 00009               | 代码编号：00009
'   Copyright: 2001-2002 Jiang Jian  | 版权所有：2001-2002 江建
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
'   Http:// vbcc.126.com             | 网址：http://vbcc.126.com
'   E-mail: [e-mail]            | 电子邮件：[e-mail]
'   Author: Jiang Jian               | 作者：江建
'   Date: 2002/04/20                 | 日期：2002年04月20日
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
'如果需要程序源代码请购买一套 vbAPI for Common Control 全套购买价格￥30
'汇款地址：安徽省淮南市李咀孜派出所江建收 邮政编码：232074

' The maximum tooltip width value does not indicate a
' tooltip window's actual width. Rather, if a tooltip
' string exceeds the maximum width, the control breaks
' the text into multiple lines, using spaces to determine
' line breaks. If the text cannot be segmented into multiple
' lines, it will be displayed on a single line. The length of
' this line may exceed the maximum (来自MSDN)多行提示

Private Const TOOLTIPS_CLASS = "tooltips_class32"
Private Const ICC_BAR_CLASSES = &H4            ' toolbar, statusbar, trackbar, tooltips

' Tooltip Stytle
Private Const TTS_ALWAYSTIP = &H1

' Tooltip Message
Private Const WM_USER = &H400
Private Const TTM_ADDTOOL = (WM_USER + 4)       ' 将Tooltip指定给窗口
Private Const TTM_SETDELAYTIME = (WM_USER + 3)  ' Tooltip 出现的时间
Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)

' Retrieve the length of time the tooltip window remains....
Private Const TTDT_AUTOPOP = &H2

' TOOLINFO uFlags
Private Const TTF_IDISHWND = &H1
Private Const TTF_SUBCLASS = &H10

Private Type TOOLINFO
    cbSize As Long
    uFlags As Long
    hWnd As Long
    uId As Long
    lpRect As RECT
    hinst As Long
    lpszText As String
End Type

Private hWndTT As Long

Public Sub CreateTooltip()
    hWndTT = CreateWindowEx(0, TOOLTIPS_CLASS, vbNullString, TTS_ALWAYSTIP, CW_USEDEFAULT, _
    CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0&, 0&, App.hInstance, 0&)
    SetWindowPos hWndTT, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End Sub


Public Function AddTooltip(strText As String, hWndWindow As Long)
    Dim ti As TOOLINFO
    With ti
        .cbSize = Len(ti)
        .hinst = App.hInstance
        .lpszText = strText
        .uFlags = TTF_SUBCLASS Or TTF_IDISHWND
        .uId = hWndWindow
    End With
    SendMessage hWndTT, TTM_ADDTOOL, 0, ti
End Function

Public Sub Tooltip_SetDelayTime(Optional DelayTime As Long = 4000)
    ' 设定出现的时间
    Call SendMessage(hWndTT, TTM_SETDELAYTIME, TTDT_AUTOPOP, ByVal DelayTime)
End Sub
    
Public Sub Tooltip_SetMaxWidth(Optional MaxWidth As Long = 288)
    ' 设定最大的宽度
    Call SendMessage(hWndTT, TTM_SETMAXTIPWIDTH, 0, ByVal MaxWidth)
End Sub

Private Sub Class_Initialize()
    Dim lpInitCtrls As INITCOMMONCONTROLSEXS
    lpInitCtrls.dwICC = ICC_BAR_CLASSES
    lpInitCtrls.dwSize = Len(lpInitCtrls)
    Call InitCommonControlsEx(lpInitCtrls)
    hWndTT = 0
End Sub

Private Sub Class_Terminate()
    If hWndTT <> 0 Then
        Call DestroyWindow(hWndTT)
    End If
End Sub