VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cToolTip"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

Option Explicit
Private Declare Function MoveWindow Lib "user32" (ByVal Hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal Hwnd As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal Hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function RoundRect Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function FrameRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal Hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal lngHandler As Long, ByVal lngIndex As Long) As Long
Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal lngHandler As Long, ByVal lngIndex As Long, ByVal lngNewClassLong As Long) As Long

Private Type RECT
    Left                        As Long
    Top                         As Long
    Right                       As Long
    Bottom                      As Long
End Type

Private Type POINTAPI
    x                           As Long
    y                           As Long
End Type


Private Const CS_DROPSHADOW As Long = &H20000
Private Const GCL_STYLE As Long = -26

Private Const DT_CENTER = &H1
Private Const DT_WORDBREAK = &H10
Private Const DT_CALCRECT As Long = &H400
Private Const DT_LEFT As Long = &H0
Private Const TRANSPARENT = 1

Implements iWindow

Private c_cWindow               As cWindow
Private WithEvents c_cTimer     As cTimer
Attribute c_cTimer.VB_VarHelpID = -1
Private c_lhWnd                 As Long

Dim m_Text As String
Dim m_Cont As Long
Dim Rec As RECT
Dim m_DC As Long

Private Function SafeDiv(X1 As Double, X2 As Double) As Double
    If X2 = 0 Then SafeDiv = 0 Else SafeDiv = X1 / X2
End Function

Private Sub PaintGradient(Hwnd As Long, m_DC As Long, ColorStar As Long, ColorEnd As Long, WinRect As RECT)
    Dim Red1 As Integer, Green1 As Integer, Blue1 As Integer
    Dim Red2 As Integer, Green2 As Integer, Blue2 As Integer
    Dim ColorRect   As RECT
    Dim i           As Long
    Dim hBrush      As Long
    Dim hPrevBrush  As Long
    Dim DivValue    As Double
    Dim CurrRed     As Integer
    Dim CurrGreen   As Integer
    Dim CurrBlue    As Integer
    
    
Blue1 = (ColorStar And &HFF0000) / (2 ^ 16)
Green1 = (ColorStar And &HFF00&) / (2 ^ 8)
Red1 = (ColorStar And &HFF&)
Blue2 = (ColorEnd And &HFF0000) / (2 ^ 16)
Green2 = (ColorEnd And &HFF00&) / (2 ^ 8)
Red2 = (ColorEnd And &HFF&)

    For i = WinRect.Top To WinRect.Bottom
        DivValue = SafeDiv((WinRect.Bottom - WinRect.Top), (i - WinRect.Top))
        CurrRed = Red1 + SafeDiv((Red2 - Red1), DivValue)
        CurrGreen = Green1 + SafeDiv((Green2 - Green1), DivValue)
        CurrBlue = Blue1 + SafeDiv((Blue2 - Blue1), DivValue)
        SetRect ColorRect, WinRect.Left, i, WinRect.Right, i + 1
        hBrush = CreateSolidBrush(RGB(CurrRed, CurrGreen, CurrBlue))
        hPrevBrush = SelectObject(m_DC, hBrush)
        FillRect m_DC, ColorRect, hBrush
        SelectObject m_DC, hPrevBrush
        DeleteObject hBrush
    Next
End Sub



