clstooltip.cls

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

            m_cRender.Gradient lHdc, 0, .Right, 0, .bottom, m_lColorOffset, m_lBackColor, Fill_Vertical
        End With
    Else
        PaintTip lHdc, tRect
    End If

    '/* shadow
    FrameTip lHdc, tRect
    '/* text
    lFntOld = SelectObject(lHdc, m_lhTitleFnt)
    DrawText lHdc, m_sTitle, m_tRTtl
    SelectObject lHdc, lFntOld
    lFntOld = SelectObject(lHdc, m_lhTextFnt)
    DrawText lHdc, m_sText, m_tRTxt
    SelectObject lHdc, lFntOld
    '/* icon
    DrawIcon lHdc, m_lIcon, m_tRIcn
    
    lWdc = GetDC(m_lToolHwnd)

    '/* shadow inset
    With tRect
        ExcludeClipRect lWdc, .Right - 3, .Top, .Right, .Top + 4
        ExcludeClipRect lWdc, .Left, .bottom, .Left + 4, .bottom - 3
    End With
    '/* draw to window
    With tRect
        If Not (m_lTransparency = -1) Then
            m_cRender.AlphaBlit lWdc, 0, 0, .Right, .bottom, lHdc, 0, 0, .Right, .bottom, m_lTransparency
        Else
            m_cRender.Blit lWdc, 0, 0, .Right, .bottom, lHdc, 0, 0, SRCCOPY
        End If
    End With
    
    '/* cleanup
    SelectObject lHdc, lFntOld
    ReleaseDC m_lToolHwnd, lWdc
    
End Sub

Private Sub DrawText(ByVal lHdc As Long, _
                     ByVal sText As String, _
                     ByRef tRect As RECT)

Dim lFlags As Long

    SetBkMode lHdc, BM_TRANSPARENT
    SetTextColor lHdc, m_lForeColor
    If m_bMultiline Then
        lFlags = DT_WORDBREAK Or DT_LEFT
    Else
        lFlags = DT_CENTER Or DT_VCENTER Or DT_SINGLELINE Or DT_END_ELLIPSIS
    End If
    
    If m_bIsNt Then
        sText = sText & Chr$(0)
        DrawTextW lHdc, StrPtr(sText), -1, tRect, lFlags
    Else
        DrawTextA lHdc, sText, -1, tRect, lFlags
    End If
    
End Sub

Private Sub DrawIcon(ByVal lHdc As Long, _
                     ByVal lIcon As Long, _
                     ByRef tRect As RECT)

    If Not (m_lImlHwnd = 0) Then
        If (lIcon > -1) Then
            With tRect
                ImageList_Draw m_lImlHwnd, lIcon, lHdc, .Left, .Top, ILD_NORMAL Or ILD_TRANSPARENT
            End With
        End If
    End If

End Sub

Private Sub FrameTip(ByVal lHdc As Long, _
                     ByRef tRect As RECT)

Dim lhBrush     As Long
Dim lhPen       As Long
Dim lhPenOld    As Long
Dim tPnt        As POINTAPI
Dim tRcpy       As RECT
    
    CopyRect tRcpy, tRect
    '/* draw 'shadow' lines
    With tRcpy
        '/* outer
        lhPen = CreatePen(0, 1, &H999999)
        lhPenOld = SelectObject(lHdc, lhPen)
        MoveToEx lHdc, .Left, .bottom - 1, tPnt
        LineTo lHdc, .Right - 1, .bottom - 1
        LineTo lHdc, .Right - 1, .Top
        SelectObject lHdc, lhPenOld
        DeleteObject lhPen
        '/* mid
        lhPen = CreatePen(0, 1, &H555555)
        lhPenOld = SelectObject(lHdc, lhPen)
        MoveToEx lHdc, .Left, .bottom - 2, tPnt
        LineTo lHdc, .Right - 2, .bottom - 2
        LineTo lHdc, .Right - 2, .Top
        SelectObject lHdc, lhPenOld
        DeleteObject lhPen
        '/* inner
        lhPen = CreatePen(0, 1, &H444444)
        lhPenOld = SelectObject(lHdc, lhPen)
        MoveToEx lHdc, .Left, .bottom - 3, tPnt
        LineTo lHdc, .Right - 3, .bottom - 3
        LineTo lHdc, .Right - 3, .Top
        SelectObject lHdc, lhPenOld
        DeleteObject lhPen
        .Right = .Right - 3
        .bottom = .bottom - 3
    End With
    '/* draw the frame
    lhBrush = CreateSolidBrush(&H808080)
    FrameRect lHdc, tRcpy, lhBrush
    DeleteObject lhBrush

