vb控件的ToolTip提示内容长度问题

提示超过80个字符，这是什么提示呀？直接看帮助了
别用自带的ToolTip，自己模拟一个
自己写的tooltip，应该差不多能用Option ExplicitPrivate 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 ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongPrivate Const LVM_FIRST = &H1000
Private Const LVM_SUBITEMHITTEST = (LVM_FIRST + 57)
Private Const LVM_GETSUBITEMRECT = (LVM_FIRST + 56)
Private Const LVM_GETITEMRECT = (LVM_FIRST + 14)
Private Const LVIR_BOUNDS = 0
Private Const LVM_GETSTRINGWIDTHA = (LVM_FIRST + 17)
Private Const LVM_GETSELECTEDCOUNT = (LVM_FIRST + 50)
Private Const LVM_DELETEALLITEMS = (LVM_FIRST + 9)Private Type POINTAPI
        x As Long
        y As Long
End TypePrivate Type LVHITTESTINFO
        pt As POINTAPI
        Flags As Long
        iItem As Long
        iSubItem As Long
End TypePrivate Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End TypePrivate lblTT           As TextBox
Private lblToolText     As LabelPrivate xPos            As Long
Private yPos            As Long
Private lvHti As LVHITTESTINFO'获取subitem索引
Public Function GetLvwIndex(LvwList As ListView, ptIndex As POINTAPI)
        GetCursorPos lvHti.pt
        ScreenToClient LvwList.hwnd, lvHti.pt
        Call SendMessage(LvwList.hwnd, LVM_SUBITEMHITTEST, 0, lvHti.pt)
        ptIndex.x = lvHti.iSubItem
        ptIndex.y = lvHti.iItem
