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

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

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

' Выводит в Immediate 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

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