VB中ToolTip工具提示的完美实现

我经常在一些软件（如Windows优化大师）上看到一些比较酷的ToolTip工具提示框，感觉不错也挺新鲜。我现在用VB做了一个，希望对用VB开发软件的朋友能有所帮助。若程序中有不完善的地方，请大家提出意见，并以修正。以下是完整的原代码：

' vbpTips.vbp ActiveX Dll 工程的完整源代码：

' //
' // 名称：ToolTip.Dll
' // 作者：Qf
' // EMAIL：dengyu1230359@sina.com
' //

' // modTips.bas 模块

Option Explicit

Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Const SW_ERASE = &H4
Public Const SW_HIDE = 0
Public Const SW_INVALIDATE = &H2
Public Const SW_MAX = 10
Public Const SW_MAXIMIZE = 3
Public Const SW_MINIMIZE = 6
Public Const SW_NORMAL = 1
Public Const SW_OTHERUNZOOM = 4
Public Const SW_OTHERZOOM = 2
Public Const SW_PARENTCLOSING = 1
Public Const SW_PARENTOPENING = 3
Public Const SW_RESTORE = 9
Public Const SW_SCROLLCHILDREN = &H1
Public Const SW_SHOW = 5
Public 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
Public Const HWND_TOPMOST = -1&
Public Const HWND_NOTOPMOST = -2&
Public Const SWP_NOSIZE = &H1&
Public Const SWP_NOMOVE = &H2&
Public Const SWP_NOACTIVATE = &H10&
Public Const SWP_SHOWWINDOW = &H40&

Public 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
Public Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Public Declare Function SetRectEmpty Lib "user32" (lpRect As RECT) As Long

Public 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
Public Const DT_BOTTOM = &H8
Public Const DT_CALCRECT = &H400
Public Const DT_CENTER = &H1
Public Const DT_CHARSTREAM = 4          '  Character-stream, PLP
Public Const DT_DISPFILE = 6            '  Display-file
Public Const DT_EXPANDTABS = &H40
Public Const DT_EXTERNALLEADING = &H200
Public Const DT_INTERNAL = &H1000
Public Const DT_LEFT = &H0
Public Const DT_METAFILE = 5            '  Metafile, VDM
Public Const DT_NOCLIP = &H100
Public Const DT_NOPREFIX = &H800
Public Const DT_PLOTTER = 0             '  Vector plotter
Public Const DT_RASCAMERA = 3           '  Raster camera
Public Const DT_RASDISPLAY = 1          '  Raster display
Public Const DT_RASPRINTER = 2          '  Raster printer
Public Const DT_RIGHT = &H2
Public Const DT_SINGLELINE = &H20
Public Const DT_TABSTOP = &H80
Public Const DT_TOP = &H0
Public Const DT_VCENTER = &H4
Public Const DT_WORDBREAK = &H10

Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Public Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Public Declare Function GetTickCount Lib "kernel32" () As Long

Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Public Type POINTAPI
    x As Long
    y As Long
End Type

Public Type TipMemberList              '成员结构
    hwnd As Long
    Text As String
End Type

Public m_TipLists() As TipMemberList   '保存成员
Public m_hOriginalWnd As Long          '保存上一个窗口的句柄
Public m_lOriginalRect As RECT         '保存上一个无句柄的窗口区域
Public m_WndStopoverTimeVal As Long    '窗体显示多长时间然后自动隐藏(默认为5秒)

Public m_BackColor As Long             '背景颜色（文本显示区的颜色）
Public m_ForeColor As Long             '前景颜色（字体的颜色）
Public m_BorderColor As Long           '边框颜色
Public m_VerticalBarColor As Long      '垂直条颜色
Public m_VerticalBarWidth As Long      '垂直条宽度
Public m_FontName As String            '字体名称
Public m_FontSize As Long              '字体大小
Public m_FontBold As Boolean           '是否粗体
Public m_FontItalic As Boolean         '是否斜体
Public m_HaveShadow As Boolean         '是否有阴影

Public Const SIDESPACE As Long = 8     '边距

