VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmComboCurrentRow"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

 'Name                  ComboCurrentRow
 '
 'Purpose:               Code to determine currently highlighted row of a ComboBox control
 '
 'Version:               1.0
 '
 'Calls:                 Windows API stuff.
 '
 'Returns:               None
 '
 'Created by:            Stephen Lebans
 '
 'Credits:               If you want some...take some.
 '
 'Date:                  Feb 02, 2004
 '
 'Time:                  10:10:10pm
 '
 'Feedback:              Stephen@lebans.com
 '
 'My Web Page:           www.lebans.com
 '
 'Copyright:             Lebans Holdings Ltd.
 '                       Please feel free to use this code
 '                       without restriction in any application you develop.
 '                       This code may not be resold by itself or as
 '                       part of a collection.
 '
 'What's Missing:        Let me know!
 '
 '
 '
 'Bugs:
 '                      There is a one pixel bug that shows itself when using certain fonts/sizes.
 '                      It will manifest itself in that you can have one row highlighted but the code
 '                      calculates the wrong row by one. It may be arounding error on my part or
 '                      just a lack of understanding of how Access renders the text in the windows of
 '                      class OGrid. If anyone figures it out please let me know!!!
 '
 'Enjoy
 'Stephen Lebans


Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

'Private Type RECT
'   left As Long
'   Top As Long
'   Right As Long
'   Bottom As Long
'End Type


Private Type POINTAPI
  x As Long
  y As Long
End Type

'Private Type POINTL
'        X As Long
'        Y 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 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 PtrSafe Function apiGetScrollInfo Lib "User32" Alias "GetScrollInfo" (ByVal hWnd As LongPtr, ByVal n As Long, _
                                                    lpSCROLLINFO As SCROLLINFO) As Long

' SB Constants
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)

Private Const SB_HORZ = 0
Private Const SB_CTL = 2
Private Const SB_VERT = 1


Private Declare PtrSafe Function apiGetFocus Lib "User32" Alias "GetFocus" () As LongPtr

Private Declare PtrSafe Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, _
                                               ByVal wParam As LongPtr, lParam As Any) As LongPtr

Private Declare PtrSafe Function GetClientRect Lib "User32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long

Private Declare PtrSafe Function GetWindowRect Lib "User32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long

#If Win64 = True Then
Private Declare PtrSafe Function WindowFromPoint Lib "User32" (ByVal Point As LongLong) As LongPtr
#Else
Private Declare PtrSafe Function WindowFromPoint Lib "User32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If


'32264 Private Declare Function GetCursorPos Lib "User32" (lpPoint As POINTL) As Long
Private Declare PtrSafe Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long

Private Declare PtrSafe Function GetFocus Lib "User32" () As LongPtr

Private Declare PtrSafe Function apiCreateIC Lib "gdi32" Alias "CreateICA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, _
                                               ByVal lpOutput As String, lpInitData As Any) As LongPtr

Private Declare PtrSafe Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" (ByVal hdc As LongPtr) As Long

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

Private Const TWIPSPERINCH = 1440
Private Const LOGPIXELSX = 88        '  Logical pixels/inch in X
'32264
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Const LOGPIXELSY = 90        '  Logical pixels/inch in Y

Private Sub Combo3_DblClick(Cancel As Integer)
MsgBox "double click"
End Sub

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

Dim udtRc As RECT: Dim lptIC As LongPtr
Dim udtRc1 As RECT
Dim lngLRet As Long
Dim lngLRowHeight As Long
Dim sngCurrentRow As Single
Dim lngLHeight As Long
Dim lptHWndCombo As LongPtr
Dim lptHwnd As LongPtr

Dim udtPt As POINTAPI


Dim lngXdpi As Long
Dim lngYdpi As Long
Dim lngTwipsPerPixelX As Long
Dim lngTwipsPerPixelY As Long

Dim udtMySCROLLINFO As SCROLLINFO

' Exit if Y Position is not greater than the height of the control itself
' because then our Combo is not dropped
If y < Me.Combo3.Height Then Exit Sub

lptHWndCombo = GetFocus()
' This is the Combo's Edit Window even if the Combo is currently dropped because
' Access has called the SetCapture API.
' We can simply assume for this sample that the drop down list window is at least twice
' the height of the Combo Edit Window.
' Therefore this method will only work for a Combo that displays at least two rows

