TopPicLogo TopPicText

Элементы формы - Выравнивание по центру при изменении размеров формы

... то что должно быть по середине  - там и останется, не зависимо от изменений размеров формы ...

Achtung!
Свойство Элемента(ов) Horizontal Anchor должно быть устоновлено = Left (по умолчанию) - иначе результат будет не ожидаемым


Модуль:


Option Compare Database
Option Explicit
'--------------------------------------------------------------------
' Module    : modFormControlsToCenter
' Version   : 001
' Author    : es
' Date      : 02.08.2015
' Purpose   : Выравнивание контролей формы по центру (относительно центра) при изменении её размеров
'
'--------------------------------------------------------------------
Private Const cm = 567               'Сколько Твипов (Twips) в 1 см
'--------------------------------------------------------------------
Private l As Integer                  'Отступ слева обьекта
Private t As Integer                  'Отступ сверху обьекта
Private w As Integer                  'Ширина обьекта
Private h As Integer                  'Высота обьекта
Private iСorrectionTwips As Integer   'Поправка в твипах
'--------------------------------------------------------------------

Public Sub ControlToCenterHz(frm As Form, ctrl As Control, Optional iMinFormWidthCm As Currency = 0, Optional iPlusMinusCm As Currency = 0)
'es - 28.07.2015 V001
'Выравнивание контрола по середине формы  (при изменении её размеров)
'--------------------------------------------------------------------
'Параметры:
'   ctrl             = Ссылка на перемещаемый контрол
'   frm              = Форма -  изменившая размеры
'   iMinFormWidthCm  = Минимальный размер формы (в САНТИМЕТРАХ) по горизонтали
'                      по достижению которого пердвижения не происходит
'   iPlusMinusCm     = поправка в см - Пожительное или Отрицательное значение (точность = 4 знака)
'                      (Для выравнивания нескольких обьектов) относительно горизонтального центра формы
'                      т.е. в сантиметрах от серидины формы до середины объекта...
'--------------------------------------------------------------------
Dim iNewFormWidth As Integer      'Новая ширина формы
Dim iLeftToFormMid As Integer     'Отступ слева до середины формы
Dim i As Integer                 'Служебная для разл. расчётов
'--------------------------------------------------------------------

On Error GoTo ControlToCenterHz_Err
    
'Новая ширина формы:
        iNewFormWidth = frm.InsideWidth
 
'Учёт минимальной высоты формы
    i = iMinFormWidthCm * cm + i
    If iNewFormWidth < i Then GoTo ControlToCenterHz_Bye
 
 
'Расчёт поправки в твипах
    iСorrectionTwips = Round(iPlusMinusCm * cm, 0)


'Отступ слева до Середины формы по горизонтали
    iLeftToFormMid = Round(iNewFormWidth / 2, 0)  'Центр формы по ширене
    
'--------------------------------------------------------------------
'Берём текущие параметры
    t = ctrl.Top    'Отступ сверху контрола
    w = ctrl.Width  'Ширина контрола
    h = ctrl.Height 'Высота контрола
    
' Расчёт отступа слева учётом поправки - см функцию "NewControlPositionInTwips" ниже ...
    l = NewControlPositionInTwips(iLeftToFormMid, ctrl.Width, iСorrectionTwips)
    If l < 0 Then GoTo ControlToCenterHz_Bye

'Собственно перемещение
    ctrl.Move l, t, w, h


ControlToCenterHz_Bye:
    Exit Sub

ControlToCenterHz_Err:
    MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "в процедуре: ControlToCenterHz", vbCritical, "Error!"
    Resume ControlToCenterHz_Bye

End Sub