Private Sub ShowTipInfor(ByVal hWndOwner As Long, ByVal strText As String)
    Dim lpPoint As POINTAPI
    Dim lpRect As RECT
    Dim lHeight As Long
    Dim lWidth As Long
    Dim lLeft As Long
    Dim lTop As Long

    frmTips.Cls
    frmTips.FontName = m_FontName      '字体名称
    frmTips.FontSize = m_FontSize      '字体大小
    frmTips.FontBold = m_FontBold      '是否粗体
    frmTips.FontItalic = m_FontItalic  '是否斜体
    frmTips.ForeColor = m_ForeColor    '字体颜色
   
    frmTips.imgArrow(0).Visible = False
    frmTips.imgArrow(1).Visible = False
    frmTips.imgArrow(2).Visible = False
    frmTips.imgArrow(3).Visible = False
   
   '设置窗体的高度和宽度
    frmTips.Height = (frmTips.TextHeight(strText) + 16) * Screen.TwipsPerPixelY
    frmTips.Width = (frmTips.TextWidth(strText) + 40) * Screen.TwipsPerPixelX
  
    GetCursorPos lpPoint
    lWidth = Screen.Width / Screen.TwipsPerPixelX
    lHeight = Screen.Height / Screen.TwipsPerPixelY
     
    If lpPoint.y <= lHeight / 2 Then '上边区域
       If ((lpPoint.x < frmTips.ScaleWidth And lpPoint.y < frmTips.ScaleHeight)) Or _
          ((lpPoint.x < frmTips.ScaleWidth)) Then '左上边
           lLeft = lpPoint.x + 16
           lTop = lpPoint.y + 16
           frmTips.Line (0, 0)-(m_VerticalBarWidth, frmTips.ScaleHeight - 1), m_BorderColor, B
           frmTips.Line (0, 0)-(frmTips.ScaleWidth - 1, frmTips.ScaleHeight - 1), m_BorderColor, B
           frmTips.Line (1, 1)-(m_VerticalBarWidth - 1, frmTips.ScaleHeight - 2), m_VerticalBarColor, BF
           frmTips.Line (m_VerticalBarWidth + 1, 1)-(frmTips.ScaleWidth - 2, frmTips.ScaleHeight - 2), m_BackColor, BF
           frmTips.imgArrow(1).Move 4, 4
           frmTips.imgArrow(1).Visible = True
           '显示文字
           SetRect lpRect, m_VerticalBarWidth + 8, 8, frmTips.ScaleWidth - 9, frmTips.ScaleHeight - 9
           DrawText frmTips.hdc, strText, lstrlen(strText), lpRect, DT_LEFT
       ElseIf ((lWidth - lpPoint.x) < frmTips.ScaleWidth And lpPoint.y < frmTips.ScaleHeight) Or _
          ((lWidth - lpPoint.x) < frmTips.ScaleWidth) Then '右上边
           lLeft = (lpPoint.x - frmTips.ScaleWidth) + 16
           lTop = lpPoint.y + 24
           frmTips.Line (frmTips.ScaleWidth - (m_VerticalBarWidth + 1), 0)-(frmTips.ScaleWidth - 1, frmTips.ScaleHeight - 1), m_BorderColor, B
           frmTips.Line (0, 0)-(frmTips.ScaleWidth - 1, frmTips.ScaleHeight - 1), m_BorderColor, B
           frmTips.Line (frmTips.ScaleWidth - m_VerticalBarWidth, 1)-(frmTips.ScaleWidth - 2, frmTips.ScaleHeight - 2), m_VerticalBarColor, BF
           frmTips.Line (1, 1)-(frmTips.ScaleWidth - (m_VerticalBarWidth + 2), frmTips.ScaleHeight - 2), m_BackColor, BF
           frmTips.imgArrow(2).Move frmTips.ScaleWidth - (m_VerticalBarWidth - 4), 4
           frmTips.imgArrow(2).Visible = True
           '显示文字
           SetRect lpRect, 8, 8, frmTips.ScaleWidth - (m_VerticalBarWidth + 9), frmTips.ScaleHeight - 9
           DrawText frmTips.hdc, strText, lstrlen(strText), lpRect, DT_LEFT
       Else
           lLeft = lpPoint.x + 16
           lTop = lpPoint.y + 16
           frmTips.Line (0, 0)-(m_VerticalBarWidth, frmTips.ScaleHeight - 1), m_BorderColor, B
           frmTips.Line (0, 0)-(frmTips.ScaleWidth - 1, frmTips.ScaleHeight - 1), m_BorderColor, B
           frmTips.Line (1, 1)-(m_VerticalBarWidth - 1, frmTips.ScaleHeight - 2), m_VerticalBarColor, BF
           frmTips.Line (m_VerticalBarWidth + 1, 1)-(frmTips.ScaleWidth - 2, frmTips.ScaleHeight - 2), m_BackColor, BF
           frmTips.imgArrow(1).Move 4, 4
           frmTips.imgArrow(1).Visible = True
           '显示文字
           SetRect lpRect, m_VerticalBarWidth + 8, 8, frmTips.ScaleWidth - 9, frmTips.ScaleHeight - 9
           DrawText frmTips.hdc, strText, lstrlen(strText), lpRect, DT_LEFT
       End If
    Else '下边区域
       If ((lpPoint.x < frmTips.ScaleWidth And (lHeight - lpPoint.y) < frmTips.ScaleHeight)) Or _
          (lpPoint.x < frmTips.ScaleWidth) Then '左下边
           lLeft = lpPoint.x
           lTop = lpPoint.y - frmTips.ScaleHeight
           frmTips.Line (0, 0)-(m_VerticalBarWidth, frmTips.ScaleHeight - 1), m_BorderColor, B
           frmTips.Line (0, 0)-(frmTips.ScaleWidth - 1, frmTips.ScaleHeight - 1), m_BorderColor, B
           frmTips.Line (1, 1)-(m_VerticalBarWidth - 1, frmTips.ScaleHeight - 2), m_VerticalBarColor, BF
           frmTips.Line (m_VerticalBarWidth + 1, 1)-(frmTips.ScaleWidth - 2, frmTips.ScaleHeight - 2), m_BackColor, BF
           frmTips.imgArrow(0).Move 4, frmTips.ScaleHeight - (m_VerticalBarWidth - 3)
           frmTips.imgArrow(0).Visible = True
           '显示文字
           SetRect lpRect, m_VerticalBarWidth + 8, 8, frmTips.ScaleWidth - 9, frmTips.ScaleHeight - 9
           DrawText frmTips.hdc, strText, lstrlen(strText), lpRect, DT_LEFT
       ElseIf ((lWidth - lpPoint.x) < frmTips.ScaleWidth And (lHeight - lpPoint.y) < frmTips.ScaleHeight) Or _
          ((lWidth - lpPoint.x) < frmTips.ScaleWidth) Then '右下边
           lLeft = lpPoint.x - frmTips.ScaleWidth
           lTop = lpPoint.y - frmTips.ScaleHeight
           frmTips.Line (frmTips.ScaleWidth - (m_VerticalBarWidth + 1), 0)-(frmTips.ScaleWidth - 1, frmTips.ScaleHeight - 1), m_BorderColor, B
           frmTips.Line (0, 0)-(frmTips.ScaleWidth - 1, frmTips.ScaleHeight - 1), m_BorderColor, B
           frmTips.Line (frmTips.ScaleWidth - m_VerticalBarWidth, 1)-(frmTips.ScaleWidth - 2, frmTips.ScaleHeight - 2), m_VerticalBarColor, BF
           frmTips.Line (1, 1)-(frmTips.ScaleWidth - (m_VerticalBarWidth + 2), frmTips.ScaleHeight - 2), m_BackColor, BF
           frmTips.imgArrow(3).Move frmTips.ScaleWidth - (m_VerticalBarWidth - 3), frmTips.ScaleHeight - (m_VerticalBarWidth - 3)
           frmTips.imgArrow(3).Visible = True
           '显示文字
           SetRect lpRect, 8, 8, frmTips.ScaleWidth - (m_VerticalBarWidth + 9), frmTips.ScaleHeight - 9
           DrawText frmTips.hdc, strText, lstrlen(strText), lpRect, DT_LEFT
       Else
           lLeft = lpPoint.x
           lTop = lpPoint.y - frmTips.ScaleHeight
           frmTips.Line (0, 0)-(m_VerticalBarWidth, frmTips.ScaleHeight - 1), m_BorderColor, B
           frmTips.Line (0, 0)-(frmTips.ScaleWidth - 1, frmTips.ScaleHeight - 1), m_BorderColor, B
           frmTips.Line (1, 1)-(m_VerticalBarWidth - 1, frmTips.ScaleHeight - 2), m_VerticalBarColor, BF
           frmTips.Line (m_VerticalBarWidth + 1, 1)-(frmTips.ScaleWidth - 2, frmTips.ScaleHeight - 2), m_BackColor, BF
           frmTips.imgArrow(0).Move 4, frmTips.ScaleHeight - (m_VerticalBarWidth - 3)
           frmTips.imgArrow(0).Visible = True
           '显示文字
           SetRect lpRect, m_VerticalBarWidth + 8, 8, frmTips.ScaleWidth - 9, frmTips.ScaleHeight - 9
           DrawText frmTips.hdc, strText, lstrlen(strText), lpRect, DT_LEFT
       End If
    End If
   
    If m_HaveShadow = True Then
       frmTips.Width = frmTips.Width + 64
       frmTips.Height = frmTips.Height + 64
       DrawShadow frmTips.hwnd, frmTips.hdc, lLeft, lTop
    End If
   
    SetWindowPos frmTips.hwnd, HWND_TOPMOST, lLeft, lTop, 0, 0, _
                 SWP_SHOWWINDOW Or SWP_NOACTIVATE Or SWP_NOSIZE
   
