clstooltip.cls

一款Grid表格控件源代码,非常棒.不下你一定会后悔

Private m_cToolDc                               As clsStoreDc
Private m_cRender                               As clsRender
Private m_TTSubclass                            As GXMSubclass


Private Sub Class_Initialize()

    m_bIsNt = CompatabilityCheck
    Set m_TTSubclass = New GXMSubclass
    Set m_cRender = New clsRender
    Set m_cToolDc = New clsStoreDc
    m_bTrackUser32 = FunctionExported("TrackMouseEvent", "User32")
    m_lWidth = 150
    m_lBackColor = GetSysColor(&H80000018 And &H1F)
    m_lForeColor = &H343434
    m_lIcon = -1
    m_lTransparency = -1
    m_lColorOffset = &HCACACA
    m_lDelayTime = 1
    m_lVisibleTime = 2
    m_lForeColor = &H333333

End Sub

Public Property Get AutoTips() As Boolean
    AutoTips = m_bAutoTips
End Property

Public Property Let AutoTips(ByVal PropVal As Boolean)
    m_bAutoTips = PropVal
End Property

Public Property Get BackColor() As Long
    BackColor = m_lBackColor
End Property

Public Property Let BackColor(ByVal PropVal As Long)
    If m_bXPColors Then
        m_lBackColor = m_cRender.XPShift(PropVal)
    Else
        m_lBackColor = PropVal
    End If
End Property

Public Property Get ColorOffset() As Long
    ColorOffset = m_lColorOffset
End Property

Public Property Let ColorOffset(ByVal PropVal As Long)
    If m_bXPColors Then
        m_lColorOffset = m_cRender.XPShift(PropVal)
    Else
        m_lColorOffset = PropVal
    End If
End Property

Public Property Get CtrlHwnd() As Long
    CtrlHwnd = m_lCtrlHwnd
End Property

Public Property Let CtrlHwnd(ByVal PropVal As Long)
    m_lCtrlHwnd = PropVal
End Property

Public Property Get DelayTime() As Long
    DelayTime = m_lDelayTime
End Property

Public Property Let DelayTime(ByVal PropVal As Long)
    m_lDelayTime = PropVal
End Property

Public Property Get Font() As StdFont
    Set Font = m_oFont
End Property

Public Property Set Font(ByVal PropVal As StdFont)
    Set m_oFont = PropVal
End Property

Public Property Get ForeColor() As Long
    ForeColor = m_lForeColor
End Property

Public Property Let ForeColor(ByVal PropVal As Long)
    m_lForeColor = PropVal
End Property

Public Property Get Gradient() As Boolean
    Gradient = m_bGradient
End Property

Public Property Let Gradient(ByVal PropVal As Boolean)
    m_bGradient = PropVal
End Property

Public Property Get Height() As Long
    Height = m_lHeight
End Property

Public Property Let Height(ByVal PropVal As Long)
    m_lHeight = PropVal
End Property

Public Property Get Icon() As Long
    Icon = m_lIcon
End Property

Public Property Let Icon(ByVal PropVal As Long)
    m_lIcon = PropVal
End Property

Public Property Get ImlHwnd() As Long
    ImlHwnd = m_lImlHwnd
End Property

Public Property Let ImlHwnd(ByVal PropVal As Long)
    m_lImlHwnd = PropVal
End Property

Public Property Get Multiline() As Boolean
    Multiline = m_bMultiline
End Property

Public Property Let Multiline(ByVal PropVal As Boolean)
    m_bMultiline = PropVal
End Property

Public Property Get RestrictToClient() As Boolean
    RestrictToClient = m_bRestrictToClient
End Property

Public Property Let RestrictToClient(ByVal PropVal As Boolean)
    m_bRestrictToClient = PropVal
End Property

Public Property Get Text() As String
    Text = m_sText
End Property

Public Property Let Text(ByVal PropVal As String)
    m_sText = PropVal
End Property

Public Property Get Title() As String
    Title = m_sTitle
End Property

Public Property Let Title(ByVal PropVal As String)
    m_sTitle = PropVal
End Property

Public Property Get ToolTipPosition() As ETPToolTipPosition
    ToolTipPosition = m_lToolTipPosition
End Property

