clstooltip.cls

基于MSFlexgrid控件的气泡提示,对mis编程很有用

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsTooltips"
Attribute VB_GlobalNameSpace = True
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：05/05/07
'描  述：MSFlexgrid控件的气泡提示示例
'网  站：http://www.mndsoft.com/
'e-mail：[e-mail]
'OICQ  : 88382850
'****************************************************************************
    '************************************************************
    '
    ' Tool Tip Class
    '
    ' 17-NOV-2004
    '
    ' Mark Mokoski
    ' C & M Telephone
    ' [e-mail]
    ' www.rjillc.com
    '
    ' Class for the creation of Rectangular and Balloon Multiline Tool Tips.
    '
    ' See Code for details on Syntax, variables and constants.
    '
    ' This Class Module works by sub classing the parent control.
    ' Works with most of the common controls, the ones it will not work
    ' with are controls that do not support tool tips themselves.
    ' There are some controls that support tool tips but complain with this
    ' sub classing module (only Microsoft knows why!).
    ' Do not use the native tool tip with the parent control and this together,
    ' you get overlapping tool tips!
    '
    ' This class module is also know to work on the following OS's (all Win32)
    ' Windows Me
    ' Windows 2000
    ' Windows XP
    ' MSDN Docs state that IE 5 or higher is needed for Balloon tips
    '
    ' It's usefull as it is written, so give it a try!
    '
    ' As brought to my attention on 01-DEC-2004
    ' Parts of this class was writen by Eidos on PSC
    ' I found it in bits on other sites and did the usual inprovments
    ' and changes to for my needs.
    '**************************************************************
    '
    ' Public Methods:
    '
    ' .CreateBalloon     Create Balloon Tool Tip
    ' .CreateTip         Create Rectangular Tool Tip
    ' .Remove            Kills Tool Tip object
    '
    ' Public Properties:
    '
    ' .Active            Boolean    Activate (visible)/Deactivate (hide) tool tip
    ' .ParentControl     Long       hWnd of Control that the tool tip is subclassed (displays on)to
    ' .Style             Enum Type  Tool Tip style, Rectangular or Balloon
    ' .Centered          Boolean    Tool Tip is centered on parent control when visible
    ' .Icon              Enum Type  Tool Tip Icon used when tool tip has a title
    ' .Title             Text       Tool Tip title text
    ' .Fore Color        Long       Tool Tip text color and border color if Balloon tip
    ' .BackColor         Long       Tool Tip Background color
    ' .TipText           Text       Tool Tip text
    ' .hWnd              Long       Tool Tip Windows Handle (.hWnd) READ ONLY
    '
    ' Sample code:
    '************************************************************
    '    Option Explicit
    '
    '   'Make new tool tip object for this project
    '   Dim Command1Tip              As New clsTooltips
    '
    '   Private Sub Form_Load()
    '
    '   'Make the complete Tool Tip, text, title, icon
    '   Command1Tip.CreateBalloon Command1, "I turned off all the Tool Tips " + vbCrLf + "Click to restore Tool Tips", "Tool Tips are OFF", tipIconWarning
    '
    '   End Sub
    '
    '   Put this delare in the Sub_Main module...
    '       'Int Common Controls Lib
    '       Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
    '
    '   Then call the sub in the Sub_Main
    '       'Int Common Controls Lib
    '       InitCommonControls
    '
    '************************************************************


    
    
    Option Explicit
    '************************************************************
    ' API Functions
    '************************************************************
    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 DestroyWindow Lib "user32" (ByVal HWND As Long) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal HWND As Long, 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 Function GetClientRect Lib "user32" (ByVal HWND As Long, lpRect As RECT) As Long
    Private Declare Function ShowWindow Lib "user32.dll" (ByVal HWND As Long, ByVal nCmdShow As Long) As Long

    'Int Common Controls Lib, put in startup module and execute
    '"InitCommonControls" in Sub_Main
    'Private Declare Sub InitCommonControls Lib "comctl32.dll" ()

    '************************************************************
    ' Constants
    '************************************************************
    'Windows API Constants
    Private Const WM_USER = &H400
    Private Const CW_USEDEFAULT = &H80000000
    Private Const SWP_NOSIZE = &H1
    Private Const SWP_NOACTIVATE = &H10
    Private Const SWP_NOMOVE = &H2
    Private Const HWND_TOPMOST = -1

    '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 TTM_SETDELAYTIME            As Long = WM_USER + 3
    Private Const TTM_SETMARGIN               As Long = WM_USER + 26
    Private Const TTS_BALLOON = &H40
    Private Const TTS_ALWAYSTIP = &H1
    Private Const TTF_SUBCLASS = &H10
    Private Const TTI_ERROR                   As Long = 3
    Private Const TTI_INFO                    As Long = 1
    Private Const TTI_NONE                    As Long = 0
    Private Const TTI_WARNING                 As Long = 2

    Private Const TOOLTIPS_CLASSA = "tooltips_class32"
    
    '************************************************************
    ' Types
    '************************************************************

    'Windows API Types

        Private Type RECT
            Left                              As Long
            Top                               As Long
            Right                             As Long
            Bottom                            As Long
        End Type
    
    'Tooltip Window Types

        Private Type TOOLINFO
            lSize                             As Long
            lFlags                            As Long
            TiphWnd                           As Long
            lId                               As Long
            lpRect                            As RECT
            hInstance                         As Long
            lpszText                          As String
            lParam                            As Long
        End Type

    '************************************************************
    'Local Class variables and Data
    '************************************************************

    'Local variables to hold property values
    Private toolBackColor                     As Long
    Private toolTitle                         As String
    Private toolForeColor                     As Long
    Private toolParentControl                 As Long
    Private toolIcon                          As toolIconType
    Private toolCentered                      As Boolean
    Private toolStyle                         As toolStyleEnum
    Private toolTipText                       As String
    Private toolActive                        As Boolean
    Private ToolLineLength                    As Integer
    Private ToolhWnd                          As Long
    
    'Private Data for Class
    Private TiphWnd                           As Long
    Private ti                                As TOOLINFO

    Public Enum toolIconType
    tipNoIcon = TTI_NONE            '= 0
    tipiconinfo = TTI_INFO          '= 1
    tipIconWarning = TTI_WARNING    '= 2
    tipIconError = TTI_ERROR        '= 3

    End Enum

    Public Enum toolStyleEnum
    styleStandard = 0
    styleBalloon = 1
    End Enum

    'Implements IDTExtensibility


