clstooltip.cls

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

            0&, _
            0&, _
            0&, _
            0&, _
            SWP_NOACTIVATE Or SWP_NOSIZE Or SWP_NOMOVE
                    
            'Get the rectangle of the parent control
            GetClientRect toolParentControl, lpRect
        
            'Now set up our tooltip info structure

                With ti
                    'If we want it centered, then set that flag

                        If toolCentered Then
                            .lFlags = TTF_SUBCLASS Or TTF_CENTERTIP
                        Else
                            .lFlags = TTF_SUBCLASS
                        End If
            
                    ''set the hwnd prop to our parent control's hwnd
                    .TiphWnd = toolParentControl
                    .lId = 0
                    .hInstance = App.hInstance
                    .lpszText = toolTipText
                    .lpRect = lpRect
                End With
        
            'Add the tooltip structure
            SendMessage TiphWnd, TTM_ADDTOOLA, 0&, ti
            
            'Set Max Width to 32 characters, and enable Multi Line Tool Tips
            SendMessage TiphWnd, TTM_SETMAXTIPWIDTH, 0&, &H20
            
            'If we want a title or we want an icon

            'If toolTitle <> vbNullString Or toolIcon <> tipNoIcon Then
            SendMessage TiphWnd, TTM_SETTITLE, CLng(toolIcon), ByVal toolTitle
            'End If
        
                If toolForeColor <> Empty Then
                    '0 (zero) or Null is seen by the API as the default color
                    'See ForeColor property for more datails
                    SendMessage TiphWnd, TTM_SETTIPTEXTCOLOR, toolForeColor, 0&
                End If
        
                If toolBackColor <> Empty Then
                    '0 (zero) or Null is seen by the API as the default color
                    'See BackColor property for more datails
                    SendMessage TiphWnd, TTM_SETTIPBKCOLOR, toolBackColor, 0&
                End If
        
        End If

End Sub

Private Sub UpDate()
    
    Dim aTemp                As Boolean

    'Used to update tooltip parameters that require reconfiguration of
    'subclass to envoke
    
    'Get current Atcive state
    aTemp = Active
    'Refresh the object
    Call Create
    'Restore the Active state
    Active = aTemp
    
End Sub

Public Property Let Active(ByVal tooldata As Boolean)

    'If True, activate (show) tool tip, False deactivate (hide) tool tip
    'Syntax: object.active= true/false
    toolActive = tooldata
    SendMessage TiphWnd, TTM_ACTIVATE, CInt(toolActive), ti
    
    
End Property

Public Property Get Active() As Boolean

    'Retrieving value of a property, Boolean responce (true/false)
    'Syntax: BooleanVar = object.Active
    Active = toolActive
    
End Property

Public Property Set ParentControl(ByVal tooldata As Object)

    'Assigning an Object to the property, set to parent object(control)
    'that the Tool Tip will "pop" up from
    'Syntax: Set object.ParentControl = ParentObject
    toolParentControl = tooldata.HWND
    UpDate
    
End Property


Public Property Get ParentControl() As Long

    'Retrieving value of a property, returns Long Windows Handle (hWnd)of Parent.
    'Syntax: ObjectVar =  object.ParentControl
    ParentControl = toolParentControl

End Property

Public Property Let Style(ByVal tooldata As toolStyleEnum)

    'Assigning a value to the property, set style param Standard or Balloon
    'Syntax: object.Style = style
    toolStyle = tooldata
    UpDate
    
End Property


Public Property Get Style() As toolStyleEnum

    'Retrieving value of a property, returns string.
    'Syntax: StringVar = object.Style
    Style = toolStyle
    
End Property


Public Property Let Centered(ByVal tooldata As Boolean)

    'Assigning a value to the property, Set Boolean true/false if ToolTip
    'is centered on the parent control
    'Syntax: object.Centered = true/false
    toolCentered = tooldata
    UpDate
    
End Property


Public Property Get Centered() As Boolean

    'Retrieving value of a property, returns Boolean true/false.
    'Syntax: BooleanVar =  object.Centered
    Centered = toolCentered
    UpDate
    
End Property

