home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / Connect_Fo214822412009.psc / cTooltip.cls < prev    next >
Text File  |  2009-04-01  |  15KB  |  366 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cTooltip"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. 'Custom Tooltip Class
  17.  
  18. Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Long, ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal fdwCharset As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
  19. 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
  20. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  21. Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
  22. Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As Rectangle) As Long
  23. Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
  24. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
  25. Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
  26. Private Declare Sub InitCommonControls Lib "comctl32" ()
  27. Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nMultiplier As Long, ByVal nDivisor As Long) As Long
  28. Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
  29. 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
  30. Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
  31.  
  32. Private Enum Consts
  33.     SWP_NOSIZE = &H1
  34.     SWP_NOMOVE = &H2
  35.     SWP_NOACTIVATE = &H10
  36.     SWP_FLAGS = SWP_NOACTIVATE Or SWP_NOSIZE Or SWP_NOMOVE
  37.     SWP_TOPMOST = -1
  38.     CW_USEDEFAULT = &H80000000
  39.     TTS_STANDARD = 0
  40.     TTS_BALLOON = &H40
  41.     TTS_ALWAYSTIP = 1               'display even if parent window is inactive
  42.     TTS_NOPREFIX = 2                'does not remove "&" from text
  43.     TTDT_AUTOPOP = 2
  44.     WM_USER = &H400
  45.     TTM_SETDELAYTIME = WM_USER + 3
  46.     TTM_ADDTOOL = WM_USER + 4
  47.     TTM_GETTEXT = WM_USER + 11
  48.     TTM_SETTIPBKCOLOR = WM_USER + 19
  49.     TTM_SETTIPTEXTCOLOR = WM_USER + 20
  50.     TTM_SETMAXTIPWIDTH = WM_USER + 24
  51.     TTM_SETTITLE = WM_USER + 32
  52.     WM_SETFONT = &H30
  53.     TTF_CENTERTIP = 2               'center tool on parent
  54.     TTF_SUBCLASS = &H10             'use implicit subclassing
  55.     fwDontCare = 0
  56.     fwBold = 700
  57.     DEFAULT_CHARSET = 1
  58.     LOGPIXELSY = 90
  59.     TTDT_INITIAL = 3
  60. End Enum
  61. #If False Then ':) Line inserted by Formatter
  62. Private SWP_NOSIZE, SWP_NOMOVE, SWP_NOACTIVATE, SWP_FLAGS, SWP_TOPMOST, CW_USEDEFAULT, TTS_STANDARD, TTS_BALLOON, TTS_ALWAYSTIP, TTS_NOPREFIX, _
  63.         TTDT_AUTOPOP, WM_USER, TTM_SETDELAYTIME, TTM_ADDTOOL, TTM_GETTEXT, TTM_SETTIPBKCOLOR, TTM_SETTIPTEXTCOLOR, TTM_SETMAXTIPWIDTH, _
  64.         TTM_SETTITLE, WM_SETFONT, TTF_CENTERTIP, TTF_SUBCLASS, fwDontCare, fwBold, DEFAULT_CHARSET, LOGPIXELSY, TTDT_INITIAL ':) Line inserted by Formatter
  65. #End If ':) Line inserted by Formatter
  66.  
  67. Public Enum TTStyle
  68.     TTStandardIfActive = TTS_STANDARD                   'suppress if parent form is not active
  69.     TTBalloonIfActive = TTS_BALLOON                     'suppress if parent form is not active
  70.     TTStandardAlways = TTS_STANDARD Or TTS_ALWAYSTIP    'display even if parent form is not active
  71.     TTBalloonAlways = TTS_BALLOON Or TTS_ALWAYSTIP      'display even if parent form is not active
  72.     TTNone = -1                                         'kill tooltip (this is simply treated as illegal, so after killing the current tip no new one is created)
  73. End Enum
  74. #If False Then ':) Line inserted by Formatter
  75. Private TTStandardIfActive, TTBalloonIfActive, TTStandardAlways, TTBalloonAlways, TTNone ':) Line inserted by Formatter
  76. #End If ':) Line inserted by Formatter
  77.  
  78. Public Enum TTIcon
  79.     TTIconNone = 0
  80.     TTIconInfo = 1         'i in white balloon
  81.     TTIconWarning = 2      '! in yellow triangle
  82.     TTIconError = 3        'x in red circle
  83.     'all have a light gray shadow so be careful when selecting the ToolTip BackColor
  84. End Enum
  85. #If False Then ':) Line inserted by Formatter
  86. Private TTIconNone, TTIconInfo, TTIconWarning, TTIconError ':) Line inserted by Formatter
  87. #End If ':) Line inserted by Formatter
  88.  
  89. Private Type Rectangle
  90.     Left        As Long
  91.     Top         As Long
  92.     Right       As Long
  93.     Bottom      As Long
  94. End Type
  95.  
  96. Private Type tToolInfo
  97.     ttSize      As Long
  98.     myFlags     As Long
  99.     ttParhWnd   As Long
  100.     ttId        As Long
  101.     ParentRect  As Rectangle
  102.     hInstance   As Long
  103.     pText       As String
  104.     lParam      As Long
  105. End Type
  106. Private ToolInfo                    As tToolInfo
  107.  
  108. Private Const ToolTipWindowClassName As String = "Tooltips_Class32"
  109. Private Const defFontName           As String = "Tahoma"
  110. Private Const defFontSize           As Long = 8
  111.  
  112. Private TThWnd                      As Long     'Tooltip window handle
  113. Private TThDC                       As Long     'Tooltip devive context
  114. Private TThFont                     As Long     'Tooltip font handle
  115.  
  116. 'my properties
  117. Private myStyle                     As TTStyle
  118. Private myIcon                      As TTIcon
  119. Private myForeColor                 As Long
  120. Private myBackColor                 As Long
  121. Private myText                      As String
  122. Private myTitle                     As String   'has the current title
  123. Private myHoverTime                 As Long     'time im millisecs (-1 = use default)
  124. Private myPopupTime                 As Long     'time im millisecs (-1 = use default)
  125. Private myInitialText               As Variant  'has the initial text
  126. Private myInitialTitle              As Variant  'has the initial title
  127. Private myFontName                  As String
  128. Private myFontSize                  As Long
  129. Private myFontBold                  As Boolean
  130. Private myFontItalic                As Boolean
  131.  
  132. Public Property Get BackCol() As Long
  133.  
  134.   'this returns the current tooltip backcolor
  135.  
  136.     BackCol = myBackColor
  137.  
  138. End Property
  139.  
  140. Public Property Get Centered() As Boolean
  141.  
  142.   'this returns the current tooltip alignment
  143.  
  144.     Centered = CBool(ToolInfo.myFlags And TTF_CENTERTIP)
  145.  
  146. End Property
  147.  
  148. Private Sub Class_Initialize()
  149.  
  150.     InitCommonControls 'doesn't matter that this is called for every class instance
  151.     myStyle = TTNone
  152.  
  153. End Sub
  154.  
  155. Private Sub Class_Terminate()
  156.  
  157.   'kill tooltip window if one exists
  158.  
  159.     KillFont 'kill the font object if one exists
  160.     If TThWnd Then
  161.         ReleaseDC TThWnd, TThDC 'release the popup window's device context
  162.         TThDC = 0
  163.         DestroyWindow TThWnd 'and destroy the window itself
  164.         TThWnd = 0
  165.     End If
  166.     myStyle = TTNone
  167.  
  168. End Sub
  169.  
  170. Public Function Create(Parent As Control, _
  171.                        Text As String, _
  172.                        Optional ByVal Style As TTStyle = TTBalloonAlways, _
  173.                        Optional ByVal Centered As Boolean = False, _
  174.                        Optional ByVal Icon As TTIcon = TTIconNone, _
  175.                        Optional Title As String = vbNullString, _
  176.                        Optional ByVal ForeColor As Long = vbButtonText, _
  177.                        Optional ByVal BackColor As Long = vbInfoBackground, _
  178.                        Optional ByVal HoverTime As Long = -1, _
  179.                        Optional ByVal PopupTime As Long = -1) As Long
  180.  
  181.   'Create the tooltip window for the tooltip's parent control if that has an hWnd
  182.   'This can now also create custom tooltips for hWnd-less controls (one at a time)
  183.   'just supply a fake hWnd (normally the containing form.hWnd) for windowless controls
  184.  
  185.     Class_Terminate 'kill font and tooltip window if one exists
  186.     With ToolInfo
  187.         On Error Resume Next
  188.             .ttParhWnd = Parent.hWnd 'the control's hWnd
  189.             If Err Then 'has no hWnd
  190.                 Err.Clear
  191.                 .ttParhWnd = Parent.Parent.hWnd 'so use the control's parent's hWnd temporarily
  192.             End If
  193.             If (Err = 0) And _
  194.                 (Style = TTBalloonAlways Or Style = TTStandardAlways Or Style = TTBalloonIfActive Or Style = TTStandardIfActive) And _
  195.                 (Icon = TTIconError Or Icon = TTIconInfo Or Icon = TTIconNone Or Icon = TTIconWarning) Then
  196.                 'the tooltip's parent control (or the parent of the tooltip's parent control) has an hWnd and the params are acceptable
  197.                 .ttSize = Len(ToolInfo)
  198.                 .myFlags = TTF_SUBCLASS Or IIf(Centered, TTF_CENTERTIP, 0&)
  199.                 GetClientRect .ttParhWnd, .ParentRect
  200.                 .hInstance = App.hInstance
  201.                 myTitle = Title
  202.                 If myInitialTitle = Empty Then
  203.                     myInitialTitle = myTitle
  204.                 End If
  205.                 myText = Replace$(Text, "|", vbCrLf) 'the vertical bar is used as line break character
  206.                 .pText = myText
  207.                 If myInitialText = Empty Then
  208.                     myInitialText = myText
  209.                 End If
  210.                 If ForeColor < 0 Then
  211.                     ForeColor = GetSysColor(ForeColor And &H7FFFFFFF)
  212.                 End If
  213.                 If BackColor < 0 Then
  214.                     BackColor = GetSysColor(BackColor And &H7FFFFFFF)
  215.                 End If
  216.                 If ForeColor = BackColor Then
  217.                     ForeColor = vbButtonText
  218.                     BackColor = vbInfoBackground
  219.                 End If
  220.                 myForeColor = ForeColor
  221.                 myBackColor = BackColor
  222.                 myStyle = Style
  223.                 myIcon = Icon
  224.                 myHoverTime = HoverTime
  225.                 If myHoverTime >= 0 And myHoverTime < 50 Then 'at least 50 millisecs
  226.                     myHoverTime = 50
  227.                 End If
  228.                 If PopupTime < 0 Then 'autotime depending on length of text
  229.                     myPopupTime = Len(myText) * 45 + 1500
  230.                   Else 'NOT POPUPTIME...
  231.                     myPopupTime = PopupTime
  232.                 End If
  233.                 'create tooltip window and set it's properties
  234.                 TThWnd = CreateWindowEx(0&, ToolTipWindowClassName, vbNullString, TTS_NOPREFIX Or Style, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, .ttParhWnd, 0&, .hInstance, 0&)
  235.                 TThDC = GetDC(TThWnd)
  236.  
  237.                 SetWindowPos TThWnd, SWP_TOPMOST, 0&, 0&, 0&, 0&, SWP_FLAGS
  238.                 With Screen
  239.                     SendMessage TThWnd, TTM_SETMAXTIPWIDTH, 0, ByVal .Width / .TwipsPerPixelX / 3
  240.                 End With 'SCREEN
  241.                 SendMessage TThWnd, TTM_ADDTOOL, 0&, ToolInfo
  242.                 SendMessage TThWnd, TTM_SETTITLE, Icon, ByVal myTitle
  243.                 SendMessage TThWnd, TTM_SETTIPTEXTCOLOR, myForeColor, ByVal 0&
  244.                 SendMessage TThWnd, TTM_SETTIPBKCOLOR, myBackColor, ByVal 0&
  245.                 SendMessage TThWnd, TTM_SETDELAYTIME, TTDT_INITIAL, ByVal myHoverTime
  246.                 SendMessage TThWnd, TTM_SETDELAYTIME, TTDT_AUTOPOP, ByVal myPopupTime
  247.                 SubstituteFont 'to fill myFontName, myFontSize, myFontBold, and myFontItalic
  248.                 Create = TThWnd 'return the tooltip window handle
  249.             End If
  250.         On Error GoTo 0
  251.     End With 'TOOLINFO
  252.  
  253. End Function
  254.  
  255. Public Property Get ForeCol() As Long
  256.  
  257.   'this returns the current tooltip forecolor
  258.  
  259.     ForeCol = myForeColor
  260.  
  261. End Property
  262.  
  263. Public Property Get HoverTime() As Long
  264.  
  265.   'this returns the current mouse hover time time in millicecs (-1 for default)
  266.  
  267.     HoverTime = myHoverTime
  268.  
  269. End Property
  270.  
  271. Public Property Get Icon() As TTIcon
  272.  
  273.   'this returns the current tooltip icon
  274.  
  275.     Icon = myIcon
  276.  
  277. End Property
  278.  
  279. Public Property Get InitialText() As String
  280.  
  281.   'this returns the inital tooltip text, ie the one that was supplied on creation
  282.  
  283.     InitialText = myInitialText
  284.  
  285. End Property
  286.  
  287. Public Property Get InitialTitle() As String
  288.  
  289.   'this returns the inital tooltip title, ie the one that was supplied on creation
  290.  
  291.     InitialTitle = myInitialTitle
  292.  
  293. End Property
  294.  
  295. Private Sub KillFont()
  296.  
  297.     If TThFont Then
  298.         DeleteObject TThFont
  299.         TThFont = 0
  300.     End If
  301.  
  302. End Sub
  303.  
  304. Public Property Get PopupTime() As Long
  305.  
  306.   'this returns the current max PopupTime time in millisecs (-1 for default)
  307.  
  308.     PopupTime = myPopupTime
  309.  
  310. End Property
  311.  
  312. Public Property Get Style() As TTStyle
  313.  
  314.   'this returns the current tooltip style
  315.  
  316.     Style = myStyle
  317.  
  318. End Property
  319.  
  320. Public Function SubstituteFont(Optional FontName As String = defFontName, _
  321.                                                              Optional ByVal FontSize As Long = defFontSize, _
  322.                                                              Optional ByVal Bold As Boolean = False, _
  323.                                                              Optional ByVal Italic As Boolean = False) As Long
  324.  
  325.   'modify tooltip font
  326.  
  327.     If TThWnd Then 'we have a tooltip window
  328.         Select Case FontSize 'limit fontsize to reasonable values
  329.           Case Is < 8
  330.             FontSize = 8
  331.           Case Is > 36
  332.             FontSize = 36
  333.         End Select
  334.         myFontName = Trim$(FontName)
  335.         myFontSize = FontSize
  336.         myFontBold = Bold
  337.         myFontItalic = Italic
  338.         KillFont 'kill any previous font and create a new one
  339.         TThFont = CreateFont(-MulDiv(myFontSize, GetDeviceCaps(TThDC, LOGPIXELSY), 72), 0, 0, 0, IIf(myFontBold, fwBold, fwDontCare), myFontItalic, 0, 0, DEFAULT_CHARSET, 0, 0, 0, 0, myFontName)
  340.         If TThFont Then                                 'font was successfully created...
  341.             SendMessage TThWnd, WM_SETFONT, TThFont, 0  'so send it to the tooltip window...
  342.             SubstituteFont = TThFont                    'and return font handle
  343.         End If
  344.     End If
  345.  
  346. End Function
  347.  
  348. Public Property Get Text() As String
  349.  
  350.   'this returns the current tooltip text
  351.  
  352.     Text = ToolInfo.pText
  353.  
  354. End Property
  355.  
  356. Public Property Get Title() As String
  357.  
  358.   'this returns the current tooltip Title
  359.  
  360.     Title = myTitle
  361.  
  362. End Property
  363.  
  364. ':) Ulli's VB Code Formatter V2.24.21 (2009-Apr-01 09:11)  Decl: 117  Code: 235  Total: 352 Lines
  365. ':) CommentOnly: 23 (6,5%)  Commented: 51 (14,5%)  Filled: 278 (79%)  Empty: 74 (21%)  Max Logic Depth: 4
  366.