怎么能让tooltiptext分行显示信息？？？－－　在线等

需要win5.0以上版本－－就是win2k/xp才支持可以到文档中型看看

[名称]           使用ToolTip来解决超长文字的显示问题[数据来源]       未知[内容简介]
http://www.csdn.net/develop/Read_Article.asp?Id=15538[源代码内容]使用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 Const LB_ITEMFROMPOINT = &H1A9
Private Sub Form_Load()
    Dim i As Integer
    For i = 0 To 5
        List1.AddItem "ListItem字符串超长超长超长超长超长咯    " & i
    Next
End Sub
Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim lParam As Long
    Dim lResult As Long
    lParam = (CInt(Y / Screen.TwipsPerPixelY) * 2 ^ 16) + CInt(X / Screen.TwipsPerPixelX)
    lResult = SendMessage(List1.hwnd, LB_ITEMFROMPOINT, 0, ByVal lParam)

    If lResult < 0 Or lResult > 32767 Then
        List1.ToolTipText = ""
        Exit Sub
    End If

    Dim nIndex As Integer
    nIndex = CInt(lResult)
    List1.ToolTipText = List1.List(nIndex)
End Sub
在 Win2000 + VB6 中调试通过
     以上代码保存于： SourceCode Explorer(源代码数据库)
           复制时间： 2003-01-14 12:02:24
           软件版本： 1.0.818
           软件作者： Shawls
           个人主页： Http://Shawls.Yeah.Net
             E-Mail： [email protected]
                 QQ： 9181729

the code to accomplish this follow'form
Option ExplicitDim mclsToolTip As New clsToolTip
Private Sub Form_Load()
Dim ctrl As Control

  With mclsToolTip
    '
    ' Create the tooltip window.
    '
    Call .Create(Me)    '
    ' Set the tooltip's width so that it displays
    ' multiline text and no tool's line length exceeds
    ' roughly 240 pixels.
    '
    .MaxTipWidth = 240    '
    ' Show the tooltip for 20 seconds.
    '
    .DelayTime(ttDelayShow) = 20000

    '
    ' Add a tooltip tool to each control on the Form.
    '
    For Each ctrl In Controls
        Call .AddTool(ctrl)
    Next

    '
    ' Set the text for Command1's tool.
    '
    .ToolText(Command1) = "This is a long tooltip for a " & vbCrLf & vbCrLf & vbTab & _
                "command button that spans multiple lines." & _
                vbCrLf & vbCrLf & vbTab & "Text formatting characters can also be used."


    '
    ' Set the text for Text1's tool.
    '
    .ToolText(Text1) = " You can make pretty pictures too... :-) " & vbCrLf & vbCrLf & _
      "                          !!!!!!!" & vbCrLf & _
      "                          (? ?" & vbCrLf & _
      "          +-----oOO----(_)----------------+" & vbCrLf & _
      "           |     TheScarms.com       |" & vbCrLf & _
      "           |           Rules!                |" & vbCrLf & _
      "          +------------------------oOO-----+" & vbCrLf & _
      "                        |__|  |__|" & vbCrLf & _
      "                          ||      ||" & vbCrLf & _
      "                      ooO   Ooo"


    '
    ' Set the text for Command1's tool.
    '
    .ToolText(Picture1) = "This is a long tooltip for a " & vbCrLf & vbCrLf & vbTab & _
                "picturebox that spans multiple lines." & _
                vbCrLf & vbCrLf & vbTab & "Text formatting characters can also be used."

  End WithEnd Sub'module
Option Explicit
'
' The NMHDR structure contains information about
' a notification message. The pointer  to this
' structure is specified as the lParam member of
' the WM_NOTIFY message.
'
Public Type NMHDR
    hwndFrom As Long
    idFrom   As Long
    code     As Long
End TypePublic Type POINTAPI
    x As Long
    y As Long
End TypePublic Type RECT
    Left   As Long
    Top    As Long
    Right  As Long
    Bottom As Long