Public Property Let ToolTipPosition(ByVal PropVal As ETPToolTipPosition)
    m_lToolTipPosition = PropVal
End Property

Public Property Get Transparency() As Long
    Transparency = m_lTransparency
End Property

Public Property Let Transparency(ByVal PropVal As Long)
    m_lTransparency = PropVal
End Property

Public Property Get VisibleTime() As Long
    VisibleTime = m_lVisibleTime
End Property

Public Property Let VisibleTime(ByVal PropVal As Long)
    m_lVisibleTime = PropVal
End Property

Public Property Get Width() As Long
    Width = m_lWidth
End Property

Public Property Let Width(ByVal PropVal As Long)
    m_lWidth = PropVal
End Property

Public Property Get XPColors() As Boolean
    XPColors = m_bXPColors
End Property

Public Property Let XPColors(ByVal PropVal As Boolean)
    m_bXPColors = PropVal
End Property

'> Create
'>>>>>>>>>>>>>>>>
Private Sub CalcTextRect(ByVal lHdc As Long, _
                         ByVal lWidth As Long, _
                         ByVal sText As String, _
                         ByVal lFlags As Long, _
                         ByVal lFont As Long, _
                         ByRef tRect As RECT)

Dim lFntOld As Long

    tRect.Right = lWidth
    lFntOld = SelectObject(lHdc, lFont)
    If m_bIsNt Then
        DrawTextW lHdc, StrPtr(sText), -1, tRect, lFlags
    Else
        DrawTextA lHdc, sText, -1, tRect, lFlags
    End If
    SelectObject lHdc, lFntOld
    
End Sub

Private Sub CalculateOffsets()

Dim lHdc    As Long
Dim lCx     As Long
Dim lCy     As Long
Dim lTHgt   As Long
Dim lMnHt   As Long
Dim lFlags  As Long
Dim tPnt    As POINTAPI

    '/* icon size
    If Not (m_lImlHwnd = 0) Then
        If Not (m_lIcon = -1) Then
            ImageList_GetIconSize m_lImlHwnd, lCx, lCy
            With m_tRIcn
                .Left = 8
                .Top = 8
                .Right = (lCx + 8)
                .bottom = (lCy + 8)
                lMnHt = (.bottom + 8)
                m_tRTtl.Left = (.Right + 8)
            End With
        Else
            m_tRTtl.Left = 8
        End If
    Else
        m_tRTtl.Left = 8
    End If
    
    '/* create fonts
    CreateFonts
    lHdc = GetDC(m_lToolHwnd)
    
    If m_bMultiline Then
        lFlags = DT_WORDBREAK Or DT_CALCRECT
        '/* calculate title height
        With m_tRTtl
            .Top = 8
            CalcTextRect lHdc, m_lWidth, m_sTitle, lFlags, m_lhTitleFnt, m_tRTtl
            lTHgt = .bottom + 4
        End With
        '/* calculate text
        With m_tRTxt
            .Top = lTHgt
            .Left = m_tRTtl.Left
            CalcTextRect lHdc, m_lWidth, m_sText, lFlags, m_lhTextFnt, m_tRTxt
            lTHgt = .bottom + 10
            If (.Right > m_tRTtl.Right) Then
                m_lWidth = .Right + 10
            Else
                m_lWidth = m_tRTtl.Right + 10
            End If
        End With
    Else
        lFlags = DT_LEFT Or DT_CALCRECT
        m_tRTtl.Top = 8
        CalcTextRect lHdc, 0, m_sTitle, lFlags, m_lhTitleFnt, m_tRTtl
        With m_tRTtl
            m_lWidth = .Right + 6
        End With
        With m_tRTxt
            .Top = 8
            .Left = m_lWidth
            CalcTextRect lHdc, 0, m_sText, lFlags, m_lhTextFnt, m_tRTxt
            lTHgt = .bottom + 8
            m_lWidth = .Right + 4
        End With
    End If
    '/* test minimum
    If (lTHgt > lMnHt) Then
        m_lHeight = lTHgt
    Else
        m_lHeight = lMnHt
    End If
    
    ReleaseDC m_lToolHwnd, lHdc
    GetCursorPos tPnt
    ScreenToClient m_lParentHwnd, tPnt
    
    '/* window size
    With m_tRWnd
        '/* shadow offset
        .Right = m_lWidth + 4
        .bottom = m_lHeight + 4
        Select Case m_lToolTipPosition
        Case 0
            .Top = tPnt.y + 4
            .Left = tPnt.x + 4
        Case 1
            .Top = (tPnt.y + 4) + (m_lHeight / 2)
            .Left = tPnt.x + 4
        Case 2
            .Top = (tPnt.y + 4) + m_lHeight
            .Left = tPnt.x + 4
        Case 3
            .Top = tPnt.y + 4
            .Left = tPnt.x - 4
        Case 4
            .Top = (tPnt.y + 4) + (m_lHeight / 2)
            .Left = tPnt.x - 4
        Case 5
            .Top = (tPnt.y + 4) + m_lHeight
            .Left = tPnt.x - 4
        End Select
    End With
    
