我現在在VB中使用樹控制元件要求滑鼠移動到相應的節點上時，要使用ToolTip提示節點的內容，當節點內容超過了80個字符時，ToolTip只能提示前80個字符，請問怎么修改ToolTip提示內容的長度大小帶提示完整的內容，急！！！！！
uj5u.com熱心網友回復：
提示超過80個字符，這是什么 提示呀？直接看幫助了別用自帶的ToolTip，自己模擬一個
uj5u.com熱心網友回復：
以前倒是也遇到過這個問題.不過后來經過分析, 發現沒有必要寫得這么羅嗦.
精簡一下描述和詞匯就搞定了.
在此感謝一下我的語文老老師.
uj5u.com熱心網友回復：
自己寫的tooltip，應該差不多能用Option Explicit
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 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 Long
Private 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 Type
Private Type LVHITTESTINFO
pt As POINTAPI
Flags As Long
iItem As Long
iSubItem As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private lblTT As TextBox
Private lblToolText As Label
Private 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
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/110971.html
標籤：控件
上一篇：vb資料系結串列框
下一篇：編程求助