急！看起来容易做起来难，再次求教关于多行tooltips，多少分都愿意给！

http://dev.csdn.net/develop/article/24/article/23/23244.shtm

Option ExplicitPrivate Const GWL_WNDPROC = -4
Private Const GWL_STYLE = (-16)Private Const WS_BORDER = &H800000Private Const FW_NORMAL = 400
Private Const FW_HEAVY = 900
Private Const FW_SEMIBOLD = 600
Private Const FW_BLACK = FW_HEAVY
Private Const FW_BOLD = 700
Private Const FW_DEMIBOLD = FW_SEMIBOLD
Private Const FW_DONTCARE = 0
Private Const FW_EXTRABOLD = 800
Private Const FW_EXTRALIGHT = 200
Private Const FW_LIGHT = 300
Private Const FW_MEDIUM = 500
Private Const FW_REGULAR = FW_NORMAL
Private Const FW_THIN = 100
Private Const FW_ULTRABOLD = FW_EXTRABOLD
Private Const FW_ULTRALIGHT = FW_EXTRALIGHTPrivate Const SW_SHOWNA = 8
Private Const TRANSPARENT = 1
Private Const ALTERNATE = 1
Private Const BLACK_BRUSH = 4
Private Const DKGRAY_BRUSH = 3Private Const DT_SINGLELINE = &H20
Private Const DT_NOCLIP = &H100
Private Const DT_CENTER = &H1
Private Const DT_VCENTER = &H4
Private Const DT_WORDBREAK = &H10
Private Const DT_CALCRECT = &H400Private Const CW_USEDEFAULT = &H80000000Private Const TTS_ALWAYSTIP = 1Private Const TTF_IDISHWND = 1
Private Const TTF_CENTERTIP = 2
Private Const TTF_RTLREADING = 4
Private Const TTF_SUBCLASS = &H10
Private Const TTF_TRACK = &H20
Private Const TTF_ABSOLUTE = &H80
Private Const TTF_TRANSPARENT = &H100
Private Const TTF_DI_SETITEM = &H8000Private Const WM_USER = &H400
Private Const WM_PAINT = &HF
Private Const WM_PRINT = &H317Private Const TTM_ACTIVATE = WM_USER + 1
Private Const TTM_SETDELAYTIME = WM_USER + 3
Private Const TTM_ADDTOOL = WM_USER + 4
Private Const TTM_DELTOOL = WM_USER + 5
Private Const TTM_NEWTOOLRECT = WM_USER + 6
Private Const TTM_RELAYEVENT = WM_USER + 7Private Const LF_FACESIZE = 32
Private Const COLOR_INFOTEXT = 23
Private Const COLOR_INFOBK = 24
Private Const COLOR_GRAYTEXT = 17
Private Const COLOR_3DLIGHT = 22Private Const RGN_OR = 2
Public Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As LongPrivate Declare Function CreateWindowEx Lib "user32.dll" 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 LongPrivate Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
    lParam As Any) As LongPrivate Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" ( _
    ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As LongPrivate Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _
    ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPrivate Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" ( _
    ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As LongPrivate Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" ( _
    ByVal hwnd As Long, ByVal nIndex As Long) As LongPrivate Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, _
    lpRect As RECT) As LongPrivate Declare Function ShowWindow Lib "user32.dll" (ByVal hwnd As Long, _
    ByVal nCmdShow As Long) As LongPrivate Declare Function MoveWindow Lib "user32.dll" (ByVal hwnd As Long, _
    ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, _
    ByVal nHeight As Long, ByVal bRepaint As Long) As LongPrivate Declare Function BeginPaint Lib "user32.dll" (ByVal hwnd As Long, _
    lpPaint As PAINTSTRUCT) As LongPrivate Declare Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" ( _
    ByVal hwnd As Long) As LongPrivate Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" ( _
    ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As LongPrivate Declare Function EndPaint Lib "user32.dll" (ByVal hwnd As Long, _
    lpPaint As PAINTSTRUCT) As LongPrivate Declare Function GetSysColor Lib "user32.dll" (ByVal nIndex As Long) As LongPrivate Declare Function GetClientRect Lib "user32.dll" (ByVal hwnd As Long, _
    lpRect As RECT) As LongPrivate Declare Function DrawText Lib "user32.dll" Alias "DrawTextA" ( _
    ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, _
    lpRect As RECT, ByVal wFormat As Long) As LongPrivate Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As LongPrivate Declare Function SetBkMode Lib "gdi32.dll" (ByVal hdc As Long, _
    ByVal nBkMode As Long) As LongPrivate Declare Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" ( _
    lpLogFont As LOGFONT) As LongPrivate Declare Function SetTextColor Lib "gdi32.dll" (ByVal hdc As Long, _
    ByVal crColor As Long) As LongPrivate Declare Function CreateRectRgn Lib "gdi32.dll" (ByVal X1 As Long, _
    ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPrivate Declare Function CreateRoundRectRgn Lib "gdi32.dll" (ByVal X1 As Long, _
    ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, _
    ByVal Y3 As Long) As LongPrivate Declare Function CreatePolygonRgn Lib "gdi32.dll" (lpPoint As POINTAPI, _
    ByVal nCount As Long, ByVal nPolyFillMode As Long) As LongPrivate Declare Function CombineRgn Lib "gdi32.dll" (ByVal hDestRgn As Long, _
    ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, _
    ByVal nCombineMode As Long) As LongPrivate Declare Function FillRgn Lib "gdi32.dll" (ByVal hdc As Long, _
    ByVal hRgn As Long, ByVal hBrush As Long) As LongPrivate Declare Function GetSysColorBrush Lib "user32.dll" ( _
    ByVal nIndex As Long) As LongPrivate Declare Function FrameRgn Lib "gdi32.dll" (ByVal hdc As Long, _
    ByVal hRgn As Long, ByVal hBrush As Long, _
    ByVal nWidth As Long, ByVal nHeight As Long) As LongPrivate Declare Function GetStockObject Lib "gdi32.dll" (ByVal nIndex As Long) As LongPrivate Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, _
    ByVal hObject As Long) As LongPrivate Declare Function DeleteObject Lib "gdi32.dll" ( _
    ByVal hObject As Long) As LongPrivate Type POINTAPI
    X As Long
    Y As Long