End Sub

Public Sub OpenTimer()
  
    m_WndStopoverTimeVal = 0
    frmTips.tmrControl.Enabled = True
   
End Sub

Public Sub CloseTimer()
   
    m_WndStopoverTimeVal = 0
    frmTips.tmrControl.Enabled = False
   
End Sub

Public Sub MonitorControlWindow(ByVal hWndOwner As Long, Optional ByVal TimeElapseVal As Long = 100)
   
    SetTimer hWndOwner, 0, TimeElapseVal, AddressOf TimerProc
   
End Sub

Public Sub ExitMonitorControlWindow(ByVal hWndOwner As Long)
   
    KillTimer hWndOwner, 0
   
End Sub

Public Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, _
                     ByVal lpTimerFunc As Long)
Dim lpPoint As POINTAPI
Dim hWndOwner As Long
Dim iIndex As Long

    GetCursorPos lpPoint
    hWndOwner = WindowFromPoint(lpPoint.x, lpPoint.y)
    If hWndOwner > 0 And hWndOwner <> hwnd Then
      '将获得的窗口句柄hWndOwner与上一次获得的窗口句柄进行比较，
      '并判断是否为同一个窗口句柄,是就不予理睬
       If hWndOwner = m_hOriginalWnd Then
      
          Exit Sub
         
       Else
         '隐藏窗体，关闭定时器清零
          ShowWindow hwnd, SW_HIDE
          CloseTimer
         '将当前获得的窗口句柄hWndOwner与列表中的句柄进行比较
          For iIndex = LBound(m_TipLists) To UBound(m_TipLists)
              If hWndOwner = m_TipLists(iIndex).hwnd Then
                '显示信息提示
                 ShowTipInfor m_TipLists(iIndex).hwnd, m_TipLists(iIndex).Text
                '启动定时器，以设置窗体显示时间长短
                 OpenTimer
                 Exit For
              End If
          Next
          '保存当前获得的窗口句柄hWndOwner
          m_hOriginalWnd = hWndOwner
       End If
    Else
   
       m_hOriginalWnd = -1
      
    End If
   
    DoEvents
   
End Sub

'//
'// 以下画窗体阴影的代码来自国外的一为程序员，记不清楚是谁了。
'//
Private Sub DrawShadow(ByVal hwnd As Long, ByVal hdc As Long, ByVal xOrg As Long, ByVal yOrg As Long)
    
    Dim hDcDsk As Long
    Dim Rec As RECT
    Dim winW As Long, winH As Long
    Dim x As Long, y As Long, c As Long
    
    GetWindowRect hwnd, Rec
    winW = Rec.Right - Rec.Left
    winH = Rec.Bottom - Rec.Top
    
    hDcDsk = GetWindowDC(GetDesktopWindow)
    
    '// Simulate a shadow on right edge...
    For x = 1 To 4
        DoEvents
        For y = 0 To 3
            c = GetPixel(hDcDsk, xOrg + winW - x, yOrg + y)
            SetPixel hdc, winW - x, y, c
        Next y
        For y = 4 To 7
            c = GetPixel(hDcDsk, xOrg + winW - x, yOrg + y)
            SetPixel hdc, winW - x, y, pMask(3 * x * (y - 3), c)
        Next y
        For y = 8 To winH - 5
            c = GetPixel(hDcDsk, xOrg + winW - x, yOrg + y)
            SetPixel hdc, winW - x, y, pMask(15 * x, c)
        Next y
        For y = winH - 4 To winH - 1
            c = GetPixel(hDcDsk, xOrg + winW - x, yOrg + y)
            SetPixel hdc, winW - x, y, pMask(3 * x * -(y - winH), c)
        Next y
    Next x
    
    '// Simulate a shadow on the bottom edge...
    For y = 1 To 4
        DoEvents
        For x = 0 To 3
            c = GetPixel(hDcDsk, xOrg + x, yOrg + winH - y)
            SetPixel hdc, x, winH - y, c
        Next x
        For x = 4 To 7
            c = GetPixel(hDcDsk, xOrg + x, yOrg + winH - y)
            SetPixel hdc, x, winH - y, pMask(3 * (x - 3) * y, c)
        Next x
        For x = 8 To winW - 5
            c = GetPixel(hDcDsk, xOrg + x, yOrg + winH - y)
            SetPixel hdc, x, winH - y, pMask(15 * y, c)
        Next x
    Next y
    
    ' - Release the desktop hDC...
    ReleaseDC GetDesktopWindow, hDcDsk