End TypePublic Const WM_USER = &H400
Public Const TOOLTIPS_CLASS = "tooltips_class32"
Public Const TTS_ALWAYSTIP = &H1
Public Const TTS_NOPREFIX = &H2
#Const WIN32_IE = &H400Public Type TOOLINFO
    cbSize   As Long
    uFlags   As TT_Flags
    hWnd     As Long
    uId      As Long
    RECT     As RECT
    hinst    As Long
    lpszText As String
#If (WIN32_IE >= &H300) Then
    lParam   As Long
#End If
End TypePublic Enum TT_Flags
    TTF_IDISHWND = &H1
    TTF_CENTERTIP = &H2
    TTF_RTLREADING = &H4
    TTF_SUBCLASS = &H10
#If (WIN32_IE >= &H300) Then
    TTF_TRACK = &H20
    TTF_ABSOLUTE = &H80
    TTF_TRANSPARENT = &H100
    TTF_DI_SETITEM = &H8000&
#End If
End EnumPublic Enum TT_DelayTime
    TTDT_AUTOMATIC = 0
    TTDT_RESHOW = 1
    TTDT_AUTOPOP = 2
    TTDT_INITIAL = 3
End EnumPublic Enum ttDelayTimeConstants
    ttDelayDefault = TTDT_AUTOMATIC '= 0
    ttDelayInitial = TTDT_INITIAL '= 3
    ttDelayShow = TTDT_AUTOPOP '= 2
    ttDelayReshow = TTDT_RESHOW '= 1
    ttDelayMask = 3
End EnumPublic Enum ttMarginConstants
    ttMarginLeft = 0
    ttMarginTop = 1
    ttMarginRight = 2
    ttMarginBottom = 3
End EnumPublic Type TTHITTESTINFO
    hWnd As Long
    pt   As POINTAPI
    ti   As TOOLINFO
End TypePublic Enum TT_Msgs
    TTM_ACTIVATE = (WM_USER + 1)
    TTM_SETDELAYTIME = (WM_USER + 3)
    TTM_RELAYEVENT = (WM_USER + 7)
    TTM_GETTOOLCOUNT = (WM_USER + 13)
    TTM_WINDOWFROMPOINT = (WM_USER + 16)
#If UNICODE Then
    TTM_ADDTOOL = (WM_USER + 50)
    TTM_DELTOOL = (WM_USER + 51)
    TTM_NEWTOOLRECT = (WM_USER + 52)
    TTM_GETTOOLINFO = (WM_USER + 53)
    TTM_SETTOOLINFO = (WM_USER + 54)
    TTM_HITTEST = (WM_USER + 55)
    TTM_GETTEXT = (WM_USER + 56)
    TTM_UPDATETIPTEXT = (WM_USER + 57)
    TTM_ENUMTOOLS = (WM_USER + 58)
    TTM_GETCURRENTTOOL = (WM_USER + 59)
#Else
    TTM_ADDTOOL = (WM_USER + 4)
    TTM_DELTOOL = (WM_USER + 5)
    TTM_NEWTOOLRECT = (WM_USER + 6)
    TTM_GETTOOLINFO = (WM_USER + 8)
    TTM_SETTOOLINFO = (WM_USER + 9)
    TTM_HITTEST = (WM_USER + 10)
    TTM_GETTEXT = (WM_USER + 11)
    TTM_UPDATETIPTEXT = (WM_USER + 12)
    TTM_ENUMTOOLS = (WM_USER + 14)
    TTM_GETCURRENTTOOL = (WM_USER + 15)
#End If#If (WIN32_IE >= &H300) Then
    TTM_TRACKACTIVATE = (WM_USER + 17)
    TTM_TRACKPOSITION = (WM_USER + 18)
    TTM_SETTIPBKCOLOR = (WM_USER + 19)
    TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
    TTM_GETDELAYTIME = (WM_USER + 21)
    TTM_GETTIPBKCOLOR = (WM_USER + 22)
    TTM_GETTIPTEXTCOLOR = (WM_USER + 23)
    TTM_SETMAXTIPWIDTH = (WM_USER + 24)
    TTM_GETMAXTIPWIDTH = (WM_USER + 25)
    TTM_SETMARGIN = (WM_USER + 26)
    TTM_GETMARGIN = (WM_USER + 27)
    TTM_POP = (WM_USER + 28)
#End If#If (WIN32_IE >= &H400) Then
    TTM_UPDATE = (WM_USER + 29)
#End If
End EnumPublic Enum TT_Notifications
    TTN_FIRST = -520&
    TTN_LAST = -549&
#If UNICODE Then
    TTN_NEEDTEXT = (TTN_FIRST - 10)
#Else
    TTN_NEEDTEXT = (TTN_FIRST - 0)
#End If
    TTN_SHOW = (TTN_FIRST - 1)
    TTN_POP = (TTN_FIRST - 2)
End EnumPublic Type NMTTDISPINFO
    hdr      As NMHDR
    lpszText As Long
#If UNICODE Then
    szText As String * 160
#Else
    szText As String * 80
#End If
    hinst  As Long
    uFlags As Long
#If (WIN32_IE >= &H300) Then
    lParam As Long
#End If
End Type'
' Exported by Comctl32.dll >= v4.00.950
' Ensures that the common control dynamic
' link library (DLL) is loaded.
'
' NOTE: API replaced by InitCommonControlsEx
Public Declare Sub InitCommonControls Lib "comctl32.dll" ()
Public Declare Function SendMessageT Lib "user32" _
    Alias "SendMessageA" (ByVal hWnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, _
    lParam As Any) As LongPublic 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 LongPublic Declare Function DestroyWindow Lib "user32" _
    (ByVal hWnd As Long) As LongPublic Declare Sub MoveMemory Lib "kernel32" _
    Alias "RtlMoveMemory" (pDest As Any, pSource As Any, _
    ByVal dwLength As Long)

'class module
Option Explicit
'
' Defaults:
' DelayInitial   = 500  (1/2 sec)
' DelayAutoPopup = 5000  (5 secs)
' DelayReshow    = 100 (1/10 sec)
' MaxTipWidth    = 0
' all Margins    = 0Private mnlgHwndTT As Long
Private mnlgMaxTip As Long
Public Function Create(ByRef frm As Form) As Boolean

    If (mnlgHwndTT = 0) Then
        Call InitCommonControls

        '
        ' The hwndParent param lets the tooltip window
        ' be owned by the specified form and be destroyed
        ' along with it. We'll cleanup in Class_Terminate anyway.
        ' No WS_EX_TOPMOST or TTS_ALWAYSTIP per Win95 UI rules.
        '
        mnlgHwndTT = CreateWindowEx(0, TOOLTIPS_CLASS, vbNullString, TTS_ALWAYSTIP, 0, 0, 0, 0, frm.hWnd, 0, App.hInstance, ByVal 0)
    End If

    Create = CBool(mnlgHwndTT)End FunctionPrivate Sub Class_Terminate()    If mnlgHwndTT > 0 Then Call DestroyWindow(mnlgHwndTT)

End Sub
Public Function AddTool(ByRef ctrl As Control, Optional ByVal strText As String) As Boolean
Dim ti As TOOLINFO

    If (mnlgHwndTT = 0) Then Exit Function

    If (fGetToolInfo(ctrl.hWnd, ti) = False) Then
        With ti
            .cbSize = Len(ti)
            '
            ' TTF_IDISHWND must be set to tell the tooltip
            ' control to retrieve the control's rect from
            ' it's hWnd specified in uId.
            '
            .uFlags = TTF_SUBCLASS Or TTF_IDISHWND
            .hWnd = ctrl.Container.hWnd
            .uId = ctrl.hWnd

            If Len(strText) > 0 Then
                .lpszText = strText
