Option Compare Database
Option Explicit

Dim AlreadyWorking As Boolean ' Проверка, выполняется ли уже обработка изменения размера'

'************************************************************************************'
' ГРУППА ФУНКЦИЙ ДЛЯ ОБРАБОТКИ ФОРМ С МАСШТАБИРУЕМЫМИ ЭЛЕМЕНТАМИ'
'************************************************************************************'
Public Function SetMinFormSize()
On Error GoTo HaveError

  Dim rsFormSize As Recordset ' Таблица размеров форм'
  Dim sFormName As String
  Dim ctrl As Control

  On Error Resume Next
  sFormName = Screen.ActiveForm.Name
  If Err.Number <>  0  Or Forms(sFormName).CurrentView <>  1  Then
    On Error GoTo HaveError
    Beep
    MsgBox  "Клавиши Ctrl-M используются для задания минимального размера формы "  _
&  "с масштабируемыми элементами. Активным окном должна быть форма в режиме "  _
&  "простой или ленточной формы!" 
    GoTo EndProc
  End If
  On Error GoTo HaveError

  Set rsFormSize = CurrentDb.OpenRecordset( "сРазмеры" , dbOpenDynaset)
  rsFormSize.FindFirst  "[NameForm]='" & sFormName & "'" 
  If Not rsFormSize.NoMatch Then
    If MsgBox( "По форме '" & sFormName & _
"' уже есть данные о ее минимальных размерах. Заменить их?" , vbYesNo,  "Внимание!" ) = vbNo Then
      GoTo EndProc
    End If
    While Not rsFormSize.NoMatch
      rsFormSize.Delete
      rsFormSize.FindFirst  "[NameForm]='" & sFormName & "'" 
    Wend
  End If

  rsFormSize.AddNew ' Сохраняю данные о самой форме'
  rsFormSize![NameForm] = sFormName
  rsFormSize![MinHeight] = Screen.ActiveForm.InsideHeight
  rsFormSize![MinWidth] = Screen.ActiveForm.InsideWidth
  rsFormSize![MinUpper] = Screen.ActiveForm.Section(acDetail).Height
  rsFormSize.Update

  ' Сохраняю данные об элементах формы'
  For Each ctrl In Screen.ActiveForm
    rsFormSize.AddNew
    rsFormSize![NameForm] = sFormName
    rsFormSize![NameControl] = ctrl.Name
    rsFormSize![MinUpper] = ctrl.Top
    rsFormSize![MinLeft] = ctrl.Left
    rsFormSize![MinHeight] = ctrl.Height
    rsFormSize![MinWidth] = ctrl.Width
    rsFormSize.Update
  Next ctrl
  
  MsgBox  "Новые данные о минимальном размере формы '" & sFormName & _
"' и ее элементов были сохранены." 
  
EndProc:
  Set ctrl = Nothing
  On Error Resume Next
  rsFormSize.Close
  On Error GoTo HaveError
  Set rsFormSize = Nothing
Exit Function
HaveError:
мсКонтрОшибок.CalcErr  "мсМасштФорм" ,  "SetMinFormSize" , Err.Number, Err.Description
End Function

Public Function SetChangeFormSize()
On Error GoTo HaveError

  Dim rsFormSize As Recordset ' Таблица размеров форм'
  Dim sFormName As String
  Dim ctrl As Control
  Dim CngFormHeight, CngFormWidth As Long

  On Error Resume Next
  sFormName = Screen.ActiveForm.Name
  If Err.Number <>  0  Or Forms(sFormName).CurrentView <>  1  Then
    On Error GoTo HaveError
    Beep
    MsgBox  "Клавиши Ctrl-N используются для задания правил изменения размера "  _
&  "формы с масштабируемыми элементами. Активным окном должна быть форма в "  _
&  "режиме простой или ленточной формы!" 
    GoTo EndProc
  End If
  On Error GoTo HaveError

  Set rsFormSize = CurrentDb.OpenRecordset( "сРазмеры" , dbOpenDynaset)
  rsFormSize.FindFirst  "[NameForm]='" & sFormName & "' And ([NameControl]='' Or [NameControl] Is Null)" 
  If rsFormSize.NoMatch Then
    Beep
    MsgBox  "Сначала выполните обработку минимальных размеров формы."  & Chr( 10 ) & _
            "Обработка остановлена." , vbCritical
    GoTo EndProc
  End If
  CngFormHeight = Screen.ActiveForm.InsideHeight - rsFormSize![MinHeight]
  CngFormWidth = Screen.ActiveForm.InsideWidth - rsFormSize![MinWidth]
  If CngFormHeight <=  0  Or CngFormWidth <=  0  Then
    Beep
    MsgBox  "Перед сохранением изменения размеров вы должны изменить их!"  & Chr( 10 ) & _
            "Обработка остановлена." , vbCritical
    GoTo EndProc
  End If

  ' Сохраняю данные об изменении размера области данных формы'
  rsFormSize.Edit
  rsFormSize![ChangeUpper] = (Screen.ActiveForm.Section(acDetail).Height - rsFormSize![MinUpper]) / CngFormHeight
  rsFormSize.Update

  ' Сохраняю данные об элементах формы'
  For Each ctrl In Screen.ActiveForm
    rsFormSize.FindFirst  "[NameForm]='" & sFormName & "' And [NameControl]='" & ctrl.Name & "'" 
    If rsFormSize.NoMatch Then
      Beep
      MsgBox  "Найдены элементы, отсутствующие в описании минимальных размеров."  & Chr( 10 ) & _
              "Выполните обработку минимальных размеров формы повторно "  _