End Sub

Private Sub PaintTip(ByVal lHdc As Long, _
                     ByRef tRect As RECT)

Dim lhBrush As Long

    lhBrush = CreateSolidBrush(m_lBackColor)
    FillRect lHdc, tRect, lhBrush
    DeleteObject lhBrush

End Sub


'> Fonts
'>>>>>>>>>>>>>>>>
Private Sub CreateFonts()

    DestroyFonts
    If (Font Is Nothing) Then
        DefaultFont m_oTitleFont, True
        DefaultFont m_oTextFont
    Else
        Set m_oTitleFont = m_oFont
        Set m_oTextFont = m_oFont
    End If
    m_lhTitleFnt = CreateFont(m_oTitleFont, True)
    m_lhTextFnt = CreateFont(m_oTextFont)
    
End Sub

Private Function CreateFont(ByVal oFont As StdFont, _
                            Optional ByVal bTitle As Boolean) As Long
'*/ change list font

Dim lChar   As Long
Dim lHdc    As Long
Dim tLF     As LOGFONT

    If Not (oFont Is Nothing) Then
        lHdc = CreateDc("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
        With tLF
            For lChar = 1 To Len(oFont.Name)
                .lfFaceName(lChar - 1) = CByte(Asc(Mid$(oFont.Name, lChar, 1)))
            Next lChar
            If bTitle Then
                oFont.Bold = True
                oFont.Size = 9
            End If
            .lfHeight = -MulDiv(oFont.Size, GetDeviceCaps(lHdc, LOGPIXELSY), 72)
            .lfItalic = oFont.Italic
            .lfWeight = IIf(oFont.Bold, FW_BOLD, FW_NORMAL)
            .lfUnderline = oFont.Underline
            .lfStrikeOut = oFont.Strikethrough
            .lfCharSet = 4
            .lfQuality = LF_ANTIALIASED_QUALITY
        End With
        DeleteDC lHdc
        If m_bIsNt Then
            CreateFont = CreateFontIndirectW(tLF)
        Else
            CreateFont = CreateFontIndirectA(tLF)
        End If
    End If

End Function

Private Sub DefaultFont(ByRef oFont As StdFont, _
                        Optional ByVal bTitle As Boolean)

    Set oFont = New StdFont
    With oFont
        .Charset = 3
        .Name = "MS Sans Serif"
        .Weight = 400
        .Size = 8
        If bTitle Then
            .Bold = True
        End If
    End With

End Sub

Private Sub DestroyFonts()

    If Not (m_lhTitleFnt = 0) Then
        DeleteObject m_lhTitleFnt
        m_lhTitleFnt = 0
    End If
    If Not (m_oTitleFont Is Nothing) Then
        Set m_oTitleFont = Nothing
    End If
    
    If Not (m_lhTextFnt = 0) Then
        DeleteObject m_lhTextFnt
        m_lhTextFnt = 0
    End If
    If Not (m_oTextFont Is Nothing) Then
        Set m_oTextFont = Nothing
    End If

End Sub

Private Function FunctionExported(ByVal sFunction As String, _
                                  ByVal sModule As String) As Boolean
'/* test for library support

Dim lModule As Long

    If m_bIsNt Then
        lModule = GetModuleHandleW(StrPtr(sModule))
        If (lModule = 0) Then
            lModule = LoadLibraryW(StrPtr(sModule))
        End If
    Else
        lModule = GetModuleHandleA(sModule)
        If (lModule = 0) Then
            lModule = LoadLibraryA(sModule)
        End If
    End If
    If Not (lModule = 0) Then
        If GetProcAddress(lModule, StrPtr(sFunction)) Then
            FunctionExported = True
        End If
        FreeLibrary lModule
    End If

End Function

Private Sub TrackMouse(ByVal lHwnd As Long)

Dim tMe As TRACKMOUSEEVENT_STRUCT

    With tMe
        .cbSize = Len(tMe)
        .dwFlags = TME_LEAVE
        .hwndTrack = lHwnd
    End With

    If m_bTrackUser32 Then
        TrackMouseEvent tMe
    Else
        TrackMouseEventComCtl tMe
    End If

End Sub

'> Subclass
'>>>>>>>>>>>>>>>>

Public Function StartTimer() As Boolean
'/* start display timer

    If Not m_bTimerActive Then
        m_TTSubclass.AddMessage m_lCtrlHwnd, WM_TIMER, MSG_BEFORE
        SetTimer m_lCtrlHwnd, 1&, 100&, 0&
        m_bTimerActive = True
    End If

End Function

Public Function StopTimer() As Boolean
'/* stop display timer

    If m_bTimerActive Then
        KillTimer m_lCtrlHwnd, 1&
        m_TTSubclass.DeleteMessage m_lCtrlHwnd, WM_TIMER, MSG_BEFORE
        DestroyToolTip
        m_bTimerActive = False
        m_lSafeTimer = 0
    End If

End Function


Private Sub MessageAttach()

    If Not m_TTSubclass Is Nothing Then
        If Not m_bIsActive Then
            With m_TTSubclass
                .Subclass m_lCtrlHwnd, Me
                If m_bAutoTips Then
                    .AddMessage m_lCtrlHwnd, WM_LBUTTONDOWN, MSG_BEFORE
                    .AddMessage m_lCtrlHwnd, WM_MOUSEMOVE, MSG_BEFORE
                    .AddMessage m_lCtrlHwnd, WM_MOUSELEAVE, MSG_BEFORE
                End If
            End With
            m_bIsActive = True
        End If
    End If
    
End Sub

Private Sub MessageDetach()

    If Not m_TTSubclass Is Nothing Then
        If m_bIsActive Then
            With m_TTSubclass
                If m_bAutoTips Then
                    .DeleteMessage m_lCtrlHwnd, WM_LBUTTONDOWN, MSG_BEFORE
                    .DeleteMessage m_lCtrlHwnd, WM_MOUSEMOVE, MSG_BEFORE
                    .DeleteMessage m_lCtrlHwnd, WM_MOUSELEAVE, MSG_BEFORE
                End If
                .UnSubclass m_lCtrlHwnd
            End With
            m_bIsActive = False
        End If
    End If
    
End Sub

Private Sub GXISubclass_WndProc(ByVal bBefore As Boolean, _
                                bHandled As Boolean, _
                                lReturn As Long, _
                                ByVal lHwnd As Long, _
                                ByVal uMsg As eMsg, _
                                ByVal wParam As Long, _
                                ByVal lParam As Long, _
                                lParamUser As Long)
    
    Select Case uMsg
    Case WM_LBUTTONDOWN
        StopTimer

    Case WM_MOUSEMOVE
        If Not m_bVisiting Then
            StartTimer
            m_bVisiting = True
        End If
        TrackMouse lHwnd
    
    Case WM_MOUSELEAVE
        m_bVisiting = False
        StopTimer
    
    Case WM_TIMER
        ToolTipTrack
    End Select
    
End Sub

Private Sub ToolTipTrack()

Dim tPnt As POINTAPI

    '/* stationary cursor
    GetCursorPos tPnt
    With tPnt
        If (.x = m_lLastX) Then
            If (.y = m_lLastY) Then
                m_lSafeTimer = m_lSafeTimer + 1
            Else
                m_lSafeTimer = 0
            End If
        Else
            m_lSafeTimer = 0
        End If
        m_lLastX = .x
        m_lLastY = .y
    End With
    '/* show tip
    If (m_lSafeTimer > (m_lDelayTime * 10)) Then
        If Not m_bShowing Then
            DrawTip
            m_bShowing = True
        End If
    End If
    '/* destroy tip
    If (m_lSafeTimer > ((m_lDelayTime + m_lVisibleTime) * 10)) Then
        If m_bShowing Then
            DestroyToolTip
            StopTimer
            m_bShowing = False
        End If
    End If
    
End Sub

'> Cleanup
'>>>>>>>>>>>>>>>>
Public Sub DestroyToolTip()

    If Not (m_lToolHwnd = 0) Then
        DestroyWindow m_lToolHwnd
        m_lToolHwnd = 0
        m_bShowing = False
    End If

End Sub

Public Sub Destroy()

    StopTimer
    If m_bIsActive Then
        MessageDetach
    End If
    DestroyToolTip
    DestroyFonts
    If Not Font Is Nothing Then Set Font = Nothing
    If Not m_TTSubclass Is Nothing Then Set m_TTSubclass = Nothing
    If Not m_cRender Is Nothing Then Set m_cRender = Nothing
    If Not m_cToolDc Is Nothing Then Set m_cToolDc = Nothing

End Sub

Private Sub Class_Terminate()
    Destroy
End Sub