Public Property Let Icon(ByVal tooldata As toolIconType)

    'Assigning a value to the property, set icon style with type var.
    'Syntax: object.Icon = iconStyle
    'Icon Styles are: INFO, WARNING and ERROR (tipNoIcom, tipIconInfo, tipIconWarning, tipIconError)
    toolIcon = tooldata
        
    'If tipHwnd <> 0 And toolTitle <> Empty And toolIcon <> tipNoIcon Then

        If TiphWnd <> 0 Then
            SendMessage TiphWnd, TTM_SETTITLE, CLng(toolIcon), ByVal toolTitle
        End If
        
    UpDate
    
End Property


Public Property Get Icon() As toolIconType

    'Retrieving value of a property, returns string.
    'Syntax: StringVar =  object.Icon
    Icon = toolIcon

End Property


Public Property Let ForeColor(ByVal tooldata As Long)

    'Assigning a value to the property, set RGB value as Long.
    'Syntax: object.ForeColor = RGB (as Long)
    'Since 0 is Black (no RGB), and the API thinks 0 is
    'the default color ("off" yellow),
    'we need to "fudge" Black a bit (yes set bit "1" to "1",)
    'I couldn't resist the pun!
    'So, in module or form code, if setting to Black, make it "1"
    'if restoring the default color, make it "0"
    'Syntax: object.ForeColor = RGB(as long)
    
    toolForeColor = tooldata

        If TiphWnd <> 0 Then
            SendMessage TiphWnd, TTM_SETTIPTEXTCOLOR, toolForeColor, 0&
        End If
        
    UpDate
    
End Property


Public Property Get ForeColor() As Long

    'Retrieving value of a property, returns RGB value as Long.
    'Syntax: LongVar =  object.ForeColor
    ForeColor = toolForeColor

End Property



Public Property Let Title(ByVal tooldata As String)

    'Assigning a value to the property, set as string.
    'Syntax: object.Title = StringVar
    toolTitle = tooldata
        
    'If tipHwnd <> 0 And toolTitle <> Empty And toolIcon <> tipNoIcon Then

        If TiphWnd <> 0 Then
            SendMessage TiphWnd, TTM_SETTITLE, CLng(toolIcon), ByVal toolTitle
        End If
        
    UpDate
    
End Property


Public Property Get Title() As String

    'Retrieving value of a property, returns string.
    'Syntax: StringVar =  object.Title
    Title = toolTitle

End Property


Public Property Let BackColor(ByVal tooldata As Long)

    'Assigning a value to the property, set RGB value as Long.
    'Syntax: object.BackColor = RGB (as Long)
    'Since 0 is Black (no RGB), and the API thinks 0 is
    'the default color ("off" yellow),
    'we need to "fudge" Black a bit (yes set bit "1" to "1",)
    'I couldn't resist the pun!
    'So, in module or form code, if setting to Black, make it "1"
    'if restoring the default color, make it "0"
    
    toolBackColor = tooldata

        If TiphWnd <> 0 Then
            SendMessage TiphWnd, TTM_SETTIPBKCOLOR, toolBackColor, 0&
        End If
        
    UpDate
    
End Property


Public Property Get BackColor() As Long

    'Retrieving value of a property, returns RGB as Long.
    'Syntax: LongVar =  object.BackColor

    BackColor = toolBackColor

End Property



Public Property Let TipText(ByVal tooldata As String)

    'Assigning a value to the property, Set as String.
    'Syntax: object.TipText = StringVar
    'Multi line Tips are enabled in the Create sub.
    'To change lines, just add a vbCrLF between text
    'ex. object.TipText= "Line 1 text" & vbCrLF & "Line 2 text"
    
    toolTipText = tooldata
    ti.lpszText = toolTipText

        If TiphWnd <> 0 Then
            SendMessage TiphWnd, TTM_UPDATETIPTEXTA, 0&, ti
        End If
    
    UpDate
    
End Property


Public Property Get TipText() As String

    'Retrieving value of a property, returns string.
    'Syntax: StringVar =  object.TipText
    TipText = toolTipText

End Property

Public Property Get HWND() As Long

    'Retrive Windows Handle of the Tool Tip
    'Syntax: LongVar = object.ToolhWnd
    HWND = ToolhWnd
    
End Property


Public Function Remove() As Boolean

    'Kills Tool Tip Object
    Tool_Tip_Terminate
    
End Function

Private Sub Tool_Tip_Terminate()

        If TiphWnd <> 0 Then
            DestroyWindow TiphWnd
        End If
    
End Sub