Popup form as a control tip

[jw5107]

I am missing around with some code that microsoft has provided. Its code for a custom "tool-tip", that pops up when the mouse hovers over a control..
This code appears to only allow predetermined text enter as the tool-tip or a field value of what fields or text boxes that are on the form. What I'm wanting is for the tool-tip to be data from another table matching the name or caption of the control the mouse is hovered over... Is this possible?? Any suggestions or ideas...?
Thanks in advance,
jw5107

 

[traingamer]

In the 'on load' event or 'on current' event, (depending on your needs) you could assign any value you want to the tooltip property of your form.

me.[your control name].ControlTipText = "What ever you want to say".

Greg
"Personally, I am always ready to learn, although I do not always like being taught." - Winston Churchill

 

[jw5107]

Traingamer,

Right...!! I got ya there... But I am wanting to use a form as the "Control Tip". The user would hover over a label, then a form would pop-up, show data based on the labels caption or name. What I have is a map on a form. Labels as the airport identifiers. So when the cursor hovers over one of the label, a form would pop-up - showing that airports flight activity, the city name, how many aircraft, etc....
Any other suggestions...?
Thanks for your help..!!
jw5107

 

[ThomasLafferty]

This could be quite problematic!

It might be possible to develop a popup form to which you assign a data source on the mouseover event. My gut feeling tells me you would have to have a timer event associated with the popup form to close it after a few seconds so that it didn't take away control from the form you were pointing at. Here's the rub: you may want to supress records if you have more than one row returned.

This is an interesting idea, and I may just lurk to see what others say.

Tom

Born once die twice; born twice die once.

 

[ChanceD2]

What is the exact question:
How do you create a mouse-over event?
How I am sure that the popup form has the correct data (via the SQL where statement)?

I'm not sure where the question is.

C-D2

 

[Remou]

Ok, I think I might have a partial answer. You will need two forms and some code from Dev ashish on the MVPS site. The two forms are frmLabels and frmInfo, frmInfo is set up as a dialog form. The info form is popping up but I have not got the positioning quite right. The box has to pop-up away from the mouse pointer, or there is trouble.

http://www.mvps.org/access/forms/frm0042.htm

Code for form with labels:

Private Sub Form_Open(Cancel As Integer)
  DoCmd.OpenForm "frmInfo", , , , , acHidden
End Sub

Private Sub Label0_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  GetInfo Me.Label0.Caption, Me.Label0.Left, Me.Label0.Top
End Sub

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  GetInfo Me.Label1.Caption, Me.Label1.Left, Me.Label1.Top
End Sub

Sub GetInfo(Airport, lngLeft, lngTop)
  Dim rs As DAO.Recordset

  Set rs = CurrentDb.OpenRecordset("Select Info from tblInfo Where Airport='" & Airport & "'")
  Forms!frmInfo.txtInfo = rs!Info
  rs.Close

  Forms!frmInfo.Visible = True
  Forms!frmInfo.SetFocus

  AlignTops Forms!frmInfo, Forms!frmLabels, lngLeft, lngTop

End Sub

Public Sub AlignTops(ByRef frmA As Form, ByRef frmB As Form, lngLeft, lngTop)

  Dim fwA As New clFormWindow, fwB As New clFormWindow
  fwA.hWnd = frmA.hWnd
  fwB.hWnd = frmB.hWnd
  
  fwA.Left = fwB.Left + (lngLeft / 11.75)
  fwA.Top = fwB.Top + (lngTop / 11.75)
 
  Set fwA = Nothing
  Set fwB = Nothing
End Sub

Code for pop-up

Private Sub Form_GotFocus()
  Me.Visible = False
End Sub

Private Sub txtInfo_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Me.Visible = False
End Sub

 

[Remou]

Here are the corrected window positions:

[tt]fwA.Left = fwB.Left + (lngLeft / 14.475)
fwA.Top = fwB.Top + ((lngTop + lngHeight) / 15.45) + 40[/tt]

Where lngHeight is the height of the label.

 

[TheAceMan1]

How are ya jw5107 . . .

I agree with [blue]ThomasLafferty[/blue] . . . although this is an interesting idea . . . my prowess tells me it [blue]won't be done without great diffculty[/blue] for the follwing major reaon:

[blue]The [purple]ControlTipText[/purple] property is a [purple]display function[/purple] and [purple]can't be set to open a form! . . .[/purple][/blue]

You could try to simulate using the [blue]OnMouseMove[/blue] event . . . but this creates [blue]multiple triggers[/blue] . . . an unsatisfactory condition for what you wish to accomplish . . .

[blue]Your Thoughts! . . .[/blue]

See Ya! . . . . . .

 

[Remou]

It seems to me that you could use the Mouse Move of the main form, rather than multiple triggers. This needs more work:

Private Sub Detail_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
For Each ctl In Me.Controls
    If Left(ctl.Name, 5) = "Label" Then
        If (ctl.Left < X + 60 And ctl.Left + ctl.Width > X - 60) And _
            (ctl.Top < Y + 60 And ctl.Top > Y - 60) Then
            GetInfo ctl.Caption, ctl.Left, ctl.Top, ctl.Height
        End If
    End If
Next
End Sub

 

[earthandfire]

Unless I've misunderstood, there seems to be a much easier solution


Add the ToolTip form to the main form as a SubForm and set it as Visible = False

To test this I've created a small table that has Airport IDs and Names and another table that has Flight IDs, StartAirport and Time and EndAirport and Time.

In a Module I have:

Option Compare Database
Option Explicit

Public TheAirport As String

Public Function GetAirport() As String

  GetAirport = TheAirport

End Function

this simplifies the query for the SubForm

The main form has a number of Labels and various locations to represent the map, the Caption of each is an AirportName.