Public Sub ControlToCenterVr(frm As Form, ctrl As Control, Optional ByVal iMinFormHeightCm As Currency = 0, Optional ByVal iPlusMinusCm As Currency = 0)
'es - 02.08.2015 V002
'Выравнивание контрола по середине формы Вертикально (при изменении её размеров)
'--------------------------------------------------------------------
'Параметры:
'   frm               = Ссылка на Форму -  изменившую размеры
'   ctrl              = Ссылка на перемещаемый контрол
'   iMinFormHeightCm  = Минимальный размер формы (в САНТИМЕТРАХ) по вертикали
'                       по достижению которого передвижения не происходит!
'                       (с учётом заголовка и примечания формы - если они видимы)
'   iPlusMinusCm      = поправка в см - Пожительное или Отрицательное значение (точность = 4 знака)
'                       (Для выравнивания нескольких обьектов) относительно центра формы
'                       т.е. в сантиметрах от серидины формы  до середины объекта ...
'--------------------------------------------------------------------
Dim iNewFormHeight As Integer    'Новая высота формы
Dim iTopToFormMid As Integer 'Отступ сверху до середины формы
Dim i As Integer                 'Служебная для разл. расчётов
Dim z As Integer
'--------------------------------------------------------------------
On Error GoTo ControlToCenterVr_Err
    
'Новая высота формы:
    iNewFormHeight = frm.InsideHeight

'Учёт минимальной высоты формы
    i = iMinFormHeightCm * cm + i
    If iNewFormHeight < i Then GoTo ControlToCenterVr_Bye

'Расчёт поправки в твипах
    iСorrectionTwips = Round(iPlusMinusCm * cm, 0)
   
'Расчёт отступа сверху до Середины области данных формы
'--------------------------------------------------------------------
'Суммарная высота заголовка и примечания формы acHeader acFooter
    If FormHasSections(frm) = True Then 'См функцию "FormHasSections" ниже ...
        If frm.Section(acHeader).Visible = True Then z = frm.Section(acHeader).Height     'Заголовок
        If frm.Section(acFooter).Visible = True Then z = z + frm.Section(acFooter).Height 'Примечание
    Else
        z = 0
    End If
    
'Отступ сверху Середины области данных формы по высоте с учётом заголовка и примечания
    i = iNewFormHeight - z                      'Высота области данных в твипах
    iTopToFormMid = Round(i / 2, 0)             'Отступ сверху до середины формы

'--------------------------------------------------------------------
'Берём тек параметры:
    l = ctrl.Left   'Отступ лева контрола
    w = ctrl.Width  'Ширина контрола
    h = ctrl.Height 'Высота контрола

' Расчёт отступа сверху с учётом высоты контроля и поправочки
    t = NewControlPositionInTwips(iTopToFormMid, ctrl.Height, iСorrectionTwips)

'Собственно перемещение контрола
    ctrl.Move l, t, w, h


ControlToCenterVr_Bye:
    Exit Sub

ControlToCenterVr_Err:
    MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "в процедуре: ControlToCenterVr", vbCritical, "Error!"
    Resume ControlToCenterVr_Bye
End Sub

Private Function FormHasSections(frm As Form) As Boolean
'Возвращает True если указанная в аргументе форма имеет Секции (Заголовок | Примечание)
'--------------------------------------------------------------------
Dim b As Boolean
'--------------------------------------------------------------------
On Error GoTo FormHasSections_Err
    b = frm.Section(acHeader).Visible
    FormHasSections = True
    Exit Function

FormHasSections_Err:
    FormHasSections = False 'Error 2462
    Err.Clear

End Function
Private Function NewControlPositionInTwips(iTwipsToFormMid As Integer, iTwipsControlSize As Integer, iPlusMinusTwips As Integer) As Integer
Dim a As Integer                 'Служебная для разл. расчётов
Dim z As Integer
'--------------------------------------------------------------------
' Расчёт отступа сверху | слева с учётом размера контроля и поправочки
    a = iTwipsToFormMid + iPlusMinusTwips   ' Учли поправку
    z = Round(iTwipsControlSize / 2, 0)     ' Половина размера обьекта
    a = a - z
    If a < 0 Then a = 0 'На всякий случай ... (то превент еррорс...)
    NewControlPositionInTwips = a         
