vbAccelerator - Contents of code file: tipPopup.ctl

VERSION 5.00
Begin VB.UserControl tipPopup 
   AutoRedraw      =   -1  'True
   BackColor       =   &H80000018&
   CanGetFocus     =   0   'False
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000017&
   ScaleHeight     =   3600
   ScaleWidth      =   4800
   ToolboxBitmap   =   "tipPopup.ctx":0000
   Begin VB.Timer tmrTimeOut 
      Enabled         =   0   'False
      Interval        =   100
      Left            =   900
      Top             =   540
   End
End
Attribute VB_Name = "tipPopup"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const MAGIC_END_EDIT_IGNORE_WINDOW_PROP As String = "VBAL:SGRID:EDITOR"

Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type

Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As
 Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal
 hWnd As Long, ByVal lpString As String) 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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Declare Function ImageList_GetImageRect Lib "comctl32.dll" ( _
        ByVal hIml As Long, _
        ByVal i As Long, _
        prcImage As RECT _
    ) As Long
Private Declare Function ImageList_Draw Lib "comctl32.dll" ( _
        ByVal hIml As Long, ByVal i As Long, _
        ByVal hdcDst As Long, ByVal x As Long, ByVal y As Long, _
        ByVal fStyle As Long _
    ) As Long
Private Const ILD_NORMAL = 0
Private Const ILD_TRANSPARENT = 1
Private Const ILD_BLEND25 = 2
Private Const ILD_SELECTED = 4
Private Const ILD_FOCUS = 4
Private Const ILD_MASK = &H10&
Private Const ILD_IMAGE = &H20&
Private Const ILD_ROP = &H40&
Private Const ILD_OVERLAYMASK = 3840
Private Const ILC_COLOR = &H0
Private Const ILC_COLOR32 = &H20
Private Const ILC_MASK = &H1&

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
 As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal
 nWidth As Long, ByVal crColor As Long) As Long
Private Const PS_SOLID = 0
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal
 hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR
 As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long

'Private Declare Function LoadImageLong Lib "user32" Alias "LoadImageA" (ByVal
 hInst As Long, ByVal lpsz As Long, ByVal uType As Long, ByVal cx As Long,
 ByVal cy As Long, ByVal uFlags As Long) As Long
Private Declare Function LoadIconString Lib "user32" Alias "LoadIconA" (ByVal
 hInstance As Long, ByVal lpIconName As String) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal
 xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long,
 ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw
 As Long, ByVal diFlags As Long) As Long
Private Const DI_MASK = &H1
Private Const DI_IMAGE = &H2
Private Const DI_NORMAL = &H3
Private Const DI_COMPAT = &H4
Private Const DI_DEFAULTSIZE = &H8
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Const IMAGE_ICON = 1
Private Const LR_DEFAULTCOLOR = &H0
Private Const LR_MONOCHROME = &H1
Private Const LR_COLOR = &H2
Private Const LR_COPYRETURNORG = &H4
Private Const LR_COPYDELETEORG = &H8
Private Const LR_LOADFROMFILE = &H10
Private Const LR_LOADTRANSPARENT = &H20
Private Const LR_DEFAULTSIZE = &H40
Private Const LR_VGACOLOR = &H80
Private Const LR_LOADMAP3DCOLORS = &H1000&
Private Const LR_CREATEDIBSECTION = &H2000&
Private Const LR_COPYFROMRESOURCE = &H4000&
Private Const LR_SHARED = &H8000&

Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect
 As RECT) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect
 As RECT) As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal ptX As
 Long, ByVal ptY As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA"
 (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA"
 (ByVal hWnd As Long, ByVal nIndex As Long) As Long
   Private Const GWL_STYLE = (-16)
   Private Const WS_BORDER = &H800000
   Private Const WS_CHILD = &H40000000
   Private Const WS_DISABLED = &H8000000
   Private Const WS_VISIBLE = &H10000000
   Private Const WS_TABSTOP = &H100000
   Private Const WS_HSCROLL = &H100000
   Private Const GWL_EXSTYLE = (-20)
   Private Const WS_EX_TOPMOST = &H8&
   Private Const WS_EX_CLIENTEDGE = &H200&
   Private Const WS_EX_STATICEDGE = &H20000
   Private Const WS_EX_WINDOWEDGE = &H100&
   Private Const WS_EX_APPWINDOW = &H40000
   Private Const WS_EX_TOOLWINDOW = &H80&
   Private Const WS_EX_LAYERED As Long = &H80000

Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal
 nCmdShow As Long) As Long
   Private Const SW_HIDE = 0

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
   Private Const SWP_FRAMECHANGED = &H20        '  The frame changed: send
    WM_NCCALCSIZE
   Private Const SWP_NOACTIVATE = &H10
   Private Const SWP_NOMOVE = &H2
   Private Const SWP_NOOWNERZORDER = &H200      '  Don't do owner Z ordering
   Private Const SWP_NOREDRAW = &H8
   Private Const SWP_NOSIZE = &H1
   Private Const SWP_NOZORDER = &H4
   Private Const SWP_SHOWWINDOW = &H40
   Private Const HWND_DESKTOP = 0
   Private Const HWND_NOTOPMOST = -2
   Private Const HWND_TOP = 0
   Private Const HWND_TOPMOST = -1
   Private Const HWND_BOTTOM = 1

Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal
 hWndNewParent As Long) As Long


