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

最新推荐文章于 2021-11-13 18:15:33 发布

lyserver

最新推荐文章于 2021-11-13 18:15:33 发布

阅读量2.6k

点赞数 1

分类专栏： VB6 文章标签： VB6 气泡箭头方向

本文链接：https://blog.youkuaiyun.com/lyserver/article/details/4234894

版权

VB6 专栏收录该内容

68 篇文章

订阅专栏

用VB实现一个气泡提示并不难，即使是实现在任意地方显示的气泡提示。难的是，如果是采用TTF_TRACK方式允许在任意地方显示时，气泡的箭头总是向上，而且还不能自动消失。为此，我写了一个增强的气泡提示类，希望对有此需要的朋友一些参考。

一、新建一个类，类名为clsTip，类代码如下：

Option Explicit
'* ******************************************** *
'*  模块名称：clsTip.cls
'*  功能：一个可以改变箭头方向的气泡提示类
'*  作者：lyserver
'*  联系方式：http://blog.youkuaiyun.com/lyserver
'* ******************************************** *
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

二、测试代码如下：

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