End Function



Public Sub ControlsToCenterAutoCode(sFormName As String, Optional bForNotCurrentForm As Boolean = False, Optional curPlusMinusToTopCm As Currency)
'es - 04.08.2015 v001
' Выводит в Immadiate Window (Ctrl + G) код для перемещения обьектов указанной в аргументе формы
'--------------------------------------------------------------------
' Аргументы:
'   sFormName             = Название формы
'   bForNotCurrentForm    = Для текущей формы или нет
'   curPlusMinusToTopCm   = Вертикальная поправка в см
'                         = Пожительное или Отрицательное значение (точность = 4 знака)
'--------------------------------------------------------------------
' Пример эксплуотации: ControlsToCenterAutoCode "FormTest", False
'--------------------------------------------------------------------
Dim iNewFormWidth As Integer
Dim iNewFormHeight As Integer    'Новая высота формы
Dim iToFormMidHz As Integer         'Отступ слева до середины формы
Dim iToFormMidVr As Integer         'Отступ сверху до середины формы
Dim iСorrectionTwips As Integer   'Поправка в твипах
Dim frm As Form
Dim ctrl As Control
Dim sOne As String                'Служебная строка
Dim sTwo As String                'Служебная строка
Dim sFormLink As String           'Служебная строка
Dim cMinFormWidthCm As Currency   'Новая ширина формы в см
Dim cMinFormHeightCm As Currency  'Новая высота формы в см
Dim cСorrectionCm As Currency     'Поправка в см

Dim bIsLoaded As Boolean          'Загружена ли форма
Dim i As Integer                 'Служебная для разл. расчётов
Dim c As Currency                 'Служебная для разл. расчётов
'--------------------------------------------------------------------
On Error GoTo ControlsToCenterAutoCode_Err
    
'Прверяем загружена ли форма
    For i = 0 To Forms.Count - 1
        If Forms(i).FormName = sFormName Then
            bIsLoaded = True
        End If
    Next

    If bIsLoaded = True Then DoCmd.Close acForm, sFormName, acSaveNo

    DoCmd.OpenForm sFormName, acDesign, "", "", , acHidden ' открываем форму в режиме Редакции
    Set frm = Forms(sFormName)

    