The query to extract the flight details is:

SELECT Flights.FlightID, Airports.AirportName AS FromAirport, Airports_1.AirportName AS ToAirport, Flights.StartTime, Flights.EndTime
FROM (Flights INNER JOIN Airports ON Flights.AirportFromID = Airports.AirportID) INNER JOIN Airports AS Airports_1 ON Flights.AirportToID = Airports_1.AirportID
WHERE (((Airports.AirportName)=GetAirport())) OR (((Airports_1.AirportName)=GetAirport()));

In this quick test I've set each label's MouseMove event separately (but Remou has shown how that can be simplified)

Option Compare Database
Option Explicit

Private Const LeftOffset As Single = 100
Private Const TopOffset As Single = 50

Private Sub OpenFormFlights(lbl As Label)

  If TheAirport = lbl.Caption Then
    Exit Sub
  Else
    TheAirport = lbl.Caption
    Child5.Top = lbl.Top + lbl.Height + lbl.BorderWidth + TopOffset
    Child5.Left = lbl.Left + LeftOffset
    Child5.Form.Requery
    Child5.Visible = True
  End If

End Sub

Private Sub Detail_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

  TheAirport = ""
  Text7.SetFocus
  If Child5.Visible Then Child5.Visible = False

End Sub

Private Sub Label0_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

  OpenFormFlights Label0

End Sub

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

  OpenFormFlights Label1

End Sub

Private Sub Label2_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

  OpenFormFlights Label2

End Sub

Private Sub Label3_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

  OpenFormFlights Label3

End Sub

Private Sub Label4_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

  OpenFormFlights Label4

End Sub

This handles automatically positioning, displaying, hiding and filtering of the flight information

By the way, I've had to add a superfluous control Text7 to hold the focus on the main form. This is because Labels can't receive the focus and if a user clicks into the SubForm (maybe to scroll it), it wouldn't otherwise be possible to hide it. Hopefully you have a suitable control to hold or take the focus.

Hope this helps.

 

[TheAceMan1]

To All . . .

[blue][purple]The MouseMove event is generated continually as the mouse pointer moves over objects.[/purple] Unless another object generates a mouse event, an object recognizes a MouseMove event whenever the mouse pointer is positioned within its borders.[/blue]

[blue]This is the reason for multipe triggers![/blue]

See Ya! . . . . . .

 

[earthandfire]

But the effects can be nullified as in my example.


Hope this helps.

 

[jw5107]

To All:
Ok - hopefully this will make some sense.. I module "modToolTipsForm" from:

http://support.microsoft.com/default.aspx?scid=kb;en-us;119991

The load event on the main form (shown below) is where it calls the popup form "frmToolTipDataSheet".
The only functions are:
Private Sub Form_Timer()
ShowToolTips Me
End Sub
Private Sub txtToolTip_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
HideToolTips
End Sub
On the main form Load and Unload events...
the line where it states "SetToolText" is the only place it to "pre-type" the tool tip... I would to get rid of this to show a the form with the aiport info based on the caption name of the control....
Private Sub Form_Load()
' Create an instance of our Tooltip class
Set TTip = New clsToolTip
' We must SetFocus to any control that can
' accept the focus in order to force Access to
' create the inplace editing Window.
Me!ParkCsr.SetFocus
With TTip
' Creat the tooltip window
Call .Create(Me)
' Set the tooltip window to show for 5 secs
.DelayTime = 5000
.SetToolTipTitle " GTWY Profile", 0
' ToolTip text colors
.ForeColor = vbBlue
.BackColor = RGB(192, 192, 192)
' Set the text for the txtCustomerID label.
.SetToolText Me.ANC1, "I am the ANC Label." & vbCrLf & "This is the second line!"
.SetToolText Me.SDF1, "I am the SDF Label." & vbCrLf & "This is the second line!"
.SetToolText Me.ONT1, "I am the ONT Label." & vbCrLf & "This is the second line!"
.SetToolText Me.DFW1, "I am the DFW Label." & vbCrLf & "This is the second line!"
.SetToolText Me.MIA1, "I am the MIA Label." & vbCrLf & "This is the second line!"
End With
End Sub
Private Sub Form_Unload(Cancel As Integer)
' Because of reference issues you must invoke
' the Cleanup sub prior to releasing the
' reference to the TTip class.
TTip.Cleanup
' Release our reference to our class
Set TTip = Nothing
End Sub
From the Class Module "clsToolTip""
Option Compare Database
Option Explicit

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 Type TOOLINFO
cbSize As Long
uFlags As Long
hWnd As Long
uId As Long
RECT As RECT
hinst As Long
lpszText As String
lParam As Long
End Type

Private Type SCROLLINFO
cbSize As Long
fMask As Long
nMin As Long
nMax As Long
nPage As Long
nPos As Long
nTrackPos As Long
End Type

Private Declare Function apiGetScrollInfo _
Lib "user32" Alias "GetScrollInfo" (ByVal hWnd As Long, _
ByVal n As Long, lpScrollInfo As SCROLLINFO) As Long

Private Declare Function GetWindowRect Lib "user32" _
(ByVal hWnd As Long, lpRect As RECT) As Long

Private Declare Function ClientToScreen Lib "user32" _
(ByVal hWnd As Long, lpPoint As POINTAPI) As Long

Private Declare Function ScreenToClient Lib "user32" _
(ByVal hWnd As Long, lpPoint As POINTAPI) As Long



