【转】实现多行toolTips的类模块

注：本文转自CSDN论坛
这里有一个类模块,就是用来实现多行   toolTips   的.  
    
  Option   Explicit  
   
   
  '============================================================='  
  '   Module   Name               :   mdlAPI  
  '   Written   By                 :   Gordon   Robinson  
  '   Date                             :   08/05/2000  
  '   Comments                     :  
  '  
  '============================================================='  
   
   
  '============================================================='  
  '   Constants  
  '============================================================='  
   
  Private   Const   TTS_ALWAYSTIP   =   &H1  
  Private   Const   TTS_NOPREFIX   =   &H2  
   
  Private   Const   CW_USEDEFAULT   =   &H80000000  
   
  Private   Const   WS_POPUP   =   &H80000000  
   
  Private   Const   WM_USER   =   &H400  
   
  Private   Const   TTM_ADDTOOL   =   WM_USER   +   4  
  Private   Const   TTM_SETMAXTIPWIDTH   =   WM_USER   +   24  
  Private   Const   TTM_SETDELAYTIME   =   WM_USER   +   3  
  Private   Const   TTM_GETDELAYTIME   =   WM_USER   +   21  
   
  Private   Const   TTDT_AUTOMATIC   =   0  
  Private   Const   TTDT_RESHOW   =   1  
  Private   Const   TTDT_AUTOPOP   =   2  
  Private   Const   TTDT_INITIAL   =   3  
   
  Private   Const   TTF_SUBCLASS   =   &H10  
  Private   Const   TTF_IDISHWND   =   &H1  
  Private   Const   TTF_CENTERTIP   =   &H2  
   
   
  '============================================================='  
  '   Types  
  '============================================================='  
   
  Private   Type   RECT  
          Left   As   Long  
          Top   As   Long  
          Right   As   Long  
          Bottom   As   Long  
  End   Type  
   
  Private   Type   TOOLINFO  
          cbSize             As   Long  
          uFlags             As   Long  
          hwnd                 As   Long  
          uId                   As   Long  
          cRect               As   RECT  
          hinst               As   Long  
          lpszText         As   String  
  End   Type  
   
   
   
  '============================================================='  
  '   API   Functions  
  '============================================================='  
   
  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   Declare   Function   DestroyWindow   Lib   "user32"   _  
          (ByVal   hwnd   As   Long)   _  
          As   Long  
   
  Private   Declare   Function   GetClientRect   Lib   "user32"   _  
          (ByVal   hwnd   As   Long,   _  
            lpRect   As   RECT)   _  
          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   SendMessageLong   Lib   "user32"   Alias   "SendMessageA"   _  
          (ByVal   hwnd   As   Long,   _  
            ByVal   wMsg   As   Long,   _  
            ByVal   wParam   As   Long,   _  
            ByVal   lParam   As   Long)   _  
          As   Long  
   
   
   
   
  '====================================================================='  
  '   Member   Variables  
  '====================================================================='  
   
  Private   m_lngHwnd                               As   Long  
  Private   m_lngMaxWidth                       As   Long  
   
  '====================================================================='  
  '   Properties  
  '====================================================================='  
   
  Public   Property   Get   MaxWidth()   As   Long  
   
          MaxWidth   =   m_lngMaxWidth  
   
  End   Property  
   
  Public   Property   Let   MaxWidth(lngMaxWidth   As   Long)  
   
          m_lngMaxWidth   =   lngMaxWidth  
          SendMessageLong   m_lngHwnd,   TTM_SETMAXTIPWIDTH,   0,   m_lngMaxWidth  
   
  End   Property  
   
  Public   Property   Get   VisibleTime()   As   Long  
   
          VisibleTime   =   SendMessageLong(m_lngHwnd,   TTM_GETDELAYTIME,   TTDT_AUTOPOP,   0)  
   
  End   Property  
   
  Public   Property   Let   VisibleTime(lngTime   As   Long)  
   
          If   lngTime   >   32767   Then   lngTime   =   32767  
          If   lngTime   <   0   Then   lngTime   =   0  
           
          SendMessageLong   m_lngHwnd,   TTM_SETDELAYTIME,   TTDT_AUTOPOP,   lngTime  
   
  End   Property  
   
  Public   Property   Get   DelayTime()   As   Long  
   
          DelayTime   =   SendMessageLong(m_lngHwnd,   TTM_GETDELAYTIME,   TTDT_INITIAL,   0)  
   
  End   Property  
   
  Public   Property   Let   DelayTime(lngTime   As   Long)  
   
          If   lngTime   >   32767   Then   lngTime   =   32767  
          If   lngTime   <   0   Then   lngTime   =   0  
           
          SendMessageLong   m_lngHwnd,   TTM_SETDELAYTIME,   TTDT_INITIAL,   lngTime  
   
  End   Property  
   
   
   
  '====================================================================='  
  '   Methods  
  '====================================================================='  
   
  Public   Sub   Create(lngHwndParent   As   Long)  
   
          m_lngHwnd   =   CreateWindowEx(0,   _  
                                                                "tooltips_class32",   _  
                                                                0,   _  
                                                                TTS_NOPREFIX   Or   TTS_ALWAYSTIP,   _  
                                                                CW_USEDEFAULT,   _  
                                                                CW_USEDEFAULT,   _  
                                                                CW_USEDEFAULT,   _  
                                                                CW_USEDEFAULT,   _  
                                                                lngHwndParent,   _  
                                                                0,   _  
                                                                App.hInstance,   _  
                                                                0)  
           
          SendMessageLong   m_lngHwnd,   TTM_SETMAXTIPWIDTH,   0,   m_lngMaxWidth  
   
  End   Sub  
   
  Public   Sub   Destroy()  
   
          DestroyWindow   m_lngHwnd  
           
  End   Sub  
   
  Public   Sub   AddControl(ctlTool   As   Object,   strCaption   As   String,   Optional   blnCenterTip   As   Boolean   =   False)  
   
          Dim   udtToolInfo   As   TOOLINFO  
           
          With   udtToolInfo  
           
                  GetClientRect   ctlTool.hwnd,   .cRect  
                  .hwnd   =   ctlTool.hwnd  
                   
                  .uFlags   =   TTF_IDISHWND   Or   TTF_SUBCLASS  
                  If   blnCenterTip   Then  
                          .uFlags   =   .uFlags   Or   TTF_CENTERTIP  
                  End   If  
                   
                  .uId   =   ctlTool.hwnd  
                  .lpszText   =   strCaption  
                  .cbSize   =   Len(udtToolInfo)  
                   
          End   With  
           
          SendMessage   m_lngHwnd,   TTM_ADDTOOL,   0,   udtToolInfo  
           
  End   Sub  
   
   
  '====================================================================='  
  '   Events  
  '====================================================================='  
   
  Private   Sub   Class_Initialize()  
   
          m_lngMaxWidth   =   300  
   
  End   Sub  