'            Else
'                .lpszText = "Tool" & ToolCount + 1
            End If

            '
            ' Maintain the maximun tip text
            ' length for fGetToolInfo.
            '
            mnlgMaxTip = fMax(mnlgMaxTip, Len(.lpszText) + 1)
        End With

        '
        ' Returns 1 on success, 0 on failure
        '
        AddTool = SendMessageT(mnlgHwndTT, TTM_ADDTOOL, 0, ti)
    End If

End FunctionPrivate Function fMax(ByVal lngParm1 As Long, ByVal lngParm2 As Long) As Long
    '
    ' Returns the larger of the two values.
    '
    If lngParm1 > lngParm2 Then
        fMax = lngParm1
    Else
        fMax = lngParm2
    End If

End Function
Public Function RemoveTool(ByRef ctrl As Control) As Boolean
Dim ti As TOOLINFO    If (mnlgHwndTT = 0) Then Exit Function

    If fGetToolInfo(ctrl.hWnd, ti) Then
        Call SendMessageT(mnlgHwndTT, TTM_DELTOOL, 0, ti)
        RemoveTool = True
    End IfEnd Function
Public Property Get BackColor() As OLE_COLOR

    If (mnlgHwndTT = 0) Then Exit Property

    '
    ' OLE_COLOR is defined in stdole2.tlb
    '
    BackColor = SendMessageT(mnlgHwndTT, TTM_GETTIPBKCOLOR, 0, 0)

End Property
Public Property Let BackColor(clr As OLE_COLOR)

    If (mnlgHwndTT = 0) Then Exit Property
    Call SendMessageT(mnlgHwndTT, TTM_SETTIPBKCOLOR, clr, 0)End Property
Public Property Get DelayTime(dwType As ttDelayTimeConstants) As Long

    If (mnlgHwndTT = 0) Then Exit Property
    DelayTime = SendMessageT(mnlgHwndTT, TTM_GETDELAYTIME, (dwType And ttDelayMask), 0&)

End Property
Public Property Let DelayTime(dwType As ttDelayTimeConstants, dwMilliSecs As Long)

    If (mnlgHwndTT = 0) Then Exit Property
    Call SendMessageT(mnlgHwndTT, TTM_SETDELAYTIME, (dwType And ttDelayMask), ByVal dwMilliSecs)  ' no rtn valEnd Property
Public Property Get ForeColor() As OLE_COLOR

    If (mnlgHwndTT = 0) Then Exit Property
    ForeColor = SendMessageT(mnlgHwndTT, TTM_SETTIPTEXTCOLOR, 0, 0)End Property
Public Property Let ForeColor(clr As OLE_COLOR)

    If (mnlgHwndTT = 0) Then Exit Property
    Call SendMessageT(mnlgHwndTT, TTM_SETTIPTEXTCOLOR, clr, 0)   ' no rtn valEnd Property
Public Property Get hWnd() As Long    hWnd = mnlgHwndTT

End Property
Public Property Get Margin(dwType As ttMarginConstants) As Long
Dim rc As RECT    If (mnlgHwndTT = 0) Then Exit Property

    Call SendMessageT(mnlgHwndTT, TTM_GETMARGIN, 0, rc)

    Select Case dwType
        Case ttMarginLeft
            Margin = rc.Left

        Case ttMarginTop
            Margin = rc.Top

        Case ttMarginRight
            Margin = rc.Right

        Case ttMarginBottom
            Margin = rc.Bottom
    End SelectEnd Property

Public Property Let Margin(dwType As ttMarginConstants, cPixels As Long)
Dim rc As RECT

    If (mnlgHwndTT = 0) Then Exit Property

    Call SendMessageT(mnlgHwndTT, TTM_GETMARGIN, 0, rc)

    Select Case dwType
        Case ttMarginLeft
            rc.Left = cPixels

        Case ttMarginTop
            rc.Top = cPixels

        Case ttMarginRight
            rc.Right = cPixels

        Case ttMarginBottom
            rc.Bottom = cPixels
    End Select

    Call SendMessageT(mnlgHwndTT, TTM_SETMARGIN, 0, rc)End Property