Private Declare Function apiGetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long) As Long

Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function apiGetDeviceCaps Lib "gdi32" _
Alias "GetDeviceCaps" (ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Declare Function ReleaseDC Lib "user32" _
(ByVal hWnd As Long, ByVal hDC As Long) As Long

Private Declare Sub InitCommonControls Lib "comctl32.dll" ()

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 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 apiGetWindow Lib "user32" _
Alias "GetWindow" _
(ByVal hWnd As Long, _
ByVal wCmd As Long) _
As Long

Private Declare Function apiGetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hWnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) _
As Long


Private Const TOOLTIPS_CLASS = "tooltips_class32"

'Private Enum TT_DelayTime
Private Const TTDT_AUTOMATIC = 0
Private Const TTDT_RESHOW = 1
Private Const TTDT_AUTOPOP = 2
Private Const TTDT_INITIAL = 3

'Private Enum ttDelayTimeConstants
Private Const ttDelayDefault = TTDT_AUTOMATIC '= 0
Private Const ttDelayInitial = TTDT_INITIAL '= 3
Private Const ttDelayShow = TTDT_AUTOPOP '= 2
Private Const ttDelayReshow = TTDT_RESHOW '= 1
Private Const ttDelayMask = 3

'Private Enum ttMarginConstants
Private Const ttMarginLeft = 0
Private Const ttMarginTop = 1
Private Const ttMarginRight = 2
Private Const ttMarginBottom = 3
Private Const TTS_ALWAYSTIP = &H1
Private Const TTS_NOPREFIX = &H2
Private Const TTS_BALLOON = &H40
'Private Enum TT_Flags
Private Const TTF_IDISHWND = &H1
Private Const TTF_CENTERTIP = &H2
Private Const TTF_RTLREADING = &H4
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 = &H8000&
'* Private Window Messages Start Here:
Private Const WM_USER = &H400&
'Private Enum TT_Msgs
Private Const TTM_ACTIVATE = (WM_USER + 1)
Private Const TTM_SETDELAYTIME = (WM_USER + 3)
Private Const TTM_RELAYEVENT = (WM_USER + 7)
Private Const TTM_GETTOOLCOUNT = (WM_USER + 13)
Private Const TTM_WINDOWFROMPOINT = (WM_USER + 16)
Private Const TTM_ADDTOOL = (WM_USER + 4)
Private Const TTM_DELTOOL = (WM_USER + 5)
Private Const TTM_NEWTOOLRECT = (WM_USER + 6)
Private Const TTM_GETTOOLINFO = (WM_USER + 8)
Private Const TTM_SETTOOLINFO = (WM_USER + 9)
Private Const TTM_HITTEST = (WM_USER + 10)
Private Const TTM_GETTEXT = (WM_USER + 11)
Private Const TTM_UPDATETIPTEXT = (WM_USER + 12)
Private Const TTM_ENUMTOOLS = (WM_USER + 14)
Private Const TTM_GETCURRENTTOOL = (WM_USER + 15)
Private Const TTM_TRACKACTIVATE = (WM_USER + 17)
Private Const TTM_TRACKPOSITION = (WM_USER + 18)
Private Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
Private Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
Private Const TTM_GETDELAYTIME = (WM_USER + 21)
Private Const TTM_GETTIPBKCOLOR = (WM_USER + 22)
Private Const TTM_GETTIPTEXTCOLOR = (WM_USER + 23)
Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
Private Const TTM_GETMAXTIPWIDTH = (WM_USER + 25)
Private Const TTM_SETMARGIN = (WM_USER + 26)
Private Const TTM_GETMARGIN = (WM_USER + 27)
Private Const TTM_POP = (WM_USER + 28)
Private Const TTM_UPDATE = (WM_USER + 29)
Private Const TTM_SETTITLE = (WM_USER + 32) '// wParam = TTI_*, lParam = char* szTitle


'Private Enum TT_Notifications
Private Const TTN_FIRST = -520& ' (0U-520U)
Private Const TTN_LAST = -549& ' (0U-549U)
Private Const TTN_NEEDTEXT = (TTN_FIRST - 0)
Private Const TTN_SHOW = (TTN_FIRST - 1)
Private Const TTN_POP = (TTN_FIRST - 2)

'// ToolTip Icons (Set with TTM_SETTITLE)
Private Const TTI_NONE = 0
Private Const TTI_INFO = 1
Private Const TTI_WARNING = 2
Private Const TTI_ERROR = 3

' GetWindow() Constants
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDLAST = 1
Private Const GW_HWNDNEXT = 2
Private Const GW_HWNDPREV = 3
Private Const GW_OWNER = 4
Private Const GW_CHILD = 5
Private Const GW_MAX = 5

' ScrollInfo fMask's
Private Const SIF_RANGE = &H1
Private Const SIF_PAGE = &H2
Private Const SIF_POS = &H4
Private Const SIF_DISABLENOSCROLL = &H8
Private Const SIF_TRACKPOS = &H10
Private Const SIF_ALL = (SIF_RANGE Or SIF_PAGE Or SIF_POS Or SIF_TRACKPOS)

' Scroll Bar Constants
Private Const SB_HORZ = 0
Private Const SB_CTL = 2
Private Const SB_VERT = 1

' App instance
Private Const GWL_HINSTANCE = (-6)
' Twips per inch
Private Const TWIPSPERINCH = 1440&

' Device Parameters for GetDeviceCaps()
Private Const LOGPIXELSX = 88 ' Logical pixels/inch in X
Private Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
Private Const BITSPIXEL = 12 ' Number of bits per pixel

' WIndow handle to our Tooltip control
Private m_hwndTT As Long

' Window handle to our Form's Detail Section
Private m_hWndDetail As Long

' Window handle to our Detail Section's
' in place editing control. Access activates and
' resizes this window whenever an editing
' control receives the focus.
Private m_hWndOKttbx As Long

' The Form containing the controls
Private m_Form As Form

' Max length of Tooltip
Private m_cMaxTip As Long
' Instance of our App
Private hInstance As Long

