MyTetra Share
Делитесь знаниями!
Элементы формы - Выравнивание по центру при изменении размеров формы
16.03.2019
23:43
Раздел: !Закладки - VBA - Access - msa.polarcom.ru - 05 Формы

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

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

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








Picture




Скачать

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

Прикрепленные файлы:
Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования