Форумы HiProg.com - MS ACCESS, VBA, VB

ник: Дядя Федор

Public Function SetFont2(con As Control, Optional maxFontSize As Integer = 14, Optional minFontSize As Integer = 6)     On Error Resume Next     Dim Cch As Long     Dim MaxWidthCch As Long     Dim dx As Long     Dim dy As Long     Dim txt As String     Dim tmpFontSize As Integer     Dim Rows As Integer     Dim WidthControl As Long     Dim HeightControl As Long     'только для TextBox или Label     'If Not (con.ControlType = acTextBox Or con.ControlType = acLabel) Then Exit Function     'ширина и высота контрола     WidthControl = con.Width - (con.LeftMargin + con.RightMargin)     HeightControl = con.Height - (con.TopMargin + con.BottomMargin)     'получим размер всей строки     Select Case con.ControlType         Case acTextBox             txt = con.Value         Case acLabel             txt = con.Caption     End Select         WizHook.key = 51488399 'инит визхука     tmpFontSize = maxFontSize     Do         If Not WizHook.TwipsFromFont(con.FontName, tmpFontSize, con.FontWeight, con.FontItalic, _                                  con.FontUnderline, Cch, txt, MaxWidthCch, _                                  dx, dy) Then Exit Function         'получаем число строк                   Rows = dx / WidthControl        '  ''Debug.print tmpFontSize, con.FontName, tmpFontSize, dx, WidthControl         If Rows >= 1 Then 'в одну строку не влезли :(             'If (Rows * dy + ((Rows - 1) * dy / 3)) > HeightControl Then                 'уменьшаем фонт                 tmpFontSize = tmpFontSize - 1           '      ''Debug.print "-", tmpFontSize, con.FontName, tmpFontSize             Else                 'Все четко!                 Exit Do             'End If         End If     Loop While tmpFontSize > minFontSize     con.FontSize = tmpFontSize End Function

Пример

Private Sub Имяраздела_Format(Cancel As Integer, FormatCount As Integer) Me.NaimPrice.FontSize = 12 ' - устанавливаем шрифт SetFont2 Me.NaimPrice, 12, 6 End Sub