End Function'工具提示
Public Sub ShowToolTip(Lvw As ListView)
        On Error Resume Next
        Dim LvwItem As ListItem
        Dim i As Long, iSub As Long
        Dim lpPt As POINTAPI, lpPt2 As POINTAPI
        Dim lpRect As RECT
        Dim lWidth As Long
        Dim lHeight As Long
        Dim MaxWidth As Long
        Dim CltWidth As Long
        Dim LvwRect As RECT
        Dim TTLeft As Long
        Static TTTop As Long
        Dim ptOffsetX As Long
        Dim ptOffsetY As Long
        Dim TTPt As POINTAPI

        Static bFlag As Boolean
        Static oldPT As POINTAPI

        Call GetLvwIndex(Lvw, lpPt)
        If lpPt.x < 0 Or lpPt.y < 0 Then Exit Sub

        '******************************************
        Set lblTT = Lvw.Parent.Controls.Add("VB.TextBox", "lblTT")
        Set lblToolText = Lvw.Parent.Controls.Add("VB.Label", "lblToolText")

        lblTT.Locked = True
        lblTT.BackColor = vbInfoBackground
        lblTT.Appearance = 0
        lblTT.TabStop = False
        lblToolText.BackColor = vbInfoBackground
        lblToolText.AutoSize = True
        lblToolText.BorderStyle = 0
        '********************************************

        ptOffsetX = 240
        ptOffsetY = 360
        MaxWidth = Lvw.Parent.ScaleWidth - 120

        With Lvw.Parent
                GetCursorPos lpPt2
                If lpPt2.x <> oldPT.x Or lpPt2.y <> oldPT.y Then
                        If xPos <> lpPt.x Or yPos <> lpPt.y Then
                                'Debug.Print "tooltiptext"
                                Set LvwItem = Lvw.ListItems(lpPt.y + 1)
                                lpRect.Left = LVIR_BOUNDS
                                lpRect.Top = lpPt.x
                                bFlag = False
                                If lpPt.x > 0 Then
                                        Call SendMessage(Lvw.hwnd, LVM_GETSUBITEMRECT, lpPt.y, lpRect) '矩形
                                        lWidth = SendMessage(Lvw.hwnd, LVM_GETSTRINGWIDTHA, 0, ByVal LvwItem.SubItems(lpPt.x)) '显示需宽度
                                Else
                                        Call SendMessage(Lvw.hwnd, LVM_GETITEMRECT, lpPt.y, lpRect)  '矩形
                                        lpRect.Right = Lvw.ColumnHeaders(1).Width / 15
                                        lWidth = SendMessage(Lvw.hwnd, LVM_GETSTRINGWIDTHA, 0, ByVal LvwItem.Text)  '显示需宽度
                                End If
                                If lpRect.Left < 0 Then
                                        bFlag = True
                                Else
                                        GetClientRect Lvw.hwnd, LvwRect
                                        CltWidth = LvwRect.Right
                                        If lpRect.Left + lWidth > CltWidth Then
                                                bFlag = True
                                        ElseIf lpRect.Right - lpRect.Left - 12 < lWidth Then
                                                bFlag = True
                                        End If
                                End If
                                If bFlag Then
                                        lblToolText.Font.Name = Lvw.Font.Name
                                        lblToolText.Font.Size = Lvw.Font.Size
                                        If lpPt.x > 0 Then
                                                lblToolText.Caption = LvwItem.SubItems(lpPt.x)
                                        Else
                                                lblToolText.Caption = LvwItem.Text
                                        End If
                                        lblTT.Font.Name = lblToolText.Font.Name
                                        lblTT.Font.Size = lblToolText.Font.Size
                                        lblTT.Font.Bold = False
                                        lblTT.Font.Italic = False
                                        lblTT.Text = lblToolText.Caption
                                        lblTT.Width = lblToolText.Width + 120
                                        lblTT.Height = lblToolText.Height + 120
                                        'Debug.Print .lblTT.Text
                                        lblToolText.Caption = ""
                                        TTPt.x = lpRect.Right
                                        TTPt.y = lpRect.Bottom
                                        ClientToScreen Lvw.hwnd, TTPt
                                        ScreenToClient .hwnd, TTPt
                                        'Debug.Print TTPt.x, TTPt.y
                                        TTTop = (TTPt.y + 16) * 15
                                End If
                                xPos = lpPt.x
                                yPos = lpPt.y
                        End If
                        '显示工具提示
                        If bFlag Then
                                ScreenToClient .hwnd, lpPt2
                                'TTTop = lpPt2.y * 15 + ptOffsetY
                                If lblTT.Width = MaxWidth Then
                                        lblTT.Top = TTTop
                                ElseIf lblTT.Width < MaxWidth Then
                                        TTLeft = lpPt2.x * 15 + ptOffsetX
                                        If TTLeft < 60 Then
                                                TTLeft = 60
                                        ElseIf TTLeft > MaxWidth - lblTT.Width Then
                                                TTLeft = MaxWidth - lblTT.Width
                                        End If
                                        lblTT.Move TTLeft, TTTop
                                        'Debug.Print TTLeft
                                Else
                                        lHeight = lblTT.Width \ MaxWidth
                                        If lHeight = lblTT.Width / MaxWidth Then
                                                lblTT.Height = lHeight * lblTT.Height
                                        Else
                                                lblTT.Height = (lHeight + 1) * lblTT.Height
                                        End If
                                        lblTT.Width = MaxWidth
                                        lblTT.Move 60, TTTop, lblTT.Width, lblTT.Height
                                        'Debug.Print "超出"
                                End If
                                If lblTT.Visible = False Then
                                        lblTT.Visible = True
                                        lblTT.ZOrder
                                End If
                        Else
                                If lblTT.Visible Then
                                        lblTT.Visible = False
                                        lblTT.Text = ""
                                End If
                        End If
                        oldPT = lpPt2
                End If
        End With
        Set LvwItem = Nothing
End Sub'清除工具提示
Sub ClearLvwToolTip()
        On Error Resume Next
        If lblTT Is Nothing Then Exit Sub
        lblTT.Visible = False
        lblTT.Text = ""
        xPos = -1: yPos = -1
End Sub

调试易

vb控件的ToolTip提示内容长度问题

解决方案 »