' Horizontal and Vertical Screen resolution
Private m_ScreenXdpi As Long
Private m_ScreenYdpi As Long

' Collection for our control classes
Private colControls As New Collection

' Our TextBox class
Private cTBox As clsTextBox

' Our Combo class
Private cCBO As clsCombo

' Our ListBox class
Private cLB As clsListBox

' Junk return vars
Private lngRet As Long
Private blRet As Boolean
Public Function Create(frm As Form) As Boolean

' Grab a reference to the Form
Set m_Form = frm

If (m_hwndTT = 0) Then
Call InitCommonControls

' Get instance of this App
hInstance = apiGetWindowLong(Application.hWndAccessApp, GWL_HINSTANCE)


' Filling the hwndParent param below allows the tooltip window to
' be owned by the specified form and be destroyed along with it,
' but we'll cleanup in Class_Terminate anyway.
' Turn off Balloon if prior to Explorer 5.0
m_hwndTT = CreateWindowEx(0, TOOLTIPS_CLASS, _
vbNullString, TTS_ALWAYSTIP Or TTS_BALLOON, _
0, 0, _
0, 0, _
m_Form.hWnd, 0, _
hInstance, ByVal 0)
End If


' Grab our Detail Section Window handle
m_hWndDetail = FindDetailWindow(m_Form.hWnd)
' Grab our Detail Section's inplace editing window
m_hWndOKttbx = FindOKttbxWindow(m_hWndDetail)


' Set the tooltip's width so that it displays multiline text,
' and that no tool's line length exceeds roughly 240 pixels.
MaxTipWidth = 240


' Now setup a ToolTip entry for every control in the Form.
Dim ctrl As Control

For Each ctrl In m_Form.Controls
Select Case ctrl.ControlType

Case acTextBox
Set cTBox = New clsTextBox
Set cTBox.FormControl = ctrl
Set cTBox.ToolTip = Me
colControls.Add cTBox, ctrl.Name
Set cTBox = Nothing

Case acComboBox
Set cCBO = New clsCombo
Set cCBO.FormControl = ctrl
Set cCBO.ToolTip = Me
colControls.Add cCBO, ctrl.Name
Set cCBO = Nothing

Case acListBox
Set cLB = New clsListBox
Set cLB.FormControl = ctrl
Set cLB.ToolTip = Me
Let cLB.hWndLB = fFindListBoxhWnd(ctrl)
colControls.Add cLB, ctrl.Name
Set cLB = Nothing

Case Else
End Select

Next ctrl

' Now add a ToolTip for every control on the Form
For Each ctrl In m_Form.Controls
Select Case ctrl.ControlType
Case acListBox
AddToolLightWeight colControls(ctrl.Name).hWndLB

Case Else
AddTool ctrl

End Select
Next
' Add a ToolTip for the Detail Section's inplace Editing window
AddToolLightWeight m_hWndOKttbx

' Return
Create = CBool(m_hwndTT)

End Function


Public Function AddTool(ctrl As Control, Optional sText As String) As Boolean
Dim ti As TOOLINFO
Dim lHeight As Long
' Allow for Form Header if visible
' and this control does not reside in the Header!
' Remember if the Form Header section does not exist
' then we will generate a runtime error therefore me MUST:
On Error Resume Next

' Reset temp var
lHeight = 0

' Do we have a valid handle to the ToolTip window
If (m_hwndTT = 0) Then Exit Function

If (GetToolInfo(ctrl, ti) = False) Then
With ti
.cbSize = Len(ti)
' We do not use the TTF_IDISHWND Flag because we are specifying
' rectangular areas of the Window. We have to do this because
' on an Access Form, the TextBox and Label controls are
' "lightweight". They do not exist as seperate Windows. Access uses
' one common shared editing window that it activates as you set the focus to
' each control.
.uFlags = TTF_SUBCLASS
.hWnd = m_Form.hWnd
' On failure use Form's WIndow
'If .hWnd = 0 Then .hWnd = frm.hWnd

' We need a method of identifying each control's rectangular area.
' Normally you could simply fill in the hWnd for the control
' but since we are working with lightweight, non window'd controls
' we require another method. We will assume that no two controls
' will have the exact same Left and Top properties. I realize that this will
' fail for identical controls stacked on top of each other
' but you have been warned!!!
' So we create a unique uId member by putting the control's Left prop
' in the High word and the Top prop in the Lo word.
.uId = MakeDWord(CInt(ctrl.Top), CInt(ctrl.Left))

If Len(sText) Then
.lpszText = sText
Else
.lpszText = ""
End If

' Maintain the maximun tip text length for GetToolInfo
m_cMaxTip = Max(m_cMaxTip, Len(.lpszText) + 1)


' Fill in our bounding rectangle for this control.
' Does not matter which section the control is in as
' we have to add the offsets of the control in this particular section
.RECT.Left = (ctrl.Left / TWIPSPERINCH) * m_ScreenXdpi
.RECT.Right = ((ctrl.Left + ctrl.Width) / TWIPSPERINCH) * m_ScreenXdpi
.RECT.Top = (ctrl.Top / TWIPSPERINCH) * m_ScreenYdpi
.RECT.Bottom = ((ctrl.Top + ctrl.Height) / TWIPSPERINCH) * m_ScreenYdpi

' Allow for Form Header if visible
' and this control does not reside in the Header!
' Remember if the Form Header section does not exist
' then we will generate a runtime error
If m_Form.Section(acHeader).Visible = True Then
If ctrl.Section <> acHeader Then

.RECT.Top = .RECT.Top + (m_Form.Section(acHeader).Height / TWIPSPERINCH) * m_ScreenYdpi
.RECT.Bottom = .RECT.Bottom + ((m_Form.Section(acHeader).Height) / TWIPSPERINCH) * m_ScreenYdpi
End If
End If