Public Property Get MaxTipWidth() As Long    '
    ' If MaxTipWidth is -1, there is no word wrapping and
    ' text control characters are printed and not
    ' evaluated (i.e. a vbCrLf shows up as "||")
    '
    If (mnlgHwndTT = 0) Then Exit Property
    MaxTipWidth = fLowWord(SendMessageT(mnlgHwndTT, TTM_GETMAXTIPWIDTH, 0, 0))End Property
Private Function fLowWord(ByVal lngValue As Long) As Integer
    '
    ' Returns the low-order word from a 32-bit value.
    '
    Call MoveMemory(fLowWord, lngValue, 2)

End Function
Public Property Let MaxTipWidth(ByVal lngWidth As Long)

    '
    ' If MaxTipWidth is -1, there is no word wrapping and
    ' text control characters are printed and not
    ' evaluated (i.e. a vbCrLf shows up as "||")
    '
    If mnlgHwndTT = 0 Then Exit Property
    If lngWidth < 1 Then lngWidth = -1
    Call SendMessageT(mnlgHwndTT, TTM_SETMAXTIPWIDTH, 0, lngWidth)End Property
Public Property Get ToolCount() As Long

    If (mnlgHwndTT = 0) Then Exit Property
    ToolCount = SendMessageT(mnlgHwndTT, TTM_GETTOOLCOUNT, 0, 0)End Property
Public Property Get ToolTipHandle() As Long

    ToolTipHandle = mnlgHwndTTEnd PropertyPublic Property Get ToolText(ByRef ctrl As Control) As String
Dim ti As TOOLINFO

    If (mnlgHwndTT = 0) Then Exit Property

    If fGetToolInfo(ctrl.hWnd, ti, True) Then
        ToolText = fGetStrFromBuffer(ti.lpszText)
    End IfEnd Property
Private Function fGetStrFromBuffer(ByVal strValue As String) As String

    If InStr(strValue, vbNullChar) Then
        fGetStrFromBuffer = Left$(strValue, InStr(strValue, vbNullChar) - 1)
    Else
        '
        ' If strValue had no null char, the Left$ function
        ' above would rtn a zero length string ("").
        '
        fGetStrFromBuffer = strValue
    End If

End Function
Public Property Let ToolText(ByRef ctrl As Control, ByVal strText As String)
Dim ti As TOOLINFO

    If (mnlgHwndTT = 0) Then Exit Property

    If fGetToolInfo(ctrl.hWnd, ti) Then
        ti.lpszText = strText
        mnlgMaxTip = fMax(mnlgMaxTip, Len(strText) + 1)
        '
        ' The tooltip won't appear for the control
        ' if lpszText is an empty string
        '
        Call SendMessageT(mnlgHwndTT, TTM_UPDATETIPTEXT, 0, ti)
    End IfEnd Property
Private Function fIsWindow(ByRef ctrl As Control) As Boolean

    On Error GoTo ErrorHandler
    fIsWindow = CBool(ctrl.hWnd)

ErrorHandler:
End Function
Private Function fGetToolInfo(ByVal lnghwndTool As Long, ti As TOOLINFO, _
    Optional fGetText As Boolean = False) As Boolean

Dim nItems As Long
Dim i      As Integer    ti.cbSize = Len(ti)
    If fGetText Then ti.lpszText = String$(mnlgMaxTip, 0)

    nItems = ToolCount

    For i = 0 To nItems - 1
        '
        ' Returns 1 on success, 0 on failure.
        '
        If SendMessageT(mnlgHwndTT, TTM_ENUMTOOLS, (i), ti) Then
            If (lnghwndTool = ti.uId) Then
                fGetToolInfo = True
                Exit Function
            End If
        End If
    NextEnd Function

调试易

怎么能让tooltiptext分行显示信息？？？－－　在线等

解决方案 »

怎么能让tooltiptext分行显示信息？？？－－ 在线等

解决方案 »

怎么能让tooltiptext分行显示信息？？？－－　在线等