Public Function CreateBalloon(ByVal Parent As Object, Text As String, Optional Title As String = vbNullString, Optional Icon As Integer = TTI_NONE)
    
    'Used to create a Balloon Tool Tip object.
    'Pass needed parameters with call.
    'Syntax: object.CreateBalloon ParentControl, Tip Text, Title, Icon
    'Title and Icon are optional, but you cant have an Icon without a Title
    'Title can be just a space, just not an empty string

    toolStyle = styleBalloon
    toolParentControl = Parent.HWND
    toolTipText = Text
    
        If Title = vbNullString Then
            toolTitle = ""
        Else
            toolTitle = Title
        End If
    
        If Icon = Icon > TTI_ERROR Then
            toolIcon = TTI_NONE
        Else
            toolIcon = Icon
        End If
    
    Call Create
    Active = True
    
End Function

Public Function CreateTip(ByVal Parent As Object, Text As String, Optional Title As String = vbNullString, Optional Icon As Integer = TTI_NONE)

    'Used to create a Standard (rectangle) Tool Tip object.
    'Pass needed parameters with call.
    'Syntax: object.CreateTip ParentControl, Tip Text, Title, Icon
    'Title and Icon are optional, but you cant have an Icon without a Title
    'Title can be just a space, just not an empty string
    
    toolStyle = styleStandard
    toolParentControl = Parent.HWND
    toolTipText = Text
    
        If Title = vbNullString Then
            toolTitle = ""
        Else
            toolTitle = Title
        End If
    
        If Icon = vbNull Or Icon > TTI_ERROR Then
            toolIcon = TTI_NONE
        Else
            toolIcon = Icon
        End If
    
    Call Create
    Active = True
    
End Function

Private Sub Create()

    'Private sub used with Create and Update subs/functions

    Dim lpRect               As RECT
    Dim lWinStyle            As Long
    
    'If Tool Tip already made, destroy it and reconstruct

        If TiphWnd <> 0 Then
            DestroyWindow TiphWnd
        End If
    
    'lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX
    lWinStyle = TTS_NOPREFIX
    
    
    'Create baloon style if desired

        If toolStyle = styleBalloon Then lWinStyle = lWinStyle Or TTS_BALLOON
    
    'The parent control has to be set first

        If toolParentControl <> &H0 Then
            TiphWnd = CreateWindowEx(0&, _
            TOOLTIPS_CLASSA, _
            vbNullString, _
            lWinStyle, _
            CW_USEDEFAULT, _
            CW_USEDEFAULT, _
            CW_USEDEFAULT, _
            CW_USEDEFAULT, _
            toolParentControl, _
            0&, _
            App.hInstance, _
            0&)
                    
            ToolhWnd = TiphWnd
            
            'Make our tooltip window a topmost window
            SetWindowPos TiphWnd, _
            HWND_TOPMOST, _