&  "или добавьте недостающие записи в описание вручную."  & Chr( 10 ) & _
              "Обработка остановлена." , vbCritical
      GoTo EndProc
    End If
    rsFormSize.Edit
    rsFormSize![ChangeUpper] = (ctrl.Top - rsFormSize![MinUpper]) / CngFormHeight
    rsFormSize![ChangeLeft] = (ctrl.Left - rsFormSize![MinLeft]) / CngFormWidth
    rsFormSize![ChangeHeight] = (ctrl.Height - rsFormSize![MinHeight]) / CngFormHeight
    rsFormSize![ChangeWidth] = (ctrl.Width - rsFormSize![MinWidth]) / CngFormWidth
    rsFormSize.Update
  Next ctrl

  MsgBox  "Правила изменения размера формы '" & sFormName & "' и ее элементов были сохранены." 
  
EndProc:
  Set ctrl = Nothing
  On Error Resume Next
  rsFormSize.Close
  On Error GoTo HaveError
  Set rsFormSize = Nothing
Exit Function
HaveError:
мсКонтрОшибок.CalcErr  "мсМасштФорм" ,  "SetChangeFormSize" , Err.Number, Err.Description
End Function

Public Function ChangeFormSize(ByVal fForm As Access.Form)
On Error GoTo HaveError

  Dim rsFormSize As Recordset ' Таблица размеров форм'
  Dim ctrl As Control
  Dim CngFormHeight, CngFormWidth As Long
 
  If AlreadyWorking Then GoTo EndProc
  AlreadyWorking = True
 
  If fForm.CurrentView =  1  Then
    Set rsFormSize = CurrentDb.OpenRecordset( "сРазмеры" , dbOpenDynaset)
    rsFormSize.FindFirst  "[NameForm]='" & fForm.Name & "' And ([NameControl]='' Or [NameControl] Is Null)" 
    If rsFormSize.NoMatch Then
      GoTo EndProc
    End If
 
    CngFormHeight = fForm.InsideHeight - rsFormSize![MinHeight]
    CngFormWidth = fForm.InsideWidth - rsFormSize![MinWidth]
    If CngFormHeight <=  0  Or CngFormWidth <=  0  Then
      fForm.InsideHeight = rsFormSize![MinHeight]
      fForm.InsideWidth = rsFormSize![MinWidth]
      CngFormHeight =  0 
      CngFormWidth =  0 
    End If
    fForm.Section(acDetail).Height = rsFormSize![ChangeUpper] * CngFormHeight + rsFormSize![MinUpper]
    fForm.Width = rsFormSize![MinWidth] + CngFormWidth
 
    For Each ctrl In fForm
      rsFormSize.FindFirst  "[NameForm]='" & fForm.Name & "' And [NameControl]='" & ctrl.Name & "'" 
      If Not rsFormSize.NoMatch Then
        ctrl.Height = rsFormSize![ChangeHeight] * CngFormHeight + rsFormSize![MinHeight]
        ctrl.Width = rsFormSize![ChangeWidth] * CngFormWidth + rsFormSize![MinWidth]

On Error Resume Next
        ctrl.Top = rsFormSize![ChangeUpper] * CngFormHeight + rsFormSize![MinUpper]
        ctrl.Left = rsFormSize![ChangeLeft] * CngFormWidth + rsFormSize![MinLeft]
On Error GoTo HaveError
      End If
    Next ctrl
  End If

  AlreadyWorking = False
  
EndProc:
  Set ctrl = Nothing
  On Error Resume Next
  rsFormSize.Close
  On Error GoTo HaveError
  Set rsFormSize = Nothing
  Set fForm = Nothing
Exit Function
HaveError:
мсКонтрОшибок.CalcErr  "мсМасштФорм" ,  "ChangeFormSize" , Err.Number, Err.Description
End Function