'Формируем ссылку на форму
    If bForNotCurrentForm = False Then
        sFormLink = "Me"
    Else
        sFormLink = "Forms(""" & frm.Name & """)"
    End If


'Ширина и высота формы:
    iNewFormWidth = frm.Width
    cMinFormWidthCm = Round(iNewFormWidth / cm, 4)
    iToFormMidHz = Round(iNewFormWidth / 2, 0) 'отступ слева до середины ФОРМЫ



'Суммарная высота заголовка и примечания формы acHeader acFooter
    If FormHasSections(frm) = True Then 'См функцию "FormHasSections" ниже ...
        If frm.Section(acHeader).Visible = True Then i = frm.Section(acHeader).Height     'Заголовок
        If frm.Section(acFooter).Visible = True Then i = i + frm.Section(acFooter).Height 'Примечание
    Else
        i = 0
    End If
    
    iNewFormHeight = frm.Section(0).Height + i
    c = Round(iNewFormHeight / cm, 2)
    cMinFormHeightCm = Round(c, 1)
    i = frm.Section(0).Height
    iToFormMidVr = Round(i / 2, 0) 'отступ сверху до середины ФОРМЫ
    
'Расчёт
    Debug.Print "'--------------------------------------------------------------------"
    Debug.Print "'Перемещение обьектов формы в центр:"
    Debug.Print "'(код автоматически создан процедурой ""ControlsToCenterAutoCode"" модуля ""modFormControlsToCenter"")"


        'Цикл по обработке всех обьектов формы
        'For Each ctrl In frm.Controls
        For Each ctrl In frm.Section(acDetail).Controls
            With ctrl
                'Расчёт горизонтальной поправки в твипах
                    
                c = ctrl.Left + Round(ctrl.Width / 2, 3)    'Отступ слева до середины контрола
                iСorrectionTwips = c - iToFormMidHz         'Поправка
                c = iСorrectionTwips / cm
                cСorrectionCm = Round(c, 3)
                sOne = CStr(Format(cMinFormWidthCm, "0.0"))
                sOne = Replace(sOne, ",", ".")
                sTwo = CStr(cСorrectionCm):   sTwo = Replace(sTwo, ",", ".")
                
                Debug.Print "   '" & ctrl.Name
                Debug.Print "    ControlToCenterHz " & sFormLink & ", " & sFormLink & "!" & ctrl.Name & ", " & sOne & ", " & sTwo
                
                'Расчёт вертикальной поправки в твипах
                c = ctrl.Top + Round(ctrl.Height / 2, 0)    'Отступ сверху до середины контрола
                iСorrectionTwips = c - iToFormMidVr         'Поправка
                c = iСorrectionTwips / cm
                cСorrectionCm = Round(c, 3)
                cСorrectionCm = cСorrectionCm + curPlusMinusToTopCm
                sOne = CStr(Format(cMinFormHeightCm, "0.0"))
                sOne = Replace(sOne, ",", ".")
                sTwo = CStr(cСorrectionCm)
                sTwo = Replace(sTwo, ",", ".")
                Debug.Print "    ControlToCenterVr " & sFormLink & ", " & sFormLink & "!" & ctrl.Name & ", " & sOne & ", " & sTwo
                DoEvents
            End With
    Next ctrl
    Debug.Print "'--------------------------------------------------------------------"

'--------------------------------------------------------------------
'Возвращаем свойство формы на место:
    DoCmd.OpenForm sFormName, acDesign, "", "", , acHidden
    Forms(sFormName).PopUp = False
    DoCmd.Close acForm, sFormName, acSaveYes
    
'Если изначально была загружена :
    If bIsLoaded = True Then DoCmd.OpenForm sFormName, acNormal  'Открываем снова

ControlsToCenterAutoCode_Bye:
    Set frm = Nothing
    Exit Sub

ControlsToCenterAutoCode_Err:
    MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "в процедуре: ControlsToCenterAutoCode", vbCritical, "Error!"
    Resume ControlsToCenterAutoCode_Bye

End Sub




Пример эксплуотации из примера


Private Sub Form_Resize()
'ControlsToCenterAutoCode "FormTest", False
'--------------------------------------------------------------------
'Маркер - Независимо от размеров формы точно по центру
    ControlToCenterHz Me, Me!LabelCentr, 0, 0
    ControlToCenterVr Me, Me!LabelCentr, 0, 0

'Кнопка cmdClose = По центру горизонтально'
    ControlToCenterHz Me, Me!cmdClose, 0, 0

'--------------------------------------------------------------------
'Перемещение обьектов формы в центр:
'(код автоматически создан процедурой "ControlsToCenterAutoCode" модуля "modFormControlsToCenter")
   'LabelInLeft
    ControlToCenterHz Me, Me!LabelInLeft, 13#, -3.24
    ControlToCenterVr Me, Me!LabelInLeft, 9#, -0.007
   'LabeInRight
    ControlToCenterHz Me, Me!LabeInRight, 13#, 3.24
    ControlToCenterVr Me, Me!LabeInRight, 9#, -0.007
   'LabelInBotom
    ControlToCenterHz Me, Me!LabelInBotom, 13#, 0.007
    ControlToCenterVr Me, Me!LabelInBotom, 9#, 1.219
   'LabelInTop
    ControlToCenterHz Me, Me!LabelInTop, 13#, 0.007
    ControlToCenterVr Me, Me!LabelInTop, 9#, -1.215

'--------------------------------------------------------------------

End Sub





Picture




Скачать

MSA-2007 ( 39 kB) Пример


Назад ToTop
L.E. 09.12.2016
Рейтинг@Mail.ru