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 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 Declare Function apiGetScrollInfo _
Lib "User32" Alias "GetScrollInfo" (ByVal hwnd As Long, _
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 Function apiGetFocus Lib "User32" _
        Alias "GetFocus" () As Long

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 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 WindowFromPoint Lib "User32" _
(ByVal xPoint As Long, ByVal yPoint As Long) As Long

Private Declare Function GetCursorPos Lib "User32" _
(lpPoint As POINTL) As Long

Private Declare Function GetFocus Lib "User32" () As Long

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

Private Declare Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" _
(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 Const TWIPSPERINCH = 1440
Private Const LOGPIXELSX = 88        '  Logical pixels/inch in X
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 rc As RECT
Dim rc1 As RECT
Dim lRet As Long
Dim lRowHeight As Long
Dim sngCurrentRow As Single
Dim lHeight As Long
Dim hWndCombo As Long
Dim hwnd As Long

Dim pt As POINTL
Dim lngIC As Long

Dim lngXdpi As Long
Dim lngYdpi As Long
Dim TwipsPerPixelX As Long
Dim TwipsPerPixelY As Long

Dim myscrollinfo 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

hWndCombo = 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 hWndCombo = 0 Then
    Exit Sub
End If

' Get Rectangle of Combo Edit window
lRet = GetWindowRect(hWndCombo, rc)

' Find current Cursor position
lRet = GetCursorPos(pt)
' Get this point's Window
hwnd = WindowFromPoint(pt.X, pt.Y)
' If we are on the Form's hwnd then exit
If hwnd = Me.hwnd Then Exit Sub

' Get Rectangle of Combo drop down List window
lRet = GetWindowRect(hwnd, rc1)

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

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

TwipsPerPixelX = TWIPSPERINCH \ lngXdpi
TwipsPerPixelY = 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 * TwipsPerPixelY)

'Convert our Cursor position to Twips
' ************map window to point!!!!!!
'pt.X = pt.X * TwipsPerPixelX
'pt.Y = pt.Y * TwipsPerPixelY

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

' Now we need to ascertain the offset of the ScrollBar position if any
myscrollinfo.cbSize = Len(myscrollinfo)
myscrollinfo.fMask = SIF_ALL
myscrollinfo.nTrackPos = 0
myscrollinfo.nPos = 0
lRet = apiGetScrollInfo(hwnd, SB_VERT, myscrollinfo)
sngCurrentRow = sngCurrentRow + myscrollinfo.nPos


' lRet = SendMessage(hwnd, LB_GETCURSEL, 0&, ByVal 0&)
Me.Text1 = Me.Text1 & vbCrLf & "Current Row:" & sngCurrentRow '"Height:" & rc.Bottom - rc.Top
Me.Text1 = Me.Text1 & vbCrLf & "ScrollBar nPos:" & myscrollinfo.nPos & "   nTrackPos:" & myscrollinfo.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