' Are we in Form Footer?
If ctrl.Section = acFooter Then
' Add Detail Section Height
If m_Form.Section(acDetail).Visible = True Then
' We have to add the Height of not just the Detail Section
' But the InsideHeight - (acHeader + acFooter) the Form
' This method allows for when the Form is taller than the
' combined Section Heights.
' Grab Header Height
If m_Form.Section(acHeader).Visible = True Then
lHeight = m_Form.Section(acHeader).Height
End If

' Add Footer height
If m_Form.Section(acFooter).Visible = True Then
lHeight = lHeight + m_Form.Section(acFooter).Height
End If

' Calculate true Detail section height
lHeight = m_Form.InsideHeight - lHeight
.RECT.Top = .RECT.Top + (lHeight / TWIPSPERINCH) * m_ScreenYdpi
.RECT.Bottom = .RECT.Bottom + (lHeight / TWIPSPERINCH) * m_ScreenYdpi
End If

End If

End With

' Returns 1 on success, 0 on failure
AddTool = SendMessage(m_hwndTT, TTM_ADDTOOL, 0, ti)

End If

End Function


Public Function AddToolLightWeight(hWnd As Long, Optional sText As String = "") As Boolean
Dim ti As TOOLINFO
Dim ctrl As Control

' Do we have a valid handle to the ToolTip window
If (m_hwndTT = 0) Then Exit Function

If (GetToolInfo(ctrl, ti, hWnd) = False) Then
With ti
.cbSize = Len(ti)
' This is the shared TextBox window Access activates for in place editing
' as we activate each lightweight editing control
.uFlags = TTF_SUBCLASS Or TTF_IDISHWND
.hWnd = hWnd
' On failure use Form's WIndow
'If .hWnd = 0 Then .hWnd = frm.hWnd

' We use the Window Handle to identify this ToolTip.
.uId = .hWnd
If Len(sText) Then
.lpszText = sText
Else
.lpszText = ""
End If

' Maintain the maximun tip text length for GetToolInfo
m_cMaxTip = Max(m_cMaxTip, Len(.lpszText) + 1)
End With

' Returns 1 on success, 0 on failure
AddToolLightWeight = SendMessage(m_hwndTT, TTM_ADDTOOL, 0, ti)

End If

End Function

Public Function RemoveTool(ctrl As Control, Optional hWnd As Long = 0) As Boolean
Dim ti As TOOLINFO

' Do we have a valid handle to the ToolTip window
If (m_hwndTT = 0) Then Exit Function

If GetToolInfo(ctrl, ti, hWnd) Then
Call SendMessage(m_hwndTT, TTM_DELTOOL, 0, ti) ' no rtn val
RemoveTool = True
End If

End Function

' public properties
Public Property Get BackColor() As Long
If (m_hwndTT = 0) Then Exit Property
BackColor = SendMessage(m_hwndTT, TTM_GETTIPBKCOLOR, 0, 0)
End Property

Public Property Let BackColor(clr As Long)
If (m_hwndTT = 0) Then Exit Property
Call SendMessage(m_hwndTT, TTM_SETTIPBKCOLOR, clr, 0) ' no rtn val
End Property

Public Property Get DelayTime() As Long
If (m_hwndTT = 0) Then Exit Property
DelayTime = SendMessage(m_hwndTT, TTM_GETDELAYTIME, (ttDelayShow And ttDelayMask), 0&)
End Property

Public Property Let DelayTime(dwMilliSecs As Long)
If (m_hwndTT = 0) Then Exit Property
Call SendMessage(m_hwndTT, TTM_SETDELAYTIME, (ttDelayShow And ttDelayMask), ByVal dwMilliSecs)
End Property

Public Property Get ForeColor() As Long
If (m_hwndTT = 0) Then Exit Property
ForeColor = SendMessage(m_hwndTT, TTM_SETTIPTEXTCOLOR, 0, 0)
End Property

Public Property Let ForeColor(clr As Long)
If (m_hwndTT = 0) Then Exit Property
Call SendMessage(m_hwndTT, TTM_SETTIPTEXTCOLOR, clr, 0) ' no rtn val
End Property

Public Property Get ScreenXdpi() As Long
ScreenXdpi = m_ScreenXdpi
End Property

Public Property Get ScreenYdpi() As Long
ScreenYdpi = m_ScreenYdpi
End Property

Public Property Get hWnd() As Long ' read-only
hWnd = m_hwndTT
End Property

Public Property Get hWndOKttbx() As Long ' read-only
hWndOKttbx = m_hWndOKttbx
End Property

Public Property Get Margin(dwType As Long) As Long
Dim rc As RECT
' Do we have a valid handle to the ToolTip window
If (m_hwndTT = 0) Then Exit Property

Call SendMessage(m_hwndTT, TTM_GETMARGIN, 0, rc) ' no rtn val
Select Case dwType
Case ttMarginLeft: Margin = rc.Left
Case ttMarginTop: Margin = rc.Top
Case ttMarginRight: Margin = rc.Right
Case ttMarginBottom: Margin = rc.Bottom
End Select

End Property

Public Property Let Margin(dwType As Long, cPixels As Long)
Dim rc As RECT
' Do we have a valid handle to the ToolTip window
If (m_hwndTT = 0) Then Exit Property

Call SendMessage(m_hwndTT, TTM_GETMARGIN, 0, rc) ' no rtn val
Select Case dwType
Case ttMarginLeft: rc.Left = cPixels
Case ttMarginTop: rc.Top = cPixels
Case ttMarginRight: rc.Right = cPixels
Case ttMarginBottom: rc.Bottom = cPixels
End Select
Call SendMessage(m_hwndTT, TTM_SETMARGIN, 0, rc) ' no rtn val

End Property

' If MaxTipWidth is -1, there's no word wrapping and text controls chars
' in lpszText are printed and not evaluated (i.e. a vbCrLf shows up as "||")

Public Property Get MaxTipWidth() As Integer
If (m_hwndTT = 0) Then Exit Property
MaxTipWidth = LoWord(SendMessage(m_hwndTT, TTM_GETMAXTIPWIDTH, 0, 0))
End Property

Public Property Let MaxTipWidth(ByVal cx As Integer)
If (m_hwndTT = 0) Then Exit Property
If (cx < 1) Then cx = -1
Call SendMessage(m_hwndTT, TTM_SETMAXTIPWIDTH, 0, ByVal CLng(cx))
End Property

Public Property Get ToolCount() As Integer ' read-only
If (m_hwndTT = 0) Then Exit Property
ToolCount = SendMessage(m_hwndTT, TTM_GETTOOLCOUNT, 0, 0)
End Property

' For the life of me I couldn't get TTM_GETTEXT to work. So
' we'll use the TTM_ENUMTOOLS message in GetToolInfo
' instead, which does retrieve the specifed tool's text... (?)

Public Property Get ToolText(ctrl As Control, Optional hWnd As Long = 0) As String
Dim ti As TOOLINFO

' Do we have a valid handle to the ToolTip window
If (m_hwndTT = 0) Then Exit Property

If GetToolInfo(ctrl, ti, hWnd, True) Then
ToolText = GetStrFromBufferA(ti.lpszText)
End If

End Property

Public Sub SetToolText(ctrl As Control, sText As String, Optional ByVal hWnd As Long = 0)
Dim ti As TOOLINFO

' Do we have a valid handle to the ToolTip window
If (m_hwndTT = 0) Then Exit Sub

' Is control a ListBox?
If ctrl.ControlType = acListBox Then
hWnd = colControls(ctrl.Name).hWndLB
End If

If GetToolInfo(ctrl, ti, hWnd) Then
ti.lpszText = sText
m_cMaxTip = Max(m_cMaxTip, Len(sText) + 1)
' The tooltip won't appear for the control if lpszText is an empty string
Call SendMessage(m_hwndTT, TTM_UPDATETIPTEXT, 0, ti) ' no rtn val
End If

' Update our private control collection
' We need to extend this to handle List, Combo, OLE Frame controls etc.
' Any other controls that can have the focus.
Select Case ctrl.ControlType
Case acTextBox, acComboBox, acListBox
colControls(ctrl.Name).ToolTipText = sText

'Case ????
' Will add support for the rest of the
' window'd controls in the next release

Case Else
End Select

End Sub

Public Sub SetToolTipTitle(ByVal sText As String, ByVal IcType As Long)
If Len(sText & vbNullString) = 0 Then Exit Sub
lngRet = SendMessage(m_hwndTT, TTM_SETTITLE, IcType, ByVal sText)
End Sub


Private Function GetToolInfo(ctrl As Control, _
ti As TOOLINFO, _
Optional ByVal hWnd As Long = 0, _
Optional fGetText As Boolean = False) As Boolean
Dim nItems As Integer
Dim i As Integer
Dim intLeft As Integer
Dim intTop As Integer

ti.cbSize = Len(ti)
If fGetText Then ti.lpszText = String$(m_cMaxTip, 0)

nItems = ToolCount

For i = 0 To nItems - 1
' call returns 1 on success, 0 on failure...
If SendMessage(m_hwndTT, TTM_ENUMTOOLS, (i), ti) Then
' Check and see if we are requesting our only
' Tooltip that is an actual hWnd not a lighweight control.
If hWnd <> 0 Then
If hWnd = ti.uId Then
GetToolInfo = True
Exit Function
End If
End If

If hWnd = 0 Then
' All other Tooltips are lightweight controls with no hWnd.
' break out uId into its 2 composite values
' that are the control's Left and Top properties.
' We created the value in this uId member by putting the Left prop in
' the High word and the Top prop in the Lo word.
intTop = LoWord(ti.uId)
intLeft = HiWord(ti.uId)
If ctrl.Left = intLeft Then
If ctrl.Top = intTop Then
GetToolInfo = True
Exit Function
End If
End If
End If
End If
Next

End Function

Private Sub GetScreenDPI()
Dim lngDC As Long
Dim lngPixelsPerInch As Long
Const nTwipsPerInch = 1440

lngDC = GetDC(0)

'Horizontal
m_ScreenXdpi = apiGetDeviceCaps(lngDC, LOGPIXELSX)
'Vertical
m_ScreenYdpi = apiGetDeviceCaps(lngDC, LOGPIXELSY)

lngDC = ReleaseDC(0, lngDC)
End Sub

Private Function LoWord(ByVal DWord As Long) As Integer
If DWord And &H8000& Then ' &H8000& = &H00008000
LoWord = DWord Or &HFFFF0000
Else
LoWord = DWord And &HFFFF&
End If
End Function

Private Function HiWord(ByVal DWord As Long) As Integer
HiWord = (DWord And &HFFFF0000) \ &H10000
End Function

Private Function MakeDWord(LoWord As Integer, HiWord As Integer) As Long
MakeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&)
End Function

Public Function Max(param1 As Long, param2 As Long) As Long
If param1 > param2 Then Max = param1 Else Max = param2
End Function

Public Function GetStrFromBufferA(szA As String) As String
If InStr(szA, vbNullChar) Then
GetStrFromBufferA = Left$(szA, InStr(szA, vbNullChar) - 1)
Else
' If sz had no null char, the Left$ function
' above would rtn a zero length string ("").
GetStrFromBufferA = szA
End If
End Function