End TypePrivate Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End TypePrivate Type TOOLINFO
    cbSize As Long
    uFlags As Long
    hwnd As Long
    uId As Long
    r As RECT
    hinst As Long
    lpszText As String
End TypePrivate Type PAINTSTRUCT
    hdc As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(32) As Byte
End TypePrivate Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(1 To LF_FACESIZE) As Byte
End TypePrivate Type TOldWndProc
    hwnd As Long
    lPrevWndProc As Long
End Type

Private WndProc() As TOldWndProc
Private NumTips As Long
Const iOffset = 8
Const FontType = "Tahoma" & vbNullChar
Const FontSize = 13
   Public hTip As Long
Private Function CustomTipProc(ByVal hwnd As Long, ByVal uiMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long    Dim ps As PAINTSTRUCT
    Dim lpszText As String
    Dim iTextLen As Integer
    Dim rc As RECT
    Dim hFont As Long
    Dim hFontOld As Long
    Dim lf As LOGFONT
    Dim i As Integer
    Dim CurPos As POINTAPI
  Select Case uiMsg
    Case WM_PRINT
        PostMessage hwnd, WM_PAINT, 0, 0
        CustomTipProc = 1
    Case WM_PAINT
        ' Get the Current Window Rect
        GetWindowRect hwnd, rc
        GetCursorPos CurPos
        rc.Right = CurPos.X - iOffset + 6 + rc.Right - rc.Left
        rc.Bottom = CurPos.Y + 20 + rc.Bottom - rc.Top
        rc.Left = CurPos.X - iOffset + 6
        rc.Top = CurPos.Y + 20
        MoveWindow hwnd, rc.Left, rc.Top, rc.Right - rc.Left, rc.Bottom - rc.Top, False
        ' Get the Window Text (the ToolTip Text)
        iTextLen = GetWindowTextLength(hwnd) + 1
        lpszText = Space(iTextLen)
        GetWindowText hwnd, lpszText, iTextLen
        lpszText = Left(lpszText, Len(lpszText) - 1)
        ' prepare the DC for drawing
        BeginPaint hwnd, ps
        ' create and select the font to be used
        lf.lfHeight = FontSize
        lf.lfWeight = FW_NORMAL
        For i = 1 To Len(FontType)
            lf.lfFaceName(i) = Asc(Mid(FontType, i, 1))
        Next
        hFont = CreateFontIndirect(lf)
        hFontOld = SelectObject(ps.hdc, hFont)
        ' enlarge the window to exactly fit the size of the tooltip text        ' using DT_CALCRECT the function extends the base of the
        ' rectangle to bound the last line of text but does not draw the text.
        DrawText ps.hdc, lpszText, Len(lpszText), rc, DT_VCENTER + DT_NOCLIP + DT_CALCRECT
        rc.Right = rc.Right + 2 * iOffset
        rc.Bottom = rc.Bottom + 3 * iOffset
        ' show the window before changing its size
        ' (work around the WM_PRINT problem/feature)
        ShowWindow hwnd, SW_SHOWNA
        ' apply new size
        MoveWindow hwnd, rc.Left, rc.Top, rc.Right - rc.Left, rc.Bottom - rc.Top, True
        SetBkMode ps.hdc, TRANSPARENT
        ' draw the balloon
        ToolTip_DrawBalloon hwnd, ps.hdc, lpszText
        ' Restore the Old Font
        SelectObject ps.hdc, hFontOld
        DeleteObject hFont
        ' End Paint
        EndPaint hwnd, ps
        CustomTipProc = 0
    Case Else
        ' Sends message to previous procedure
        For i = 0 To NumTips - 1
            If WndProc(i).hwnd = hwnd Then
                CustomTipProc = CallWindowProc(WndProc(i).lPrevWndProc, hwnd, uiMsg, _
                    wParam, lParam)
                Exit For
            End If
        Next
    End Select
End FunctionPrivate Sub ToolTip_DrawBalloon(hwndTip As Long, hdc As Long, lpszText As String)
    Dim rc As RECT
    Dim hRgn, hrgn1, hrgn2 As Long
    Dim pts(0 To 2) As POINTAPI    GetClientRect hwndTip, rc
    pts(0).X = rc.Left + iOffset
    pts(0).Y = rc.Top
    pts(1).X = pts(0).X
    pts(1).Y = pts(0).Y + iOffset
    pts(2).X = pts(1).X + iOffset
    pts(2).Y = pts(1).Y
    hRgn = CreateRectRgn(0, 0, 0, 0)
    ' Create the rounded box
    hrgn1 = CreateRoundRectRgn(rc.Left, rc.Top + iOffset, rc.Right, rc.Bottom, 15, 15)
    ' Create the arrow
    hrgn2 = CreatePolygonRgn(pts(0), 3, ALTERNATE)
    ' combine the two regions
    CombineRgn hRgn, hrgn1, hrgn2, RGN_OR
    ' Fill the Region with the Standard BackColor of the ToolTip Window
    FillRgn hdc, hRgn, GetSysColorBrush(COLOR_INFOBK)
    ' Draw the Frame Region
    FrameRgn hdc, hRgn, GetStockObject(DKGRAY_BRUSH), 1, 1
    rc.Top = rc.Top + iOffset * 2
    rc.Bottom = rc.Bottom - iOffset
    rc.Left = rc.Left + iOffset
    rc.Right = rc.Right - iOffset
    ' Draw the Shadow Text
    SetTextColor hdc, GetSysColor(COLOR_3DLIGHT)
    DrawText hdc, lpszText, Len(lpszText), rc, DT_VCENTER + DT_NOCLIP
    rc.Left = rc.Left - 1
    rc.Top = rc.Top - 1
    ' Draw the Text
    SetTextColor hdc, GetSysColor(COLOR_INFOTEXT)
    DrawText hdc, lpszText, Len(lpszText), rc, DT_VCENTER + DT_NOCLIP
End Sub' Add the Custom ToolTip to the specified object
Public Sub AddCustomToolTip(X As Object, ToolTipText As String, FormOwner As Form)
    Dim ti As TOOLINFO
    Dim dwStyle As Long    ' A tooltip control with the TTS_ALWAYSTIP style appears when the cursor is
    ' on a tool, regardless of whether the tooltip control's owner window is active
    ' or inactive. Without this style, the tooltip control appears when the tool's
    ' owner window is active, but not when it is inactive.
    hTip = CreateWindowEx(0&, "tooltips_class32", "", TTS_ALWAYSTIP, _
        CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
        FormOwner.hwnd, 0&, App.hInstance, 0&)
    ti.cbSize = Len(ti)
    ti.uFlags = TTF_IDISHWND + TTF_SUBCLASS
    ti.hwnd = X.hwnd
    ti.uId = X.hwnd
    ti.lpszText = ToolTipText
    SendMessage hTip, TTM_ADDTOOL, 0&, ti
    ' SubClass the tooltip window
    ReDim Preserve WndProc(NumTips)
    WndProc(NumTips).lPrevWndProc = SetWindowLong(hTip, GWL_WNDPROC, AddressOf CustomTipProc)
    WndProc(NumTips).hwnd = hTip
    NumTips = NumTips + 1
    ' Remove Border from ToolTip
    dwStyle = GetWindowLong(hTip, GWL_STYLE)
    dwStyle = dwStyle And (Not WS_BORDER)
    SetWindowLong hTip, GWL_STYLE, dwStyle
End Sub窗体中：
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
   (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongConst LVM_FIRST = &H1000&
Const LVM_HITTEST = LVM_FIRST + 18
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Dim m_lCurItemIndex As Long
Private Type LVHITTESTINFO
   pt As POINTAPI
   flags As Long
   iItem As Long
   iSubItem As Long
End Type
Private Sub Form_Load()
      With ListView1.ListItems
      .Add Text:="Test item #1 in line 1" & Chr(10) & Chr(13) & "Test item #1 in line2"
      .Add Text:="Test item #2" & Chr(10) & Chr(13) & "Test item #2 in line2"
      .Add Text:="test item #3" & Chr(10) & Chr(13) & "Test item #1 " & Chr(10) & Chr(13) & "Test item #1 "
   End WithEnd Sub
Private Sub ListView1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
   Dim lvhti As LVHITTESTINFO
   Dim lItemIndex As Long

   lvhti.pt.X = X / Screen.TwipsPerPixelX
   lvhti.pt.Y = Y / Screen.TwipsPerPixelY
   lItemIndex = SendMessage(ListView1.hwnd, LVM_HITTEST, 0, lvhti) + 1
   If m_lCurItemIndex <> lItemIndex Then
      m_lCurItemIndex = lItemIndex
      If m_lCurItemIndex = 0 Then   ' no item under the mouse pointer
        DestroyWindow hTip   '这里要请其他大侠改一下，因为可能资源没有完全释放
      Else
          AddCustomToolTip ListView1, ListView1.ListItems(m_lCurItemIndex).Text, Form1
      End If
   End If
End Sub

谢谢，辛苦了
但是listview在类模块里动态创建的话这个能实现么？
我看不出和上面的有什么本质上的区别啊？

呵呵，大师终于出现了没办法，这个我已经作了很久了
因为我这些控件在很多窗体都具有相同的属性和功能
这个我已经写了很多了，我想只能用类模块了大师能否在写个类似上面的代码么？
或者不用API怎么实现?
谢谢

不用 API，就另外用一个窗体作tooltips吧。

还是用个LABEL控件吧，多简单阿。
就为了这么一个效果用那么多代码不值得。

郁闷啊
因为用了activeskin，所以不能用label，所以只能用skinlabel，所以没有autosize属性

我这里有一个ctTips的控件，估计可以达到你想要得效果，但是这个控件是有Lisence的，所以只有发到你的邮箱。

没用过SkinLabel……
但是就算它没有AutoSize属性也可以用有AutoSize属性的Label来传值啊把Label1隐藏
然后在需要改SkinLabel的时候改Label1.Caption就可以间接实现AutoSize
Private Sub Label1_Change()
SkinLabel.Caption = Label1.Caption
SkinLabel.Width = Label1.Width
End Sub

呵呵
谢谢
这只是个折衷的办法啊
有没有更好的办法呢？
APRILSONG大师，能不能给我想个更好的方法呢？

顶！
APRILSONG大师，求您加我qq：1267663

调试易

急！看起来容易做起来难，再次求教关于多行tooltips，多少分都愿意给！

解决方案 »