Option Compare Database
Option Explicit

Global g_KoefScreenResol As Single

Public Type Rect
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type T_OP
    Name As String
    Left As Integer
    Top As Integer
    Width As Integer
    Height As Integer
    FontSize As Integer
End Type

Public Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) As Long

Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
 'Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
 
Public Const HORZRES =  8 
Public Const VERTRES =  10 

 ' Пример вызова:
 
 'Private Sub test()
 
 '     If ScreenResol(1024, 768) Then
 
 '       MsgBox "Разрешение экрана больше или равно, чем 1024 x 768"
 
 '     Else
 
 '       MsgBox "Разрешение экрана менее, чем 1024 x 768"
 
 '     End If
 
 'End Sub
 

Public Sub GetKoefSR_1024()
    If ScreenResol( 1024 ,  768 ) Then
        g_KoefScreenResol =  1 . 28 
    Else
        g_KoefScreenResol =  1 
    End If
End Sub

Public Sub GetKoefSR_Person()
    If Get_Koef_Resize =  0  Then
        Call GetKoefSR_1024
    Else
        g_KoefScreenResol = Get_Koef_Resize
    End If
End Sub



Public Function ScreenResol(ByVal x As Long, ByVal y As Long) As Boolean
 ' Проверка разрешения экрана
 
    Dim hdc As Long
    Dim xRes As Long
    Dim yRes As Long
    
    hdc = GetDC(GetDesktopWindow())

    xRes = GetDeviceCaps(hdc, HORZRES)
    yRes = GetDeviceCaps(hdc, VERTRES)
    
     ' Проверка делается на >=
 
    ScreenResol = (xRes >= x) And (yRes >= y)
        
     'If xRes < 1024 Then DoCmd.OpenForm "ChangeResolution", acNormal, , , , acDialog    'Вызов настройки экрана
 
     'ReleaseDC GetDesktopWindow(), hdc
 
End Function

Public Sub FormReSize4Resol(frm As Form)
On Error Resume Next
Dim obj As Object
Dim i As Integer
Dim AccRect As Rect
Dim OP() As T_OP
Dim C_OP As Integer
Dim tmp As Integer

    If g_KoefScreenResol =  0  Then Call GetKoefSR_Person  'GetKoefSR_1024
 
    If Abs(g_KoefScreenResol -  1 ) <  0 . 001  Then Exit Sub

     'MsgBox "FRM: " & frm.Name
 

    frm.InsideHeight = frm.InsideHeight * g_KoefScreenResol
    frm.InsideWidth = frm.InsideWidth * g_KoefScreenResol
    
    frm.Width = frm.Width * g_KoefScreenResol
    
    For i =  0  To  1000 
        Set obj = frm.Section(i)
        If err.number <>  0  Then
            err.number =  0 
            Exit For
        End If
         'MsgBox "SEC: " & obj.Name
 
        obj.Height = obj.Height * g_KoefScreenResol
    Next
    
    C_OP =  0 
    For Each obj In frm.Controls
         'MsgBox "OBJ: " & obj.Name & " - " & TypeName(obj)
 
        If TypeName(obj) = "OptionGroup" Then  ' Проводим сдвижку после сдвижки внутренних объектов
 
            C_OP = C_OP +  1 
            ReDim Preserve OP( 1  To C_OP)
            OP(C_OP).Name = obj.Name
            OP(C_OP).Top = obj.Top * g_KoefScreenResol
            OP(C_OP).Left = obj.Left * g_KoefScreenResol
            OP(C_OP).Width = obj.Width * g_KoefScreenResol
            OP(C_OP).Height = obj.Height * g_KoefScreenResol
            OP(C_OP).FontSize = obj.FontSize * g_KoefScreenResol
        Else
            obj.Top = obj.Top * g_KoefScreenResol
            obj.Left = obj.Left * g_KoefScreenResol
            obj.Width = obj.Width * g_KoefScreenResol
            obj.Height = obj.Height * g_KoefScreenResol
            obj.FontSize = obj.FontSize * g_KoefScreenResol
            err.number =  0 
        End If
    Next
    
     ' Сдвижка элементов OptionGroup
 
    For i =  1  To C_OP
        tmp = frm(OP(i).Name).Height
        frm.Section(frm(OP(i).Name).Section).Height = frm.Section(frm(OP(i).Name).Section).Height + tmp
        frm(OP(i).Name).Top = OP(C_OP).Top
        frm(OP(i).Name).Height = OP(C_OP).Height
        frm.Section(frm(OP(i).Name).Section).Height = frm.Section(frm(OP(i).Name).Section).Height - tmp
        
        tmp = frm(OP(i).Name).Width
        frm.Width = frm.Width + tmp
        frm(OP(i).Name).Left = OP(C_OP).Left
        frm(OP(i).Name).Width = OP(C_OP).Width
        frm.Width = frm.Width - tmp
        
        frm(OP(i).Name).FontSize = OP(C_OP).FontSize
    Next
    
     ' Центрирование форм (если надо)
 
    If frm.AutoCenter Then
        Call GetClientRect(Application.hWndAccessApp, AccRect)
        AccRect.Left = ((AccRect.Right - AccRect.Left) *  15  - frm.WindowWidth) /  2 
        AccRect.Top = ((AccRect.Bottom - AccRect.Top) *  15  - frm.WindowHeight) /  2  -  660 
        If AccRect.Left <  0  Then AccRect.Left =  0 
        If AccRect.Top <  0  Then AccRect.Top =  0 
        DoCmd.MoveSize AccRect.Left, AccRect.Top
    End If
    
End Sub

frm.Width = frm.Width * g_KoefScreenResol
    
    For i =  0  To  1000 
        Set obj = frm.Section(i)
        If err.number <>  0  Then
            err.number =  0 
            Exit For
        End If
         'MsgBox "SEC: " & obj.Name
 
        obj.Height = obj.Height * g_KoefScreenResol
    Next