Here is the code:
In a module:
Option Compare Database
Option Explicit
'DEVELOPED AND TESTED UNDER MICROSOFT ACCESS 97 and 2K VBA
'
'Copyright: Stephen Lebans - Lebans Holdings 1999 Ltd.
www.lebans.com
' You may use this code in your own private or commercial
applications
' without cost. Simply leave this copyright notice in the source
code.
' You may not sell htis code by itself or as part of a collection.
'
'
'Name: PositionFormRelativeToControl
'
'Version: 1.5
'
'Purpose: To allow you to open a second form relative to a control on the
parent form.
'
'Author: Stephen Lebans
''
'Web Site:
www.lebans.com
'
'Date: Nov 13 , 2004, 10:10:10 PM
'
'Credits: Whomever wants some!
'
'BUGS: Please report any bugs to:
''
'What's Missing:
' Proper error handling.
'
'How it Works:
' Walk through the source code!<grin>
'
' Enjoy
' Stephen Lebans
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 GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA"
(ByVal hwnd As Long, ByVal nIndex As Long) 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 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 GetDesktopWindow Lib "user32" () 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 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 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 Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" (ByVal hwnd1 As Long, ByVal hwnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
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
' Window Styles
Private Const WS_OVERLAPPED = &H0&
Private Const WS_POPUP = &H80000000
Private Const WS_CHILD = &H40000000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_VISIBLE = &H10000000
Private Const WS_DISABLED = &H8000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_CAPTION = &HC00000 ' WS_BORDER Or
WS_DLGFRAME
Private Const WS_BORDER = &H800000
Private Const WS_DLGFRAME = &H400000
Private Const WS_VSCROLL = &H200000
Private Const WS_HSCROLL = &H100000
Private Const WS_SYSMENU = &H80000
Private Const WS_THICKFRAME = &H40000
Private Const WS_GROUP = &H20000
Private Const WS_TABSTOP = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_TILED = WS_OVERLAPPED
Private Const WS_ICONIC = WS_MINIMIZE
Private Const WS_SIZEBOX = WS_THICKFRAME
Private Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or
WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Private Const WS_TILEDWINDOW = WS_OVERLAPPEDWINDOW
Private Const WS_POPUPWINDOW = (WS_POPUP Or WS_BORDER Or WS_SYSMENU)
Private Const WS_CHILDWINDOW = (WS_CHILD)
' Extended Window Styles
Private Const WS_EX_DLGMODALFRAME = &H1&
Private Const WS_EX_NOPARENTNOTIFY = &H4&
Private Const WS_EX_TOPMOST = &H8&
Private Const WS_EX_ACCEPTFILES = &H10&
Private Const WS_EX_TRANSPARENT = &H20&
' 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
' App instance
Private Const GWL_HINSTANCE = (-6)
Private Const GWL_STYLE = (-16)
' 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
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const SM_CXVSCROLL = 2
Private Const SM_CYHSCROLL = 3
Private Const SM_CXBORDER = 5
Private Const SM_CYBORDER = 6
' SetWindowPos Flags
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOREDRAW = &H8
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_FRAMECHANGED = &H20 ' The frame changed: send
WM_NCCALCSIZE
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_NOCOPYBITS = &H100
Private Const SWP_NOOWNERZORDER = &H200 ' Don't do owner Z ordering
Private Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Private Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
' SetWindowPos() hWndInsertAfter values
Private Const HWND_TOP = 0
Private Const HWND_BOTTOM = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const TITLE = ""
' Horizontal and Vertical Screen resolution
Private m_ScreenXdpi As Long
Private m_ScreenYdpi As Long
' Junk return vars
Private lRet As Long
Public Function PositionFormRelativeToControl(frmName As String, ctl As
Access.Control, Optional Position As Long = 0) As Boolean
Position:
' 0 = Underneath
' 1 = On Top
' 2 = Right side
' 3 = Left side
' 4 = Bottom Right Hand Corner
' Window handle to our Form's Detail Section
Dim m_hWndSection As Long
' Form we will position under the control
Dim frm As Access.Form
' Access MDI document window
Dim hWndMDI As Long
' MDI borders
Dim MDIborderX As Long
Dim MDIborderY As Long
' For positioning window
Dim rc As RECT
Dim rcWin As RECT
Dim pt As POINTAPI
Dim lOffsetX As Long, lOffsetY As Long
' Screen dimensions
Dim m_ScreenWidth As Long
Dim m_ScreenHeight As Long
' Window Style var
Dim lStyle As Long
' Since we are turning off screen redraw ignore all errors
On Error Resume Next
' Turn off redraw
' Leave this alone util you are done debugging
'Application.Echo False
' Open the Form
DoCmd.OpenForm frmName
' Does form exist?
Set frm = Forms.Item(frmName)
If Not frm Is Nothing Then
' Get the Window handle for the form Section containing this control
m_hWndSection = fFindSectionhWnd(ctl)
' Calculate the LEFT offset for this control from the edge of the Section
' First calc our screen resolution
GetScreenDPI
' Now get our screen dimensions
m_ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
m_ScreenHeight = GetSystemMetrics(SM_CYSCREEN)
Select Case Position
Case 0
lOffsetX = ctl.Left / (TWIPSPERINCH / m_ScreenXdpi)
lOffsetY = (ctl.Top + ctl.Height) / (TWIPSPERINCH / m_ScreenYdpi)
Case 1
lOffsetX = ctl.Left / (TWIPSPERINCH / m_ScreenXdpi)
lOffsetY = (-frm.WindowHeight + ctl.Top) / (TWIPSPERINCH /
m_ScreenYdpi)
Case 2
lOffsetX = (ctl.Left + ctl.Width) / (TWIPSPERINCH / m_ScreenXdpi)
lOffsetY = (ctl.Top) / (TWIPSPERINCH / m_ScreenYdpi)
Case 3
' Nov-2004 Logic error
' Must use Form's width NOT COntrol's width
'lOffsetX = (ctl.Left - ctl.Width) / (TWIPSPERINCH / m_ScreenXdpi)
lOffsetX = (ctl.Left - frm.WindowWidth) / (TWIPSPERINCH /
m_ScreenXdpi)
lOffsetY = (ctl.Top) / (TWIPSPERINCH / m_ScreenYdpi)
Case 4
lOffsetX = (ctl.Left + ctl.Width) / (TWIPSPERINCH / m_ScreenXdpi)
lOffsetY = (ctl.Top + ctl.Height) / (TWIPSPERINCH / m_ScreenYdpi)
Case Else
' Default to Underneath
lOffsetX = ctl.Left / (TWIPSPERINCH / m_ScreenXdpi)
lOffsetY = (ctl.Top + ctl.Height) / (TWIPSPERINCH / m_ScreenYdpi)
End Select
' Get window rectangle of the Section
lRet = GetWindowRect(m_hWndSection, rc)
' Add in offsets for the calling control
pt.X = lOffsetX + rc.Left&
pt.Y = lOffsetY + rc.Top
' Bounds checking to ensure form will be completely visible on screen
lRet = GetWindowRect(frm.hwnd, rcWin)
With rcWin
If m_ScreenWidth - pt.X < .Right - .Left Then
pt.X = m_ScreenWidth - (.Right - .Left)
ElseIf pt.X < 2 Then 'm_S
pt.X = 2
End If
If m_ScreenHeight - pt.Y < .Bottom - .Top Then
pt.Y = m_ScreenHeight - (.Bottom - .Top)
ElseIf pt.Y < 2 Then
pt.Y = 2
End If
End With
' If the Form's POPUP property is True then skip the
' ScreenToClient stuff
If Not frm.PopUp = True Then
' find MDIClient window
hWndMDI = FindWindowEx(Application.hWndAccessApp, 0&, "MDIClient",
TITLE)
' COnvert to Client coordinates of our MDI window
lRet = ScreenToClient(hWndMDI, pt)
' We have to subtract our MDI window's Border
lRet = GetWindowRect(hWndMDI, rcWin)
lRet = GetClientRect(hWndMDI, rc)
MDIborderX = ((rcWin.Right - rcWin.Left) - (rc.Right - rc.Left))
MDIborderY = ((rcWin.Bottom - rcWin.Top) - (rc.Bottom - rc.Top))
' See if ScrollBar is visible in the MDI window
lStyle = GetWindowLong(hWndMDI, GWL_STYLE)
If lStyle And WS_HSCROLL Then
MDIborderY = MDIborderY - GetSystemMetrics(SM_CYHSCROLL)
End If
If lStyle And WS_VSCROLL Then
MDIborderX = MDIborderX - GetSystemMetrics(SM_CXVSCROLL)
End If
' Remainder is our Border thickness
MDIborderX = MDIborderX / 2
MDIborderY = MDIborderY / 2
Else
' POPUP = True
' We need to subtract the Border thickness of the main Access
Aplication Window
MDIborderX = GetSystemMetrics(SM_CXBORDER)
MDIborderY = GetSystemMetrics(SM_CYBORDER)
End If
' Position our Form underneath of the calling control
Call SetWindowPos(frm.hwnd, 0&, pt.X - MDIborderX, pt.Y - MDIborderY, 0,
0, SWP_NOSIZE)
End If
' Turn on redraw
'Application.Echo True
' Cleanup
Set frm = Nothing
' Return Success
PositionFormRelativeToControl = True
End Function
Private Sub GetScreenDPI()
Dim lngDC As Long
' Grab any DC
lngDC = GetDC(0)
'Horizontal
m_ScreenXdpi = apiGetDeviceCaps(lngDC, LOGPIXELSX)
'Vertical
m_ScreenYdpi = apiGetDeviceCaps(lngDC, LOGPIXELSY)
lngDC = ReleaseDC(0, lngDC)
End Sub
Private Function fFindSectionhWnd(ctl As Access.Control) As Long
On Error GoTo Err_fFindSectionhWnd
' Get ListBox's hWnd
Dim hWnd_LSB As Long
Dim hWnd_Temp As Long
' Window RECT vars
Dim rc As RECT
Dim pt As POINTAPI
' 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
' Nov -2004 - Modification by Onno Willems
' Let's get first Child Window of the FORM
If TypeOf ctl.Parent Is Access.Page Then
' If the control is on a page on a tab, we can't get a window handle
If TypeOf ctl.Parent.Parent Is Access.TabControl Then
' As expected, the page is on a tab
If TypeOf ctl.Parent.Parent.Parent Is Access.Form Then
' And the parent of the tab is the form we wanted
hWnd_LSB = apiGetWindow(ctl.Parent.Parent.Parent.hwnd,
GW_CHILD)
End If
End If
Else
' Normal control directly on form
hWnd_LSB = apiGetWindow(ctl.Parent.hwnd, GW_CHILD)
End If
' 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
fFindSectionhWnd = hWnd_LSB
Exit Function
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
fFindSectionhWnd = 0
Exit_fFindSectionhWnd:
Exit Function
Err_fFindSectionhWnd:
MsgBox Err.Description
Resume Exit_fFindSectionhWnd
End Function
' From Dev Ashish's Site
' The Access Web
'
http://www.mvps.org/access/
'******* 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 *********
Then in the open form when you enter for example ComboBox1:
Private Sub ComboBox1_Enter()
On Error GoTo Err_Combo0_Enter
Dim blRet As Boolean
blRet = PositionFormRelativeToControl("Form1", Me.ComboBox1, 1)
Me.SetFocus
Me.ComboBox1.SetFocus
Exit_Combo0_Enter:
Exit Sub
Err_Combo0_Enter:
MsgBox Err.Description
Resume Exit_Combo0_Enter
End Sub
***Now this works fine and Form1 will open either above, to the right, to
the left, below, or below right depending on the 0,1,2,3,4 in the
blRet = PositionFormRelativeToControl("Form1", Me.ComboBox1, 1)
but the form will make a flash at a different location before it moves to
the correct position. Is there a way to prevent the flash of the form before
it postitions itself to the proper location.
Thank you,
Steven