End Sub

'// Function pMask splits a color into its RGB components and transforms the color using a scale 0..255
Private Function pMask(ByVal lScale As Long, ByVal lColor As Long) As Long
    
    Dim R As Byte
    Dim G As Byte
    Dim B As Byte
    
    Long2RGB lColor, R, G, B
    
    R = pTransform(lScale, R)
    G = pTransform(lScale, G)
    B = pTransform(lScale, B)
    
    pMask = RGB(R, G, B)
    
End Function

'// Function pTransform converts a RGB subcolor using a scale  where 0 = 0 and 255 = lScale
Private Function pTransform(ByVal lScale As Long, ByVal lColor As Long) As Long
    
    pTransform = lColor - Int(lColor * lScale / 255)
   
End Function

Private Sub Long2RGB(LongColor As Long, R As Byte, G As Byte, B As Byte)
    On Error Resume Next
   
    '// convert to hex using vb's hex function, then use the hex2rgb function
    Hex2RGB (Hex(LongColor)), R, G, B
 
End Sub

Private Sub Hex2RGB(strHexColor As String, R As Byte, G As Byte, B As Byte)
    On Error Resume Next
    Dim HexColor As String
    Dim I As Byte
  
    '//  make sure the string is 6 characters long
    '// (it may have been given in &H###### format, we want ######)
    strHexColor = Right((strHexColor), 6)
    '// however, it may also have been given as or #***** format, so add 0's in front
    For I = 1 To (6 - Len(strHexColor))
        HexColor = HexColor & "0"
    Next
    HexColor = HexColor & strHexColor
    '// convert each set of 2 characters into bytes, using vb's cbyte function
    R = CByte("&H" & Right$(HexColor, 2))
    G = CByte("&H" & Mid$(HexColor, 3, 2))
    B = CByte("&H" & Left$(HexColor, 2))
   
End Sub

 
'// clsTips.cls 类模块

Option Explicit

Public Property Let BackColor(ByVal rgbBackColor As Long)
    m_BackColor = rgbBackColor
End Property

Public Property Let ForeColor(ByVal rgbForeColor As Long)
     m_ForeColor = rgbForeColor
End Property

Public Property Let BorderColor(ByVal rgbBorderColor As Long)
    m_BorderColor = rgbBorderColor
End Property

Public Property Let VerticalBarColor(ByVal rgbVerticalBarColor As Long)
    m_VerticalBarColor = rgbVerticalBarColor
End Property

 '// 垂直条宽度