Private Function FindDetailWindow(ByVal frmhWnd As Long) As Long
' The Detail Window is always the second of three
' windows of class OFormSub.
' 1) Form Header
' 2) Detail
' 3) Footer


Dim hWnd_VSB As Long
Dim hWnd As Long
Dim ctr As Long

ctr = 0
hWnd = frmhWnd

' Let's get first Child Window of the FORM
hWnd_VSB = apiGetWindow(hWnd, GW_CHILD)

' Let's walk through every sibling window of the Form
Do
' Thanks to Terry Kreft for explaining
' why the apiGetParent acll is not required.
' Terry is in a Class by himself!
'If apiGetParent(hWnd_VSB) <> hWnd Then Exit Do

If fGetClassName(hWnd_VSB) = "OFormSub" Then
ctr = ctr + 1
If ctr = 2 Then
FindDetailWindow = hWnd_VSB
Exit Function
End If

End If

' Let's get the NEXT SIBLING Window
hWnd_VSB = apiGetWindow(hWnd_VSB, GW_HWNDNEXT)

' Let's Start the process from the Top again
' Really just an error check
Loop While hWnd_VSB <> 0

' SORRY - This is impossible but there is no Detail Window!
FindDetailWindow = 0
End Function


Private Function FindOKttbxWindow(ByVal frmhWnd As Long) As Long
' The Detail Window always contains
' one window of class OKttbx.

Dim hWnd_VSB As Long
Dim hWnd As Long
Dim ctr As Long

ctr = 0
hWnd = frmhWnd

' Let's get first Child Window of the FORM
hWnd_VSB = apiGetWindow(hWnd, GW_CHILD)

' Let's walk through every sibling window of the Form
Do
If fGetClassName(hWnd_VSB) = "OKttbx" Then
FindOKttbxWindow = hWnd_VSB
Exit Function
End If

' Let's get the NEXT SIBLING Window
hWnd_VSB = apiGetWindow(hWnd_VSB, GW_HWNDNEXT)

' Let's Start the process from the Top again
' Really just an error check
Loop While hWnd_VSB <> 0

' SORRY - This is impossible but there is no TextBox Window!
FindOKttbxWindow = 0
End Function


Private Function fFindListBoxhWnd(ctl As Access.ListBox) As Long
' Get ListBox's hWnd
Dim hWnd_LSB As Long
Dim hWnd_Temp As Long

' Window RECT
Dim rc As RECT
Dim pt As POINTAPI
'Dim lngIC As Long
'Dim lngYdpi As Long

' Temp vars to calculate Window/Control positions
Dim lngCtlWidth As Long
Dim lngCtlHeight As Long

' Loop Counters
Dim SectionCounter As Long
Dim ctr As Long

' Which Section contains the Control?
Select Case ctl.Section

Case acDetail
'0
SectionCounter = 2

Case acHeader
'1
SectionCounter = 1

Case acFooter
'2
SectionCounter = 3

Case Else
' **** NEED ERROR HANDLING! ****

End Select

' Setup SectionCounter
' Form Header, Detail and then Footer
ctr = 1

' Let's get first Child Window of the FORM
hWnd_LSB = apiGetWindow(m_Form.hWnd, GW_CHILD)


' Let's walk through every sibling window of the Form
Do
If fGetClassName(hWnd_LSB) = "OFormSub" Then
' First OFormSub is the Form's Header. We want the next next one
' which is the detail section
If ctr = SectionCounter Then

' Search for Child Windows of Class "OGrid"
' Let's get first Child Window of the FORM
hWnd_Temp = apiGetWindow(hWnd_LSB, GW_CHILD)

Do
If fGetClassName(hWnd_Temp) = "OGrid" Then '

lngCtlWidth = (ctl.Width / TWIPSPERINCH) * m_ScreenXdpi
lngCtlHeight = (ctl.Height / TWIPSPERINCH) * m_ScreenYdpi
lngRet = GetWindowRect(hWnd_Temp, rc)

' Let's match our X and Y coordinates to make sure we
' have the correct ListBox
pt.X = (ctl.Left / TWIPSPERINCH) * m_ScreenXdpi
pt.y = (ctl.Top / TWIPSPERINCH) * m_ScreenXdpi
' Convert to Screen Coords
lngRet = ClientToScreen(hWnd_LSB, pt)


If Abs(pt.X - rc.Left) <= 2 Then
If Abs(pt.y - rc.Top) <= 2 Then

If Abs(lngCtlWidth - (rc.Right - rc.Left)) <= 3 Then
fFindListBoxhWnd = hWnd_Temp
Exit Function
End If

End If
End If
End If

' Let's get the NEXT SIBLING Window
hWnd_Temp = apiGetWindow(hWnd_Temp, GW_HWNDNEXT)


' Let's Start the process from the Top again
' Really just an error check
Loop While hWnd_Temp <> 0

End If
' Increment our Section Counter
ctr = ctr + 1
End If

' Let's get the NEXT SIBLING Window
hWnd_LSB = apiGetWindow(hWnd_LSB, GW_HWNDNEXT)

' Let's Start the process from the Top again
' Really just an error check
Loop While hWnd_LSB <> 0

' SORRY - NO ListBox hWnd is available
fFindListBoxhWnd = 0
End Function
Public Function fGetScrollBarPos(hWnd) As Long
' Return ScrollBar Thumb position
' for the Vertical Scrollbar attached to the
' Window passed to this Function.

Dim lngRet As Long
Dim sInfo As SCROLLINFO

' Init SCROLLINFO structure
sInfo.fMask = SIF_ALL
sInfo.cbSize = Len(sInfo)
sInfo.nPos = 0
sInfo.nTrackPos = 0

