VB一个可以改变箭头方向的气泡提示

'新建一个类名。名称为clsTip
Option Explicit
'* 模块名称：clsTip.cls
'* 功能：一个可以改变箭头方向的气泡提示类
Private Type TOOLINFO
cbSize As Long
dwFlags As Long
hwnd As Long
dwID As Long
rtRect(3) As Long
hInst As Long
lpszText As String
lParam As Long
End Type
Private Declare Sub InitCommonControls Lib “comctl32” ()
Private Declare Function CreateWindowEx Lib “user32” Alias “CreateWindowExA” _
(ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, _
ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal hwndParent As Long, ByVal hMenu As Long, _
ByVal hInstance As Long, lpParam As Any) As Long
Private Const TOOLTIPS_CLASS As String = “tooltips_class32”
Private Declare Function DestroyWindow Lib “user32” (ByVal hwnd As Long) As Long
’ ToolTips Style
Public Enum StyleConstants
TTS_COMMON = &H0
TTS_BALLOON = &H40
End Enum
Private Const TTS_ALWAYSTIP As Long = &H1
Private Const TTS_NOANIMATE As Long = &H10
Private Const TTS_NOFADE As Long = &H20
Private Const TTS_NOPREFIX As Long = &H2
Private Const TTDT_AUTOPOP = 2
Private Const TTDT_INITIAL = 3
’ ToolTips Flags
Private Const TTF_ABSOLUTE As Long = &H80
Private Const TTF_CENTERTIP As Long = &H2
Private Const TTF_DI_SETITEM As Long = &H8000
Private Const TTF_IDISHWND As Long = &H1
Private Const TTF_RTLREADING As Long = &H4
Private Const TTF_SUBCLASS As Long = &H10
Private Const TTF_TRACK As Long = &H20
Private Const TTF_TRANSPARENT As Long = &H100
’ ToolTips Icon
Public Enum IconConstants
TTI_NONE = 0
TTI_INFO = 1
TTI_WARNING = 2
TTI_ERROR = 3
End Enum
'ToolTips Arrow Orientation
Public Enum OrientationConstants
Down = 0
Up = 1
End Enum
’ ToolTips Message
Private Const WM_USER As Long = &H400
Private Const TTM_SETDELAYTIME As Long = (WM_USER + 3)
Private Const TTM_ADDTOOL As Long = (WM_USER + 4)
Private Const TTM_DELTOOL As Long = (WM_USER + 5)
Private Const TTM_SETTOOLINFO As Long = (WM_USER + 9)
Private Const TTM_UPDATETIPTEXTA = (WM_USER + 12)
Private Const TTM_TRACKACTIVATE As Long = (WM_USER + 17)
Private Const TTM_TRACKPOSITION As Long = (WM_USER + 18)
Private Const TTM_SETTIPBKCOLOR As Long = (WM_USER + 19)
Private Const TTM_SETTIPTEXTCOLOR As Long = (WM_USER + 20)
Private Const TTM_SETTITLE As Long = (WM_USER + 32)
Private Declare Function GetCursorPos Lib “user32” (ByVal lpPoint As Long) As Long
Private Declare Function SetCursorPos Lib “user32” (ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function ShowCursor Lib “user32” (ByVal bShow As Long) As Long
Private Declare Function GetForegroundWindow Lib “user32” () As Long
Private Declare Function ClientToScreen Lib “user32” (ByVal hwnd As Long, ByVal lpPoint As Long) As Long
Private Declare Function GetClientRect Lib “user32” (ByVal hwnd As Long, ByVal lpRect As Long) As Long
Private Declare Function SendMessage Lib “user32” Alias “SendMessageA” (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function PostMessage Lib “user32” Alias “PostMessageA” (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindowLong Lib “user32” Alias “GetWindowLongA” (ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib “user32” Alias “SetWindowLongA” (ByVal hwnd As Long, _
ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_STYLE = (-16)
Private 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
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
Private Declare Function CallWindowProc Lib “user32” Alias “CallWindowProcA” (ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib “kernel32” Alias “RtlMoveMemory” (Destination As Any, _
Source As Any, ByVal Length As Long)
Private Declare Function SetTimer Lib “user32” (ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib “user32” (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function GetWindowRect Lib “user32” (ByVal hwnd As Long, ByVal lpRect As Long) As Long

Dim m_hwndTip As Long
Dim m_hwndParent As Long
Dim m_TipInfo As TOOLINFO
Dim m_Title As String
Dim m_Icon As IconConstants
Dim m_Style As StyleConstants
Dim m_Orientation As OrientationConstants
Dim m_Delay As Long
Dim m_ForeColor As Long, m_BackColor As Long
Dim m_idTimer As Long

Private Sub Class_Initialize()
InitCommonControls
m_Icon = TTI_INFO
m_TipInfo.cbSize = Len(m_TipInfo)
m_TipInfo.dwFlags = TTF_IDISHWND Or TTF_TRANSPARENT Or TTF_SUBCLASS 'Or TTF_TRACK
m_TipInfo.hInst = App.hInstance
m_Delay = 2000
End Sub

Private Sub Class_Terminate()
If m_idTimer <> 0 Then KillTimer 0, m_idTimer
If m_hwndTip <> 0 Then DestroyWindow m_hwndTip
m_idTimer = 0
m_hwndTip = 0
End Sub

Public Sub Show(ByVal hwndParent As Long, Optional ByVal szText As String = vbNullString, _
Optional ByVal szTitle As String = vbNullString, Optional X As Long, Optional Y As Long)

Dim hwnd As Long
Dim objPos(1) As Long, rtWin(3) As Long, ptPos As Long

Call Class_Terminate

m_Title = szTitle
m_TipInfo.lpszText = szText
m_hwndParent = IIf(hwndParent, hwndParent, GetForegroundWindow)
m_hwndTip = CreateWindowEx(0, TOOLTIPS_CLASS, "", TTS_NOPREFIX Or TTS_ALWAYSTIP Or m_Style, _
    0, 0, 0, 0, m_hwndParent, 0, App.hInstance, ByVal 0&)
m_TipInfo.hwnd = m_hwndParent
m_TipInfo.dwID = m_hwndParent

If X > 0 And Y > 0 Then
    objPos(0) = X: objPos(1) = Y
    ClientToScreen m_hwndParent, VarPtr(objPos(0))
Else
    GetCursorPos VarPtr(objPos(0))
End If
ptPos = objPos(1) * &H10000 + objPos(0)

SendMessage m_hwndTip, TTM_SETDELAYTIME, TTDT_INITIAL, ByVal 0
SendMessage m_hwndTip, TTM_SETTITLE, m_Icon, ByVal m_Title
If m_ForeColor <> Empty Then SendMessage m_hwndTip, TTM_SETTIPTEXTCOLOR, m_ForeColor, 0&
If m_BackColor <> Empty Then SendMessage m_hwndTip, TTM_SETTIPBKCOLOR, m_BackColor, 0&
SendMessage m_hwndTip, TTM_ADDTOOL, 0&, m_TipInfo

If m_Orientation = Up Then
    SendMessage m_hwndTip, TTM_TRACKPOSITION, 0, ByVal ptPos
    SendMessage m_hwndTip, TTM_TRACKACTIVATE, 1, m_TipInfo
Else
    SendMessage m_hwndTip, TTM_TRACKACTIVATE, 1, m_TipInfo
    GetWindowRect m_hwndTip, VarPtr(rtWin(0))
    objPos(0) = objPos(0) - 16
    objPos(1) = objPos(1) - (rtWin(3) - rtWin(1)) + 1
    SetWindowPos m_hwndTip, HWND_NOTOPMOST, objPos(0), objPos(1), 0, 0, _
        SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_SHOWWINDOW
End If
m_idTimer = SetTimer(0, 0, m_Delay, GetClassProcAddr(Me, 22))

End Sub

Public Sub Hide()
Call Class_Terminate
End Sub

Public Property Get Title() As String
Title = m_Title
End Property
Public Property Let Title(ByVal New_Value As String)
m_Title = New_Value
If m_hwndTip <> 0 Then SendMessage m_hwndTip, TTM_SETTITLE, m_Icon, ByVal m_Title
End Property

Public Property Get Text() As String
Text = m_TipInfo.lpszText
End Property
Public Property Let Text(ByVal New_Value As String)
m_TipInfo.lpszText = New_Value
If m_hwndTip <> 0 Then SendMessage m_hwndTip, TTM_UPDATETIPTEXTA, 0&, m_TipInfo
End Property

Public Property Get Style() As StyleConstants
Style = m_Style
End Property
Public Property Let Style(ByVal New_Value As StyleConstants)
m_Style = New_Value
End Property

Public Property Get Icon() As IconConstants
Icon = m_Icon
End Property
Public Property Let Icon(ByVal New_Value As IconConstants)
m_Icon = New_Value
If m_hwndTip <> 0 Then SendMessage m_hwndTip, TTM_SETTITLE, m_Icon, ByVal m_Title
End Property

Public Property Get Orientation() As OrientationConstants
Orientation = m_Orientation
End Property
Public Property Let Orientation(ByVal New_Value As OrientationConstants)
m_Orientation = New_Value
If New_Value = Up Then
m_TipInfo.dwFlags = TTF_IDISHWND Or TTF_TRANSPARENT Or TTF_TRACK
Else
m_TipInfo.dwFlags = TTF_IDISHWND Or TTF_TRANSPARENT Or TTF_SUBCLASS
End If
End Property

Public Property Get BackColor() As OLE_COLOR
BackColor = m_BackColor
End Property
Public Property Let BackColor(ByVal New_Value As OLE_COLOR)
m_BackColor = New_Value
If m_hwndTip <> 0 Then SendMessage m_hwndTip, TTM_SETTIPBKCOLOR, m_BackColor, 0&
End Property

Public Property Get ForeColor() As OLE_COLOR
ForeColor = m_ForeColor
End Property
Public Property Let ForeColor(ByVal New_Value As OLE_COLOR)
m_ForeColor = New_Value
If m_hwndTip <> 0 Then SendMessage m_hwndTip, TTM_SETTIPTEXTCOLOR, m_ForeColor, 0&
End Property

Public Property Get Delay() As Long
Delay = m_Delay
End Property
Public Property Let Delay(ByVal New_Value As Long)
m_Delay = New_Value
End Property

Private Function GetClassProcAddr(obj As Object, ByVal Index As Long, _
Optional ByVal ParamCount As Long = 4, Optional ByVal HasReturnValue As Boolean) As Long
Static lReturn As Long, pReturn As Long
Static AsmCode(50) As Byte
Dim i As Long, pThis As Long, pVtbl As Long, pFunc As Long

pThis = ObjPtr(obj)
CopyMemory pVtbl, ByVal pThis, 4
CopyMemory pFunc, ByVal pVtbl + (6 + Index) * 4, 4
pReturn = VarPtr(lReturn)

For i = 0 To UBound(AsmCode)                                '填充nop
    AsmCode(i) = &H90
Next
AsmCode(0) = &H55                                           'push   ebp
AsmCode(1) = &H8B: AsmCode(2) = &HEC                        'mov    ebp,esp
AsmCode(3) = &H53                                           'push   ebx
AsmCode(4) = &H56                                           'push   esi
AsmCode(5) = &H57                                           'push   edi
If HasReturnValue Then
    AsmCode(6) = &HB8                                       'mov    offset lReturn
    CopyMemory AsmCode(7), pReturn, 4
    AsmCode(11) = &H50                                      'push   eax
End If
For i = 0 To ParamCount - 1                                 'push   dword ptr[ebp+xx]
    AsmCode(12 + i * 3) = &HFF
    AsmCode(13 + i * 3) = &H75
    AsmCode(14 + i * 3) = (ParamCount - i) * 4 + 4
Next
i = i * 3 + 12
AsmCode(i) = &HB9                                           'mov    ecx,this
CopyMemory AsmCode(i + 1), pThis, 4
AsmCode(i + 5) = &H51                                       'push ecx
AsmCode(i + 6) = &HE8                                       'call 相对地址
CopyMemory AsmCode(i + 7), pFunc - VarPtr(AsmCode(i + 6)) - 5, 4
If HasReturnValue Then
    AsmCode(i + 11) = &HB8                                  'mov    eax,offset lReturn
    CopyMemory AsmCode(i + 12), pReturn, 4
    AsmCode(i + 16) = &H8B                                  'mov    eax,dword ptr[eax]
    AsmCode(i + 17) = &H0
End If
AsmCode(i + 18) = &H5F                                      'pop    edi
AsmCode(i + 19) = &H5E                                      'pop    esi
AsmCode(i + 20) = &H5B                                      'pop    ebx
AsmCode(i + 21) = &H8B: AsmCode(i + 22) = &HE5              'mov    esp,ebp
AsmCode(i + 23) = &H5D                                      'pop    ebp
AsmCode(i + 24) = &HC3                                      'ret
GetClassProcAddr = VarPtr(AsmCode(0))

End Function

Private Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, _
ByVal dwTime As Long)
Call Class_Terminate
End Sub

'----------------------------------------------------------------------------------------
'窗口调用,窗口添加两个Command

Option Explicit
Dim m_Tip As clsTip

Private Sub Command1_Click()
Me.Circle (20, 50), 2, vbRed
m_Tip.Orientation = Down
m_Tip.Delay = 1500 '1500毫秒后气泡自动消失
m_Tip.Show Me.hwnd, “这是一个可以指定位置和箭头方向气泡提示！” & vbCrLf & _
“第二行信息”, “信息”, 20, 50
End Sub

Private Sub Command2_Click()
m_Tip.Hide '也可以手动消失
End Sub

Private Sub Form_Load()
Set m_Tip = New clsTip
m_Tip.Style = TTS_BALLOON
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set m_Tip = Nothing
End Sub