Private Sub c_cTimer_PulseTimer()
    Dim PT As POINTAPI
    Dim Width As Long
    Dim Height As Long
    Dim hFrgn As Long
    
    m_Cont = m_Cont + 1

    Select Case m_Cont
        Case 20
            
            Call GetCursorPos(PT)
            

        
            
            Width = GetTextWidth(m_DC, m_Text) + 10
            Height = GetTextHeight(m_DC, m_Text) + 10
            

            
            If PT.x + Width > Screen.Width / Screen.TwipsPerPixelX Then
                If Height + PT.y + 24 > (Screen.Height / Screen.TwipsPerPixelY) Then
                    PT.y = PT.y - Height
                    PT.x = (Screen.Width / Screen.TwipsPerPixelX) - Width
                Else
                    PT.x = (Screen.Width / Screen.TwipsPerPixelX) - Width
                    PT.y = PT.y + 24
                End If
            Else
                If Height + PT.y + 24 > (Screen.Height / Screen.TwipsPerPixelY) Then
                    PT.y = PT.y - Height
                Else
                    PT.y = PT.y + 24
                    
                End If
            End If

            Call MoveWindow(c_lhWnd, PT.x, PT.y, Width, Height, 1)
            
            SetLayeredWindowAttributes c_lhWnd, 0, 50, LWA_ALPHA
            Call ShowWindow(c_lhWnd, SW_SHOW)

            SetRect Rec, 0, 0, Width, Height
            
            hFrgn = CreateRoundRectRgn(0, 0, Width, Height, 12, 12)
            SetWindowRgn c_lhWnd, hFrgn, True
            DeleteObject hFrgn
            
            Call PaintGradient(c_lhWnd, m_DC, vbWhite, &HC8C8C8, Rec)
    
            hFrgn = CreateRoundRectRgn(0, 0, Width, Height, 12, 12)
            DrawRgnRectangle hFrgn, &HC8C8C8, m_DC
            DeleteObject hFrgn
            
            SetRect Rec, 5, 5, Width, Height
            DrawText m_DC, m_Text, Len(m_Text), Rec, DT_LEFT
            
            
        Case 21: SetLayeredWindowAttributes c_lhWnd, 0, 120, LWA_ALPHA
        Case 22: SetLayeredWindowAttributes c_lhWnd, 0, 255, LWA_ALPHA
        Case 150: SetLayeredWindowAttributes c_lhWnd, 0, 120, LWA_ALPHA
        Case 151: SetLayeredWindowAttributes c_lhWnd, 0, 50, LWA_ALPHA
        Case 152
            Call c_cTimer.StopTimer
            m_Cont = 0
            Call ShowWindow(c_lhWnd, SW_HIDE)
    End Select
End Sub

Private Sub Class_Initialize()

    Set c_cTimer = New cTimer
    Set c_cWindow = New cWindow
    
    With c_cWindow
        Set .Owner = Me
        .WindowClassRegister "CWL_ToolTip" & ObjPtr(Me)
        c_lhWnd = .WindowCreate(WS_EX_TOPMOST Or WS_EX_TOOLWINDOW Or WS_EX_LAYERED, WS_POPUP, , , , 100, 100)
        .AddMsg WM_MOUSEMOVE
    End With
    
    SetClassLong c_lhWnd, GCL_STYLE, GetClassLong(c_lhWnd, GCL_STYLE) Or CS_DROPSHADOW
    m_DC = GetWindowDC(c_lhWnd)
            
    SetBkMode m_DC, TRANSPARENT
End Sub

Private Sub Class_Terminate()
    c_cWindow.WindowDestroy c_lhWnd
    Set c_cWindow = Nothing
    Set c_cTimer = Nothing
End Sub

Public Function ResetCounterHide()
    If m_Cont > 23 Then m_Cont = 23
End Function
Public Function SetText(Text As String)
    m_Text = Text
End Function

Public Function Show(Text As String)
    m_Text = Text
    m_Cont = 0
    c_cTimer.StartTimer c_lhWnd, 20
End Function

Public Function Hide()
    m_Cont = 149
End Function

Private Sub iWindow_Proc(bHandled As Boolean, lReturn As Long, Hwnd As Long, uMsg As WinSubHook2.eMsg, wParam As Long, lParam As Long)
    If uMsg = WM_MOUSEMOVE Then Me.Hide
End Sub


Private Function GetTextWidth(hdc As Long, Text As String) As Long
    Dim RClip As RECT
    RClip.Top = -10000
    DrawText hdc, Text, -1, RClip, DT_CALCRECT
    GetTextWidth = RClip.Right
End Function


Private Function GetTextHeight(hdc As Long, Text As String) As Long
    Dim RClip As RECT
    RClip.Top = -10000
    RClip.Right = GetTextWidth(hdc, Text)
    GetTextHeight = DrawText(hdc, Text, -1, RClip, DT_LEFT)
End Function


Private Sub DrawRgnRectangle(ByRef hRect As Long, ByVal Color As Long, ByVal MyHdc As Long)
    Dim hBrush As Long
    hBrush = CreateSolidBrush(Color)
    FrameRgn MyHdc, hRect, hBrush, 1, 1
    DeleteObject hBrush
End Sub




