Programming Tool Box/SIMS_2.iso/code/design/mstips/dutip.bas

BASIC Source File | 1995-02-27 | 5KB | 211 lines

Option Explicit

'This module provides the generic tooltip routines.


Dim frmCurrForm As Form
Dim nCurr_hWnd As Integer

Const nTIP_TEXT_OFFSET_IN_PIXELS_X = 2
Const nTIP_TEXT_OFFSET_IN_PIXELS_Y = 18
Const nTIP_TIMER_LARGE_INTERNAL = 1000
Const nTIP_TIMER_SMALL_INTERNAL = 50
Const nTIP_MAX_WIDTH_IN_TWIPS = 2880  '2 inches
Const nlTIP_BACKCOLOR = &H80FFFF  'light yellow


Type typTipPointAPI
   nX As Integer
   nY As Integer
End Type

Const SW_SHOWNOACTIVATE = 4
Const GW_CHILD = 5

Declare Sub dutip_GetCursorPos Lib "User" Alias "GetCursorPos" (lpPoint As typTipPointAPI)
Declare Function dutip_nGetActiveWindow Lib "User" Alias "GetActiveWindow" () As Integer
Declare Function dutip_nWindowFromPoint Lib "User" Alias "WindowFromPoint" (ByVal lpPointY As Integer, ByVal lpPointX As Integer) As Integer
Declare Function dutip_nShowWindow Lib "User" Alias "ShowWindow" (ByVal hWnd As Integer, ByVal nCmdShow As Integer) As Integer
Declare Function dutip_nGetWindow Lib "User" Alias "GetWindow" (ByVal hWnd As Integer, ByVal wCmd As Integer) As Integer

Sub dutip_DisableTips ()

'Disable the tooltip timer, and unloads
'the tooltip form.


frmTip.tmrTip.Enabled = False

frmTip.Hide
Unload frmTip

Set frmTip = Nothing

End Sub

Sub dutip_EnableTips ()

'Load the tooltip form, customize colors.


Load frmTip

frmTip.Caption = ""
frmTip.BackColor = nlTIP_BACKCOLOR

frmTip.lblTip.BackColor = nlTIP_BACKCOLOR
frmTip.lblTip.AutoSize = True
frmTip.lblTip.Move Screen.TwipsPerPixelX * 2, Screen.TwipsPerPixelY * 1

frmTip.tmrTip.Enabled = False

End Sub

Sub dutip_PollTips ()

'Called from the _Timer event in DUTIP.FRM
'to periodically check the position of the mouse.


Dim nSub As Integer, tfControlHit As Integer
Dim nTemp_hWnd As Integer

Dim recPoint As typTipPointAPI


If dutip_nGetActiveWindow() = frmCurrForm.hWnd Then
   Call dutip_GetCursorPos(recPoint)

   nTemp_hWnd = dutip_nWindowFromPoint(recPoint.nY, recPoint.nX)

   If nTemp_hWnd <> nCurr_hWnd Then
      nCurr_hWnd = nTemp_hWnd


      tfControlHit = False

      On Error Resume Next

      For nSub = 0 To frmCurrForm.Controls.Count - 1
     nTemp_hWnd = frmCurrForm.Controls(nSub).hWnd

     If Err = 0 Then
        If nCurr_hWnd = nTemp_hWnd Then  'hit on primary window
           tfControlHit = True
        Else                             'check child windows
           If TypeOf frmCurrForm.Controls(nSub) Is ComboBox Then
          If nCurr_hWnd = dutip_nGetWindow(frmCurrForm.Controls(nSub).hWnd, GW_CHILD) Then
             tfControlHit = True
          End If
           Else
          'add checks here for other multi-window controls
           End If
        End If

        If tfControlHit Then  'popup the tooltip
           Call dutip_ShowTip(frmCurrForm.Controls(nSub), recPoint)

           Exit For
        End If
     Else
        Err = 0
     End If
      Next

      On Error GoTo 0

      If tfControlHit Then
     frmTip.tmrTip.Interval = nTIP_TIMER_SMALL_INTERNAL
      Else
     If nCurr_hWnd <> frmTip.hWnd Then
        frmTip.tmrTip.Interval = nTIP_TIMER_LARGE_INTERNAL
     End If

     frmTip.Hide
      End If
   End If
End If

End Sub

Sub dutip_SetTipForm (frmForm As Form)

'Identifies the form to monitor, and enables
'the timer.


Set frmCurrForm = frmForm
nCurr_hWnd = 0

frmTip.tmrTip.Enabled = False
frmTip.tmrTip.Interval = nTIP_TIMER_LARGE_INTERNAL
frmTip.tmrTip.Enabled = True

End Sub

Sub dutip_ShowTip (ctlControl As Control, recPoint As typTipPointAPI)

'Sizes and positions the tooltip, according to the
'length of the text and the location of the mouse.


Dim nRC As Integer
Dim fLeft As Single, fTop As Single
Dim fWidth As Single, fHeight As Single
Dim sTipText As String


sTipText = ToolTips_sGetTipText(ctlControl, recPoint.nX, recPoint.nY)
      'This callback function lives
      'in *your* application code,
      'not in this module.

frmTip.Hide

If Len(sTipText) > 0 Then
   frmTip.lblTip.WordWrap = False
   frmTip.lblTip.Caption = sTipText

   'Set the tooltip width

   If frmTip.lblTip.Width > nTIP_MAX_WIDTH_IN_TWIPS Then
      frmTip.lblTip.WordWrap = True
      frmTip.lblTip.Width = nTIP_MAX_WIDTH_IN_TWIPS
   Else
      If frmTip.lblTip.Width > (nTIP_MAX_WIDTH_IN_TWIPS \ 2) Then
     frmTip.lblTip.WordWrap = True
     frmTip.lblTip.Width = (nTIP_MAX_WIDTH_IN_TWIPS \ 2)
      End If
   End If

   'Calculate where to popup the tooltip,
   'relative to the mouse

   fLeft = (recPoint.nX - nTIP_TEXT_OFFSET_IN_PIXELS_X) * Screen.TwipsPerPixelX
   fTop = (recPoint.nY + nTIP_TEXT_OFFSET_IN_PIXELS_Y) * Screen.TwipsPerPixelY
   fWidth = (Screen.TwipsPerPixelX * 6) + frmTip.lblTip.Width
   fHeight = (Screen.TwipsPerPixelY * 4) + frmTip.lblTip.Height

   'Make adjustments so the tooltip isn't
   'clipped by the edge of the screen

   If (fLeft + fWidth) > Screen.Width Then
      fLeft = fLeft - fWidth - (nTIP_TEXT_OFFSET_IN_PIXELS_X * Screen.TwipsPerPixelX)
   End If
   If (fTop + fHeight) > Screen.Height Then
      fTop = fTop - fHeight - (nTIP_TEXT_OFFSET_IN_PIXELS_Y * Screen.TwipsPerPixelY)
   End If

   'Position the tooltip

   frmTip.Move fLeft, fTop, fWidth, fHeight
   frmTip.ZOrder

   'Pop it up, without focus

   nRC = dutip_nShowWindow(frmTip.hWnd, SW_SHOWNOACTIVATE)
End If

End Sub