End Sub

Private Function CompatabilityCheck() As Boolean

Dim tVer  As VERSIONINFO

    tVer.dwOSVersionInfoSize = Len(tVer)
    GetVersionEx tVer
    If tVer.dwMajorVersion >= 5 Then
        CompatabilityCheck = True
    End If

End Function

Private Sub CreateToolTip()

Dim bOnDesktop  As Boolean
Dim lTTStyle    As Long

    If m_bRestrictToClient Then
        m_lParentHwnd = GetParent(m_lCtrlHwnd)
        If m_lParentHwnd = 0 Then
            m_lParentHwnd = m_lCtrlHwnd
        End If
        bOnDesktop = (m_lParentHwnd = GetDesktopWindow())
        If bOnDesktop Then
            m_bRestrictToClient = False
        End If
    Else
        m_lParentHwnd = GetDesktopWindow()
        bOnDesktop = True
    End If
    lTTStyle = SS_OWNERDRAW Or WS_CHILD Or WS_CLIPSIBLINGS Or WS_OVERLAPPED
    
    '/* create window
    If m_bIsNt Then
        m_lToolHwnd = CreateWindowExW(-bOnDesktop * WS_EX_TOOLWINDOW, StrPtr("Static"), StrPtr(""), lTTStyle, _
            0&, 0&, 0&, 0&, m_lParentHwnd, 0, App.hInstance, ByVal 0&)
    Else
        m_lToolHwnd = CreateWindowExA(-bOnDesktop * WS_EX_TOOLWINDOW, "Static", "", lTTStyle, _
            0&, 0&, 0&, 0&, m_lParentHwnd, 0, App.hInstance, ByVal 0&)
    End If

End Sub

Private Sub SetPosition()
    
    If Not (m_lToolHwnd = 0) Then
        With m_tRWnd
            If m_bRestrictToClient Then
                SetWindowPos m_lToolHwnd, 0&, .Left, .Top, .Right, .bottom, SWP_SHOWWINDOW Or SWP_NOACTIVATE
            Else
                SetWindowPos m_lToolHwnd, -1&, .Left, .Top, .Right, .bottom, SWP_SHOWWINDOW Or SWP_NOACTIVATE
            End If
        End With
    End If

End Sub

Public Sub ShowTipManual(ByVal lHwnd As Long, _
                         ByVal sText As String, _
                         ByVal sTitle As String, _
                         ByVal lIcon As Long, _
                         ByVal lWidth As Long)

    If Not (lHwnd = 0) Then
        m_lCtrlHwnd = lHwnd
        Text = sText
        Title = sTitle
        Icon = lIcon
        Width = lWidth
        DrawTip
    End If

End Sub

Public Sub Start()
    
    If Not (m_lCtrlHwnd = 0) Then
        If Not m_bIsActive Then
            MessageAttach
        End If
    End If
    
End Sub

'> Render
'>>>>>>>>>>>>>>>>
Public Sub DrawTip()

    CreateToolTip
    CalculateOffsets
    SetPosition
    RenderTip
            
End Sub

Private Sub RenderTip()

Dim lWdc    As Long
Dim lHdc    As Long
Dim lFntOld As Long
Dim tRect   As RECT

    GetClientRect m_lToolHwnd, tRect
    '/* draw dc
    With m_cToolDc
        .Width = tRect.Right
        .Height = tRect.bottom
        lHdc = .hdc
    End With
    '/* gradient
    If m_bGradient Then
        With tRect