Public Property Let VerticalBarWidth(ByVal lngVerticalBarWidth As Long)
    m_VerticalBarWidth = lngVerticalBarWidth
End Property

Public Property Let FontName(ByVal strFontName As String)
    m_FontName = strFontName
End Property

Public Property Let FontSize(ByVal lFontSize As Long)
    m_FontSize = lFontSize
End Property

Public Property Let FontBold(ByVal bFontBold As Boolean)
    m_FontBold = bFontBold
End Property

Public Property Let FontItalic(ByVal bFontItalic As Boolean)
    FontItalic = m_FontItalic
End Property
 
Public Property Let HaveShadow(ByVal bHaveShadow As Boolean)
    m_HaveShadow = bHaveShadow
End Property

Public Sub AddItem(ByVal hwnd As Long, ByVal Text As String)
    On Error Resume Next
    Dim Index As Long

    Index = UBound(m_TipLists) + 1
    If Err.Number > 0 Then
       Index = 0
    Else
       Index = UBound(m_TipLists) + 1
    End If
    ReDim Preserve m_TipLists(Index)
    m_TipLists(Index).hwnd = hwnd
    m_TipLists(Index).Text = Text
 
End Sub

Private Sub ClearAll()

    Erase m_TipLists
   
End Sub

Public Sub Start()
   
   '监控窗体
    MonitorControlWindow frmTips.hwnd
   
End Sub

   
Private Sub Class_Initialize()
   
    m_BackColor = RGB(255, 255, 225)        '背景颜色（文本显示区的颜色）
    m_ForeColor = RGB(0, 0, 0)              '前景颜色（字体的颜色）
    m_BorderColor = RGB(0, 0, 0)            '边框颜色
    m_VerticalBarColor = RGB(192, 192, 192) '垂直条颜色
    m_VerticalBarWidth = 16                 '垂直条宽度
    m_FontName = "Arial"                    '字体名称
    m_FontSize = 8                          '字体大小
    m_FontBold = False                      '是否粗体
    m_FontItalic = False                    '是否斜体
    m_HaveShadow = True                     '是否有阴影

End Sub

Private Sub Class_Terminate()
  
   '结束监控窗体
    ExitMonitorControlWindow frmTips.hwnd
   '清空列表
    ClearAll
   '关闭窗体
    Unload frmTips
   
End Sub

'// frmTips.frm 窗体
'// 注意：你需要在该窗体上放一个定时器控件，4个方向箭头图标。图标的大小最好为16*16Pixel。

Option Explicit

Private Sub Form_Load()
   
    tmrControl.Interval = 1000
    tmrControl.Enabled = False
   
End Sub

Private Sub Form_Terminate()
   
    Set frmTips = Nothing
   
End Sub

Private Sub tmrControl_Timer()
   
    m_WndStopoverTimeVal = m_WndStopoverTimeVal + 1
    If m_WndStopoverTimeVal = 5 Then
       m_WndStopoverTimeVal = 0
       tmrControl.Enabled = False
       frmTips.Hide
    End If
   
End Sub

编译上面的vbpTips.vbp工程生成vbpTips.dll。程序制作完成。
以下是测试示例代码，对于ActiveX DLL的使用，我想大家没有问题：
Option Explicit

Dim t As New clsTips

Private Sub Form_Load()
t.BackColor = vbWhite
t.VerticalBarColor = RGB(255, 210, 83)

t.AddItem Me.hWnd, "hello word how are you what is you neme?" & vbCrLf & _
                   "中国人民万岁" & vbCrLf & _
                   "为了爱梦一生-王杰" & vbCrLf & _
                   "界面和业务逻辑彻底分离，节约开发和维护时间"
t.AddItem Command1.hWnd, "hello佛朗哥角动量客观机" & vbCrLf & _
                         "gfhfgh"
t.AddItem Command2.hWnd, "ffff" & vbCrLf & _
                         "gfhfgh"
t.Start
 
End Sub

Private Sub Form_Unload(Cancel As Integer)

Set t = Nothing

End Sub

已编译好的源程序：ToolTip.rar

注意：单击鼠标右键，目标另存为下载。下载后将ToolTip.jpg扩展名改成rar,然后解压即可。

下面是程序运行效果：