' Get the window's ScrollBar position
lngRet = apiGetScrollInfo(hWnd, SB_VERT, sInfo)
'Debug.Print "nPos:" & sInfo.nPos & " nPage:" & sInfo.nPage & " nMax:" & sInfo.nMax
fGetScrollBarPos = sInfo.nPos ' + 1

End Function
'******* Code Start *********
Private Function fGetClassName(hWnd As Long)
Dim strBuffer As String
Dim lngLen As Long
Const MAX_LEN = 255
strBuffer = Space$(MAX_LEN)
lngLen = apiGetClassName(hWnd, strBuffer, MAX_LEN)
If lngLen > 0 Then fGetClassName = Left$(strBuffer, lngLen)
End Function
'******* Code End *********


Private Sub Class_Initialize()
' Get the current screen resolution
GetScreenDPI

' Defaults:
' DelayInitial = 500 (1/2 sec)
' DelayAutoPopup = 5000 (5 secs)
' DelayReshow = 100 (1/10 sec)
' MaxTipWidth = 0
' all Margins = 0


End Sub

Public Sub Cleanup()

' I obviously have a reference problem. When I release the reference to
' this class from the calling Form the Class_Terminate event
' is not called.
' I have checked for memory/resource leaks and have found none
' by calling this cleanup sub prior to releasing the
' reference to this class.

Dim ctrl As Control
' Remove each tooltip tool we previously added to our Tooltip control
For Each ctrl In m_Form.Controls

Select Case ctrl.ControlType
Case acListBox
blRet = RemoveTool(ctrl, colControls(ctrl.Name).hWndLB)

Case Else
RemoveTool ctrl

End Select

Next

' Now release our ToolTip for the Access in place editing
' window - OKttbx window
blRet = RemoveTool(ctrl, m_hWndOKttbx)

' Free up our collection
Set colControls = Nothing

' Release our private control classes
Set cTBox = Nothing
Set cCBO = Nothing
Set cLB = Nothing
End Sub

Private Sub Class_Terminate()

If m_hwndTT <> 0 Then
lngRet = DestroyWindow(m_hwndTT)
End If

Set m_Form = Nothing
End Sub

I'm pretty certain this will work, just don't know where to put the code to show the "tool-tip form" with the airport info...
Thanks for all the help!!!
jw5107

 

[assets]

A very good post and my hats off to all who have replied. I am trying to change the colour of buttons. While I have done this by a bitmap, i wanted to change the colour on mouse over. I have not been able to do that yet but hope to get come helpfull info. As a side issue it can be done with javascript with the swap function and switch cell.style.color


Never give up never give in.

There are no short cuts to anything worth doing

 

[earthandfire]

Whilst I appreciate that you would prefer to use the ToolTip technology, in case you are unable to resolve your outstanding issues I've modified my example to include a timed closing of the pseudo popup form:

Option Compare Database
Option Explicit

Private Const LeftOffset As Single = 100
Private Const TopOffset As Single = 50

Private ChildTimedOut As Boolean

Private Sub OpenFormFlights(lbl As Label)

  If TheAirport = lbl.Caption Or ChildTimedOut Then
    Exit Sub
  Else
    TheAirport = lbl.Caption
    Child5.Top = lbl.Top + lbl.Height + lbl.BorderWidth + TopOffset
    Child5.Left = lbl.Left + LeftOffset
    Child5.Form.Requery
    Child5.Visible = True
    TimerInterval = 5000
  End If

End Sub

Private Sub CloseFlightsForm()

  If TheAirport = "" Then
    Exit Sub
  Else
    TimerInterval = 0
    Text7.SetFocus
    Child5.Visible = False
    TheAirport = ""
  End If

End Sub

Private Sub Detail_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

  ChildTimedOut = False
  CloseFlightsForm

End Sub

Private Sub Form_Timer()

  ChildTimedOut = True
  CloseFlightsForm

End Sub

Private Sub Label0_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

  OpenFormFlights Label0

End Sub

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

  OpenFormFlights Label1

End Sub

Private Sub Label2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

  OpenFormFlights Label2

End Sub

Private Sub Label3_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

  OpenFormFlights Label3

End Sub

Private Sub Label4_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

  OpenFormFlights Label4

End Sub

Hope this helps.

 

[jw5107]

OK - I got this to work using earthandfire's example.
2 questions:
1. Can somebody elaborate on Remou's example of looping thru the labels on the main form (mouse move event of the detail section). I think this would be a better way to go instead of setting all the triggers for each label. I have a bunch..!!
2. I also would like for the "tool-tip pop-up form" to open as a balloon, or in the balloon state. Any examples of how I can get the form to open as a balloon..??

Thanks for all the help!!! We ARE getting some where on this..!!!!
jw5107

 

[Remou]

My second post slots into my first post, instead of the label triggers. Have a look at both of them together and it should, hopefully, start making sense.

 

[jw5107]

earthandfire,

In your example (which I have got to work just fine - thanks!!) is there a way to have the hidden subform, when made visible - appear in the balloon format - like a tool-tip..?? Theres got to be a way to make this happen...!!!!
Any suggestions or examples...??
Thanks for the help..!
jw5107

 

[jw5107]

Any other suggestions as to how I can use the example d/base "A2kTooltipver34" from lebans.com for a form that pops-up just like a tool-tip, but with data related the a labels caption property...?? There has got to be a way to make this work...!!! I feel that I am so close..!! I just don't know how to get the coding to look at the labels caption (the control that the cursor is "hovered" over), and show a form (styled in balloon format) with a query as the recordsource - related to each labels caption...
There has got to be a way...!!
Thanks in advance..!!!
jw5107