If lptHWndCombo = 0 Then
    Exit Sub
End If

' Get Rectangle of Combo Edit window
lngLRet = GetWindowRect(lptHWndCombo, udtRc)

' Find current Cursor position
lngLRet = GetCursorPos(udtPt)
' Get this point's Window
#If Win64 = True Then ' 32264 Update ? use PointToLongLong(point) when existing from udt.x , udy.Y
  lptHwnd = WindowFromPoint(PointToLongLong(udtPt))
#Else
  lptHwnd = WindowFromPoint(udtPt.x, udtPt.y)
#End If
' If we are on the Form's lptHwnd then exit
If lptHwnd = Me.hWnd Then Exit Sub

' Get Rectangle of Combo drop down List window
lngLRet = GetWindowRect(lptHwnd, udtRc1)

' Verify this window is larger than then Combo's Edit window
If (udtRc1.Bottom - udtRc1.Top) < (udtRc.Bottom - udtRc.Top) * 2 Then Exit Sub

' Need Twips per pixel
lptIC = apiCreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
'If the call to CreateIC didn't fail, then get the Screen X resolution.
If lptIC <> 0 Then
    lngXdpi = apiGetDeviceCaps(lptIC, LOGPIXELSX)
    lngYdpi = apiGetDeviceCaps(lptIC, LOGPIXELSY)
           
    'Release the information context.
    apiDeleteDC (lptIC)
Else
    ' Something has gone wrong. Assume a normal value.
    lngXdpi = 96
    lngYdpi = 96
    Exit Sub
End If

lngTwipsPerPixelX = TWIPSPERINCH \ lngXdpi
lngTwipsPerPixelY = TWIPSPERINCH \ lngYdpi

' Calculate the height of each row

' We must remove the Height of the Combo control itself from our Y pos value
y = y - Me.Combo3.Height
' Plus there is a 1 pixel gap we have to include
y = y - (1 * lngTwipsPerPixelY)

'Convert our Cursor position to Twips
' ************map window to point!!!!!!
'pt.X = udtPt.X * lngTwipsPerPixelX
'pt.Y = udtPt.Y * lngTwipsPerPixelY

' Divide the total height of the Combo drop down window by the total number of rows displayed
lngLRowHeight = (udtRc1.Bottom - udtRc1.Top) * lngTwipsPerPixelY
lngLRowHeight = lngLRowHeight \ Me.Combo3.ListRows
' Now we have how many Twips per Row
' Divide by Y Position to get current Row
'sngCurrentRow = CSng(Y / lngLRowHeight) + 1
sngCurrentRow = (y \ lngLRowHeight) + 1

' Now we need to ascertain the offset of the ScrollBar position if any
udtMySCROLLINFO.cbSize = LenB(udtMySCROLLINFO)
udtMySCROLLINFO.fMask = SIF_ALL
udtMySCROLLINFO.nTrackPos = 0
udtMySCROLLINFO.nPos = 0
lngLRet = apiGetScrollInfo(lptHwnd, SB_VERT, udtMySCROLLINFO)
sngCurrentRow = sngCurrentRow + udtMySCROLLINFO.nPos


' lngLRet = SendMessage(lptHwnd, LB_GETCURSEL, 0&, ByVal 0&)
Me.Text1 = Me.Text1 & vbCrLf & "Current Row:" & sngCurrentRow '"Height:" & udtRc.Bottom - udtRc.Top
Me.Text1 = Me.Text1 & vbCrLf & "ScrollBar nPos:" & udtMySCROLLINFO.nPos & "   nTrackPos:" & udtMySCROLLINFO.nTrackPos
End Sub

Private Sub Combo3_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Me.Text1 = "MouseMove:" & x & "  Y:" & y
 Call Combo3_MouseDown(Button, Shift, x, y)
End Sub

Private Sub Combo3_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Me.Text1 = "MouseUP"
End Sub
Private Function PointToLongLong(Point As POINTAPI) As LongLong
    Dim ll As LongLong
    Dim cbLongLong As LongPtr
    
    cbLongLong = LenB(ll)
    
    ' make sure the contents will fit
    If LenB(Point) = cbLongLong Then
        CopyMemory ll, Point, cbLongLong
    End If
    
    PointToLongLong = ll
End Function