【使用方法】
将上面那段源程序存为一个类模块,名为   cTooltop 
  首先应该建立一个form然后在form上添加文本框：复选框chkAddToCurrentGroup，txtemail,txttelephone,...然后就可以了
  然后在窗体的   Form_Load   中写如下代码即可.  
   
  Dim   ct   As   New   cTooltip  
  '========================================================  
  '设置多行的提示信息  
  ct.Create   Me.hwnd                 '父窗体句柄  
  ct.DelayTime   =   100               '延迟时间  
  ct.VisibleTime   =   5000         '显示时间  
   
  ct.AddControl   chkAddToCurrentGroup,   "如果选中此项,那么数据录入时,"   &   vbCrLf   &   _  
                                                                          "同时将此记录加入当前选中了的分组。"   &   vbCrLf   &   _  
                                                                          "如果选中了多个组，那么它将加入多个组"  
   
  ct.AddControl   txtAddress,   "这里的地址是指除去省名、地区之外的更详细的地址。"   &   vbCrLf   &   _  
                                                      "也就是说,这里不必也不能填写省名、地区了。"   &   vbCrLf   &   _  
                                                      "例如:   广东省广州市中山八路   8888   号"   &   vbCrLf   &   _  
                                                      "在此只需填写   “中山八路   8888   号”即可"  
  ct.AddControl   txtUnit,   "这里填写单位、公司。"   &   vbCrLf   &   _  
                                                "如:大发公司财务处"  
   
  ct.AddControl   txtTelephone,   "你可以在此快速录入电话号码."   &   vbCrLf   &   _  
                                                          "号码之间以分号(;)分隔."   &   vbCrLf   &   _  
                                                          "电话号码以类别字母开头(缺省认为家庭电话)"   &   vbCrLf   &   _  
                                                          "类别字母为(注意数字   0   与字母   o   的区别):"   &   vbCrLf   &   _  
                                                          "o   办公       h   家庭       m   移动       f   传真       c   呼机"   &   vbCrLf   &   _  
                                                          "例如:o020-87332053-8888;m13660888888;c95950-88888"  
   
  ct.AddControl   txtEmail,   "你可以在此快速录入电子邮箱."   &   vbCrLf   &   _  
                                                  "邮箱之间以分号(;)分隔."   &   vbCrLf   &   _  
                                                  "如:yourgod@god.com;mygod@god.net"