ACCESS FEED: RE: [MS_AccessPros] widths and heights

Selasa, 26 Agustus 2014

RE: [MS_AccessPros] widths and heights

Hi Stuart and Crystal (and anyone else who's interested),

Here is an all-version-friendly update. I've tested it on A2003, A2010-64, and A2013-32. (Of course, both functions return zero on A2003 because it has neither ribbon nor nav pane).

Cheers,
Graham

=============== start code ================
Option Compare Database
Option Explicit

Private Const LOGPIXELSX    As Long = 88
Private Const LOGPIXELSY    As Long = 90

Private Const nTwipsPerInch As Long = 1440

Private dTwipsPerPixelX     As Double
Private dTwipsPerPixelY     As Double

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

#If VBA7 Then
Private Declare PtrSafe Function GetDC _
    Lib "user32" ( _
      ByVal hWnd As LongPtr _
    ) As LongPtr
#Else
Private Declare Function GetDC _
    Lib "user32" ( _
      ByVal hWnd As Long _
    ) As Long
#End If

#If VBA7 Then
Private Declare PtrSafe Function ReleaseDC _
    Lib "user32" ( _
      ByVal hWnd As LongPtr _
    , ByVal hdc As LongPtr _
    ) As Long
#Else
Private Declare Function ReleaseDC _
    Lib "user32" ( _
      ByVal hWnd As Long _
    , ByVal hdc As Long _
    ) As Long
#End If

#If VBA7 Then
Private Declare PtrSafe Function GetDeviceCaps _
    Lib "gdi32" ( _
      ByVal hdc As LongPtr _
    , ByVal nIndex As Long _
    ) As Long
#Else
Private Declare Function GetDeviceCaps _
    Lib "gdi32" ( _
      ByVal hdc As Long _
    , ByVal nIndex As Long _
    ) As Long
#End If

#If VBA7 Then
Private Declare PtrSafe Function GetWindowRect _
    Lib "user32" ( _
      ByVal hWnd As LongPtr _
    , lpRect As winRECT _
    ) As Long
#Else
Private Declare Function GetWindowRect _
    Lib "user32" ( _
      ByVal hWnd As Long _
    , lpRect As winRECT _
    ) As Long
#End If

#If VBA7 Then
Private Declare PtrSafe Function FindWindowEx _
    Lib "user32" _
    Alias "FindWindowExA" ( _
      ByVal hWndParent As LongPtr _
    , ByVal hwndChildAfter As LongPtr _
    , ByVal lpszClass As String _
    , ByVal lpszWindow As String _
    ) As LongPtr
#Else
Private Declare Function FindWindowEx _
    Lib "user32" _
    Alias "FindWindowExA" ( _
      ByVal hWndParent As Long _
    , ByVal hwndChildAfter As Long _
    , ByVal lpszClass As String _
    , ByVal lpszWindow As String _
    ) As Long
#End If

Private Function TwipsPerPixelX() As Double
If dTwipsPerPixelX = 0 Then GetScreenMetrics
TwipsPerPixelX = dTwipsPerPixelX
End Function

Private Function TwipsPerPixelY() As Double
If dTwipsPerPixelY = 0 Then GetScreenMetrics
TwipsPerPixelY = dTwipsPerPixelY
End Function

Private Sub GetScreenMetrics()
#If VBA7 Then
Dim hdc As LongPtr
#Else
Dim hdc As Long
#End If
hdc = GetDC(0)
dTwipsPerPixelX = nTwipsPerInch / GetDeviceCaps(hdc, LOGPIXELSX)
dTwipsPerPixelY = nTwipsPerInch / GetDeviceCaps(hdc, LOGPIXELSY)
Call ReleaseDC(0, hdc)
End Sub

Public Function GetRibbonHeight() As Long
' Return height of the Ribbon in twips
' Note that the result includes the QAT and the application title bar
#If VBA7 Then
Dim hWnd As LongPtr
Dim xRect As winRECT
hWnd = FindWindowEx(hWndAccessApp, 0, "MsoCommandBarDock", "MsoDockTop")
If hWnd <> 0 Then
    hWnd = FindWindowEx(hWnd, 0, "MsoCommandBar", "Ribbon")
End If
If hWnd = 0 Then
    MsgBox "Ribbon not found"
Else
    If GetWindowRect(hWnd, xRect) = 0 Then
      MsgBox "Cannot determine Ribbon dimensions"
    Else
      With xRect
        GetRibbonHeight = (.Bottom - .Top) * TwipsPerPixelY
      End With
    End If
End If
#Else
' pre-Access2007 - return 0
GetRibbonHeight = 0
#End If
End Function

Public Function GetNavPaneWidth() As Long
' Return width of the Nav Pane in twips
#If VBA7 Then
Dim hWnd As LongPtr
Dim xRect As winRECT
hWnd = FindWindowEx(hWndAccessApp, 0, "NetUINativeHWNDHost", "Navigation Pane Host")
If hWnd = 0 Then
    MsgBox "Nav Pane not found"
Else
    If GetWindowRect(hWnd, xRect) = 0 Then
      MsgBox "Cannot determine Nav Pane dimensions"
    Else
      With xRect
        GetNavPaneWidth = (.Right - .Left) * TwipsPerPixelX
      End With
    End If
End If
#Else
' pre-Access2007 - return 0
GetNavPaneWidth = 0
#End If
End Function
===================== end code =================================

From: MS_Access_Professionals@yahoogroups.com [mailto:MS_Access_Professionals@yahoogroups.com]
Sent: Wednesday, 27 August 2014 08:04
To: MS_Access_Professionals@yahoogroups.com
Subject: RE: [MS_AccessPros] widths and heights

So glad you finally got it :-)

It's easy enough to change the API Declares to be 64-bit compatible. I'll do that and post later. Keep an eye on that spam folder :-)

Cheers,
Graham

From: MS_Access_Professionals@yahoogroups.com [mailto:MS_Access_Professionals@yahoogroups.com]
Sent: Wednesday, 27 August 2014 07:28
To: MS_Access_Professionals@yahoogroups.com
Subject: Re: [MS_AccessPros] widths and heights

It works, it works perfectly!

But I just had a bad thought. A couple of the users are using 64 bit office, and I think you are using the 32 bit stuff.....

__._,_.___

Posted by: "Graham Mandeno" <graham@mandeno.com>

Reply via web post

•

Reply to sender

•

Reply to group

•

Start a New Topic