Access フォームのウィンドウサイズ調整

Access のフォームを開いたときに、最大化ではなくてAccess のクライアント領域のサイズで開きたいのですが、意外に難しかったです。あるフォームの Form_Open イベントで FormAutoResizing を呼ぶとクライアント領域のサイズに合わせて表示できます。

Private Sub Form_Open(Cancel As Integer)
    ' ウィンドウの大きさ自動調整
    FormAutoResizing
End Sub
' ウィンドウサイズ調整
Public ResWidth As String
Public ResHeight As String

Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, rectangle As RECT) As Long
Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hWnd As Long, ByVal hwndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Type RECT
   x1 As Long
   y1 As Long
   x2 As Long
   y2 As Long
End Type

'
' https://support.microsoft.com/en-us/kb/94927?wa=wsignin1.0
'
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

Const HWND_DESKTOP As Long = 0
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90

'--------------------------------------------------
Function PixelXToTwips(pixelsx As Long) As Single
    Dim lngDC As Long
    lngDC = GetDC(HWND_DESKTOP)
    PixelXToTwips = pixelsx * 1440& / GetDeviceCaps(lngDC, LOGPIXELSX)
    ReleaseDC HWND_DESKTOP, lngDC
End Function

'--------------------------------------------------
Function PixelYToTwips(pixelsy As Long) As Single
    Dim lngDC As Long
    lngDC = GetDC(HWND_DESKTOP)
    PixelYToTwips = pixelsy * 1440& / GetDeviceCaps(lngDC, LOGPIXELSY)
    ReleaseDC HWND_DESKTOP, lngDC
End Function
            


Public Function FormAutoResizing()
    Dim ret As Long
    Dim rc As RECT
    Dim w As Integer
    Dim h As Integer
    
    Dim hWnd As Long
    ' Access のクライアント領域を検索
    hWnd = FindWindowEx(Application.hWndAccessApp, 0, "MDIClient", vbNullString)
    If hWnd = 0 Then
        hWnd = Application.hWndAccessApp
    End If
    
    ret = GetClientRect(hWnd, rc)

    If ret Then
        w = PixelXToTwips(rc.x2 - rc.x1)
        h = PixelYToTwips(rc.y2 - rc.y1)
        DoCmd.MoveSize 0, 0, w, h
    End If
End Function

コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です

このサイトはスパムを低減するために Akismet を使っています。コメントデータの処理方法の詳細はこちらをご覧ください