Private Declare Function DrawTextA Lib "user32" (ByVal hdc As Long, ByVal lpStr
 As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function DrawTextW Lib "user32" (ByVal hdc As Long, ByVal lpStr
 As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Const DT_LEFT = &H0&
    Private Const DT_TOP = &H0&
    Private Const DT_CENTER = &H1&
    Private Const DT_RIGHT = &H2&
    Private Const DT_VCENTER = &H4&
    Private Const DT_BOTTOM = &H8&
    Private Const DT_WORDBREAK = &H10&
    Private Const DT_SINGLELINE = &H20&
    Private Const DT_EXPANDTABS = &H40&
    Private Const DT_TABSTOP = &H80&
    Private Const DT_NOCLIP = &H100&
    Private Const DT_EXTERNALLEADING = &H200&
    Private Const DT_CALCRECT = &H400&
    Private Const DT_NOPREFIX = &H800
    Private Const DT_INTERNAL = &H1000&
    Private Const DT_WORD_ELLIPSIS = &H40000

Private Type OSVERSIONINFO
   dwVersionInfoSize As Long
   dwMajorVersion As Long
   dwMinorVersion As Long
   dwBuildNumber As Long
   dwPlatformId As Long
   szCSDVersion(0 To 127) As Byte
End Type
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA"
 (lpVersionInfo As OSVERSIONINFO) As Long
Private Const VER_PLATFORM_WIN32_NT = 2
Private Declare Function FrameRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As
 Long, ByVal hBrush As Long, ByVal nWidth As Long, ByVal nHeight As Long) As
 Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal
 hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (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 Long
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI,
 ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal
 hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1
 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Const RGN_AND = 1
Private Const RGN_COPY = 5
Private Const RGN_DIFF = 4
Private Const RGN_OR = 2
Private Const RGN_XOR = 3
Private Const RGN_MAX = RGN_COPY
Private Const RGN_MIN = RGN_AND
Private Const WINDING = 2
Private Const ALTERNATE = 1

Public Enum etpStandardIcons
   etpNone
   IDI_ERROR = 32513 ' Stop Error icon
   IDI_QUESTION = 32514 'Question mark icon.
   IDI_WARNING = 32515 'Exclamation point icon.
   IDI_INFORMATION = 32516 'Asterisk icon.
End Enum

Public Enum etpShowDirection
   etpShowBelow
   etpShowAbove
End Enum

Public Event Click()
Public Event TimeOut()

Private m_hWnd As Long
Private m_bDesignTime As Boolean
Private m_bIsNt As Boolean
Private m_bIsXp As Boolean
Private m_bShown As Boolean
Private m_eShowDirection As etpShowDirection
Private m_hRgn As Long
Private m_hRgnFrame As Long

Private m_lWidth As Long
Private m_lHeight As Long
Private m_lMinWidth As Long
Private m_lBubbleArrowSize As Long
Private m_rcText As RECT
Private m_rcTitle As RECT

Private m_sTitle As String
Private m_sText As String
Private m_hIml As Long
Private m_lIcon As Long
Private m_eStandardIcon As etpStandardIcons
Private m_hIcon As Long
Private m_bShowCloseButton As Boolean
Private m_lTimeOut As Long


Public Property Get Showing() As Boolean
   Showing = m_bShown
End Property
Public Sub Show(ByVal hWndRelativeTo As Long, ByVal x As Long, ByVal y As Long)
Dim tP As POINTAPI
   
   tP.x = x
   tP.y = y
   ClientToScreen hWndRelativeTo, tP
   pShowPopup tP.x, tP.y
   
End Sub
Public Sub Hide()
   pHidePopup
End Sub

Public Property Get ShowCloseButton() As Boolean
   ShowCloseButton = m_bShowCloseButton
End Property
Public Property Let ShowCloseButton(ByVal bState As Boolean)
   m_bShowCloseButton = bState
   pEvalSize
   pPaint
   PropertyChanged "ShowCloseButton"
End Property

Public Property Get hIml() As Long
   hIml = m_hIml
End Property
Public Property Let hIml(ByVal lhIml As Long)
   m_hIml = lhIml
   pEvalSize
   pPaint
End Property
Public Property Get Title() As String
   Title = m_sTitle
End Property
Public Property Let Title(ByVal sTitle As String)
   m_sTitle = sTitle
   pEvalSize
   pPaint
   PropertyChanged "Title"
End Property
Public Property Get StandardIcon() As etpStandardIcons
   StandardIcon = m_eStandardIcon
End Property
Public Property Let StandardIcon(ByVal eIcon As etpStandardIcons)
   m_eStandardIcon = eIcon
   If Not (m_hIcon = 0) Then
      DestroyIcon m_hIcon
   End If
   If (eIcon = IDI_ERROR) Or (eIcon = IDI_INFORMATION) Or (eIcon =
    IDI_QUESTION) Or (eIcon = IDI_WARNING) Then
      m_hIcon = LoadIconString(0, "#" & eIcon)
   End If
   pEvalSize
   PropertyChanged "StandardIcon"
End Property
Public Property Get IconIndex() As Long
   IconIndex = m_lIcon
End Property
Public Property Let IconIndex(ByVal lIndex As Long)
   m_lIcon = lIndex
   pEvalSize
End Property
Public Property Get Text() As String
   Text = m_sText
End Property
Public Property Let Text(ByVal sText As String)
   m_sText = sText
   pEvalSize
   pPaint
   PropertyChanged "Text"
End Property
Public Property Get TimeOut() As Long
   TimeOut = m_lTimeOut
End Property
Public Property Let TimeOut(ByVal lTimeOut As Long)
   m_lTimeOut = lTimeOut
   PropertyChanged "TimeOut"
End Property

Public Property Get BackColor() As OLE_COLOR
   BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal oColor As OLE_COLOR)
   UserControl.BackColor = oColor
   pPaint
   PropertyChanged "BackColor"
End Property
Public Property Get ForeColor() As OLE_COLOR
   ForeColor = UserControl.ForeColor
End Property
Public Property Let ForeColor(ByVal oColor As OLE_COLOR)
   UserControl.ForeColor = oColor
   pPaint
   PropertyChanged "ForeColor"
End Property
Public Property Get Font() As IFont
   Set Font = UserControl.Font
End Property
Public Property Let Font(ByVal fnt As IFont)
   pSetFont fnt
   PropertyChanged "Font"
End Property
Private Sub pSetFont(fnt As IFont)
   Set UserControl.Font = fnt
   pEvalSize
   pPaint
End Sub

Private Sub pPaint()
Dim lhDC As Long
Dim lTop As Long
Dim rcWork As RECT
Dim hBr As Long
Dim lR As Long

   UserControl.Cls
   
   lhDC = UserControl.hdc
   
   hBr = CreateSolidBrush(TranslateColor(vbButtonShadow))
   lR = FrameRgn(lhDC, m_hRgnFrame, hBr, 1, 1)
   Debug.Print lR
   DeleteObject hBr
   
   
   If (m_eShowDirection = etpShowBelow) Then
      lTop = m_lBubbleArrowSize
   End If
      
   ' Draw the icon if any
   If Not (m_hIcon = 0) Then
      DrawIconEx lhDC, 8, 4 + lTop, m_hIcon, 16, 16, 0, 0, DI_NORMAL
   ElseIf Not (m_hIml = 0) And (m_lIcon > -1) Then
   End If
   
   SetTextColor lhDC, TranslateColor(ForeColor)
   
   ' Draw the caption
   Dim iFntNow As IFont
   Set iFntNow = UserControl.Font
   Set UserControl.Font = BoldFont
   LSet rcWork = m_rcTitle
   OffsetRect rcWork, 0, lTop
   DrawText lhDC, m_sTitle, -1, rcWork, DT_SINGLELINE Or DT_VCENTER
   Set UserControl.Font = iFntNow
   
   ' Draw the close button if required
   
   
   ' Draw the text
   LSet rcWork = m_rcText
   OffsetRect rcWork, 0, lTop
   DrawText lhDC, m_sText, -1, rcWork, DT_WORDBREAK
   
   UserControl.Refresh
   
End Sub

Private Property Get IFontOf(iFnt As IFont)
   Set IFontOf = iFnt
End Property

Private Property Get BoldFont() As IFont
Dim sFntBold As New StdFont
Dim iFnt As IFont
   Set iFnt = UserControl.Font
   iFnt.Clone sFntBold
   sFntBold.Bold = True
   Set BoldFont = sFntBold
End Property

Private Sub pEvalSize()
Dim lMaxWidth As Long
Dim lWidth As Long
Dim lTitleHeight As Long
Dim lTextWidth As Long
Dim lHeight As Long
Dim rc As RECT
Dim lhDC As Long

   lhDC = UserControl.hdc

   '
   ' Determine the size of the title
   '
   If Len(m_sTitle) > 0 Then
      Dim iFntNow As IFont
      Set iFntNow = UserControl.Font
      Set UserControl.Font = BoldFont
      DrawText lhDC, m_sTitle, -1, rc, DT_CALCRECT Or DT_SINGLELINE
      Set UserControl.Font = iFntNow
   End If
   m_rcTitle.top = 4
   m_rcTitle.left = 4
   m_rcTitle.right = 4 + rc.right - rc.left
   m_rcTitle.bottom = 4 + rc.bottom - rc.top
   lTextWidth = rc.right - rc.left
   lTitleHeight = rc.bottom - rc.top
   ' Add spaces:
   lWidth = lTextWidth + 16
      
   ' Add Size of the close button
   If (m_bShowCloseButton) Then
      lWidth = lWidth + 16 + 8
      If (lTitleHeight < 20) Then
         lTitleHeight = 20
      End If
      OffsetRect m_rcTitle, 20, 0
   End If
   If (m_eStandardIcon = IDI_ERROR Or m_eStandardIcon = IDI_INFORMATION Or
    m_eStandardIcon = IDI_QUESTION Or m_eStandardIcon = IDI_WARNING) _
      Or (Not (m_hIml = 0) And (m_lIcon > -1)) Then
      lWidth = lWidth + 16 + 8
      OffsetRect m_rcTitle, 24, 0
      If (lTitleHeight < 20) Then
         lTitleHeight = 20
         OffsetRect m_rcTitle, 0, (20 - m_rcTitle.bottom - m_rcTitle.top) \ 2
      End If
   End If
   
   If (lWidth < m_lMinWidth) Then
      lWidth = m_lMinWidth
      lTextWidth = lWidth - 16
   End If
   
   '
   ' Evaluate the size of the text
   '
   m_rcText.left = 8
   m_rcText.right = m_rcText.left + lWidth - 16
   m_rcText.top = lTitleHeight + 4
   m_rcText.bottom = 512
   DrawText lhDC, m_sText, -1, m_rcText, DT_WORDBREAK Or DT_CALCRECT
   '
   
   m_lWidth = lWidth
   m_lHeight = m_rcText.top + m_rcText.bottom - m_rcText.top + 8 +
    m_lBubbleArrowSize
   
   pSetRegion
   '
End Sub
Private Sub pSetRegion()
   '
   
   Dim hRgnMain As Long
   hRgnMain = CreateRoundRectRgn(0, IIf(m_eShowDirection = etpShowAbove, 0,
    m_lBubbleArrowSize), m_lWidth, m_lHeight, 16, 16)
   Dim hRgnBubble As Long
   ReDim tP(0 To 2) As POINTAPI
   If (m_eShowDirection = etpShowAbove) Then
      tP(0).x = 32
      tP(0).y = m_lHeight - m_lBubbleArrowSize
      tP(1).x = 32 + m_lBubbleArrowSize
      tP(1).y = m_lHeight - m_lBubbleArrowSize
      tP(2).x = 32 + m_lBubbleArrowSize
      tP(2).y = m_lHeight
   Else
      tP(0).x = 32
      tP(0).y = 0
      tP(1).x = 32
      tP(1).y = m_lBubbleArrowSize
      tP(2).x = 32 + m_lBubbleArrowSize
      tP(2).y = m_lBubbleArrowSize
   End If
   hRgnBubble = CreatePolygonRgn(tP(0), 3, WINDING)
   Dim hRgn As Long
   Dim lR As Long
   hRgn = CreateRectRgn(0, 0, 0, 0)
   lR = CombineRgn(hRgn, hRgnMain, hRgnBubble, RGN_OR)
   If Not (m_hRgnFrame = 0) Then
      DeleteObject m_hRgnFrame
   End If
   m_hRgnFrame = CreateRectRgn(0, 0, 0, 0)
   lR = CombineRgn(m_hRgnFrame, hRgnMain, hRgnBubble, RGN_OR)
   DeleteObject hRgnMain
   DeleteObject hRgnBubble
   
   If Not (m_hWnd = 0) Then
      SetWindowRgn m_hWnd, hRgn, 0
   End If
   If (m_hRgn) Then
      DeleteObject m_hRgn
   End If
   m_hRgn = hRgn
   
   '
End Sub

Private Sub pShowPopup(ByVal x As Long, ByVal y As Long)
Dim rc As RECT
   
   pEvalSize
   ' Set the style of the object so it works as a popup:
   Dim lStyle As Long
   lStyle = GetWindowLong(m_hWnd, GWL_EXSTYLE)
   lStyle = lStyle Or WS_EX_TOOLWINDOW
   lStyle = lStyle And Not (WS_EX_APPWINDOW)
   SetWindowLong m_hWnd, GWL_EXSTYLE, lStyle
   SetParent m_hWnd, HWND_DESKTOP
   SetProp m_hWnd, MAGIC_END_EDIT_IGNORE_WINDOW_PROP, 1
   SetWindowPos m_hWnd, HWND_TOPMOST, x, y, m_lWidth, m_lHeight, SWP_SHOWWINDOW
   pPaint
   m_bShown = True
   If (m_lTimeOut > -1) Then
      tmrTimeOut.Tag = timeGetTime
      tmrTimeOut.Enabled = True
   End If
   
End Sub

Private Sub pHidePopup()
   If (m_bShown) Then
      ShowWindow m_hWnd, SW_HIDE
      RemoveProp m_hWnd, MAGIC_END_EDIT_IGNORE_WINDOW_PROP
      m_bShown = False
   End If
End Sub

Private Function TranslateColor(ByVal oClr As OLE_COLOR, _
                        Optional hPal As Long = 0) As Long
    ' Convert Automation color to Windows color
    If OleTranslateColor(oClr, hPal, TranslateColor) Then
        TranslateColor = CLR_INVALID
    End If
End Function


Private Property Get ObjectFromPtr(ByVal lPtr As Long) As Object
Dim objT As Object
   If Not (lPtr = 0) Then
      ' Turn the pointer into an illegal, uncounted interface
      CopyMemory objT, lPtr, 4
      ' Do NOT hit the End button here! You will crash!
      ' Assign to legal reference
      Set ObjectFromPtr = objT
      ' Still do NOT hit the End button here! You will still crash!
      ' Destroy the illegal reference
      CopyMemory objT, 0&, 4
   End If
End Property

Private Sub VerInitialise()
   
   Dim tOSV As OSVERSIONINFO
   tOSV.dwVersionInfoSize = Len(tOSV)
   GetVersionEx tOSV
   
   m_bIsNt = ((tOSV.dwPlatformId And VER_PLATFORM_WIN32_NT) =
    VER_PLATFORM_WIN32_NT)
   If (tOSV.dwMajorVersion > 5) Then
      'm_bHasGradientAndTransparency = True
      m_bIsXp = True
      'm_bIs2000OrAbove = True
   ElseIf (tOSV.dwMajorVersion = 5) Then
      'm_bHasGradientAndTransparency = True
      'm_bIs2000OrAbove = True
      If (tOSV.dwMinorVersion >= 1) Then
         m_bIsXp = True
      End If
   ElseIf (tOSV.dwMajorVersion = 4) Then ' NT4 or 9x/ME/SE
      'If (tOSV.dwMinorVersion >= 10) Then
      '   m_bHasGradientAndTransparency = True
      'End If
   Else ' Too old
   End If
   
End Sub

Private Sub DrawText( _
      ByVal lhDC As Long, _
      ByVal sText As String, _
      ByVal lLength As Long, _
      tR As RECT, _
      ByVal lFlags As Long _
   )
Dim lPtr As Long
   If (m_bIsNt) Then
      lPtr = StrPtr(sText)
      If Not (lPtr = 0) Then ' NT4 crashes with ptr = 0
         DrawTextW lhDC, lPtr, -1, tR, lFlags
      End If
   Else
      DrawTextA lhDC, sText, -1, tR, lFlags
   End If
End Sub

Private Sub pInitialise()
   
   m_bDesignTime = Not (UserControl.Ambient.UserMode)
   m_hWnd = UserControl.hWnd
   If (m_bDesignTime) Then
      pEvalSize
      pPaint
   Else
      UserControl.Extender.Visible = False
   End If
   
End Sub

Private Sub tmrTimeOut_Timer()
   '
Dim lT As Long
   If Len(tmrTimeOut.Tag) > 0 Then
      lT = CLng(tmrTimeOut.Tag)
      If (timeGetTime - lT > m_lTimeOut) Then
         RaiseEvent TimeOut
         pHidePopup
      End If
   Else
      tmrTimeOut.Enabled = False
   End If
   '
End Sub

Private Sub UserControl_Initialize()
   m_lTimeOut = -1
   m_eStandardIcon = etpNone
   VerInitialise
   m_lMinWidth = 128
   m_lBubbleArrowSize = 16
End Sub

Private Sub UserControl_InitProperties()
   '
   pInitialise
   '
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As
 Single, y As Single)
   '
   If (m_bShown) Then
      RaiseEvent Click
      pHidePopup
   End If
   '
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   '
   Title = PropBag.ReadProperty("Title", "")
   Text = PropBag.ReadProperty("Text", "")
   StandardIcon = PropBag.ReadProperty("StandardIcon", etpNone)
   TimeOut = PropBag.ReadProperty("TimeOut", -1)
   BackColor = PropBag.ReadProperty("BackColor", vbInfoBackground)
   ForeColor = PropBag.ReadProperty("ForeColor", vbInfoText)
   Dim sFnt As New StdFont
   sFnt.Name = "Tahoma"
   sFnt.Size = 8.25
   Font = PropBag.ReadProperty("Font", sFnt)
   ShowCloseButton = PropBag.ReadProperty("ShowCloseButton", False)
   
   pInitialise
   '
End Sub

Private Sub UserControl_Resize()
   '
   pPaint
   '
End Sub

Private Sub UserControl_Show()
   '
End Sub

Private Sub UserControl_Terminate()
   pHidePopup
   DeleteObject m_hRgnFrame
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
   '
   PropBag.WriteProperty "Title", Title, ""
   PropBag.WriteProperty "Text", Text, ""
   PropBag.WriteProperty "StandardIcon", StandardIcon, etpNone
   PropBag.WriteProperty "TimeOut", TimeOut, -1
   PropBag.WriteProperty "BackColor", BackColor, vbInfoBackground
   PropBag.WriteProperty "ForeColor", ForeColor, vbInfoText
   Dim sFnt As New StdFont
   sFnt.Name = "Tahoma"
   sFnt.Size = 8.25
   PropBag.WriteProperty "Font", Font, sFnt
   PropBag.WriteProperty "ShowCloseButton", ShowCloseButton, False
   '
End Sub