Горизонтальная построчная разлиновка многострочного TextBox в отчёте

По материалам: http://www.cyberforum.ru/ms-access/thread2368371.html

'--------------------------------------------------------------------------
' Module    : modReportLinedTextBox
' Author    : shanemac51 + es(допилил малость)
' Date      : 14.12.2018
' Purpose   : Горизонтальная построчная разлиновка TextBox Control
'             * Цвет линии берётся из своиств поля!
'--------------------------------------------------------------------------
'http://www.cyberforum.ru/ms-access/thread2368371.html
'--------------------------------------------------------------------------
'Работает на событии PRINT области данных отчета - например так:
'   Private Sub ОбластьДанных_Print(Cancel As Integer, PrintCount As Integer)
'       LinedTextBoxControl Me.ОбластьДанных, Me!txtText
'   End Sub
'--------------------------------------------------------------------------
Private Const iFixLineH As Integer = 0      ' Поправка на высоту строки! (эксперементальным путём)
Private Const iFixLineT As Integer = -60    ' Поправка на TOP первой строки раздела! (эксперементальным путём)

Private Type utCtrlParameters 'Пользовательский тип с характеристиками поля : высота, ширина и пр ...
    iLeft As Integer
    iTop As Integer
    iWidth As Integer
    iHeight As Integer
    lColor As Long
    iLineHeight As Integer
    iTopMargin As Integer
    iBottomMargin As Integer
    iLineSpacing As Integer
    iLines As Integer
End Type

Public Sub LinedTextBoxControl(objReportSection As Section, ByRef ctrl As Control)
'Собственно разлиновка контрола переданного в аргументе (кроме последней строки)
'--------------------------------------------------------------------------
'Аргументы:
'   objReportSection = Сылка на секцию отчёта
'   ctrl             = Ссылка на поле подлежащие построчной разлиновке
'--------------------------------------------------------------------------
Dim i%, k%
Dim CtrlSZ As utCtrlParameters
Dim x%, y%
On Error GoTo LinedTextBoxControl_Err

    CtrlSZ = GetCtrlParam(ctrl) 'взяли параметры поля в переменную пользовательского типа ...
   
    With objReportSection
        'Разлиновка контрола построчно
        k = CtrlSZ.iTopMargin + CtrlSZ.iTop '+
        
        If CtrlSZ.iLines > 1 Then 'только если больше одной строки
            For i = 1 To CtrlSZ.iLines - 1 'кроме последней! там уже будет бордер контрола
                k = k + CtrlSZ.iLineHeight
                'If i = 1 Then k = k + CtrlSZ.iTopMargin 'На первой строке + отступ сверху
                'Пишем линию: Parent.Line (StartX, EndY)-(EndX, EndY), Color
                .Parent.Line (CtrlSZ.iLeft, k)-(CtrlSZ.iLeft + CtrlSZ.iWidth, k), CtrlSZ.lColor  '255
            Next i
        End If
        
        'Border вокруг контрола (если нужно) - но! контрол чутка выше чем надо обычно.
        '   - значит нижняя граница расчётная а не фактическая
        'Учтанови! : ctrl.BorderStyle = 0 '0 = Transporent! ...
        
        'рисуем горизонтальную над контролом
        x = CtrlSZ.iLeft + CtrlSZ.iWidth
        .Parent.Line (CtrlSZ.iLeft, CtrlSZ.iTop)-(x, CtrlSZ.iTop), CtrlSZ.lColor
        
        'рисуем вертикальную слева
        y = CtrlSZ.iTop + CtrlSZ.iHeight
        .Parent.Line (CtrlSZ.iLeft, CtrlSZ.iTop)-(CtrlSZ.iLeft, y), CtrlSZ.lColor
        
        'теперь вертикальная справа от контрола
        x = CtrlSZ.iLeft + CtrlSZ.iWidth
        y = CtrlSZ.iTop + CtrlSZ.iHeight
        .Parent.Line (x, CtrlSZ.iTop)-(x, y), CtrlSZ.lColor
        
        'рисуем горизонтальную под контролом (выше фактической границы)
        y = CtrlSZ.iTop + CtrlSZ.iHeight
        x = CtrlSZ.iLeft + CtrlSZ.iWidth
        .Parent.Line (CtrlSZ.iLeft, y)-(x, y), CtrlSZ.lColor ' 255
    End With

LinedTextBoxControl_End:
    On Error Resume Next
    Err.Clear
    Exit Sub

LinedTextBoxControl_Err:
    Debug.Print "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf
    Resume LinedTextBoxControl_End
End Sub
Private Function GetCtrlParam(ctrl As Control) As utCtrlParameters
'es 14.12.2018
'Возвращает параметры заданного контрола
'--------------------------------------------------------------------------
Dim x%
On Error GoTo GetCtrlParam_Err
    
    GetCtrlParam.iLeft = ctrl.Left
    GetCtrlParam.iTop = ctrl.Top
    GetCtrlParam.iWidth = ctrl.Width
    GetCtrlParam.iHeight = ctrl.Height
    GetCtrlParam.lColor = ctrl.BorderColor
    x = GetControlLineHeight(ctrl)
    GetCtrlParam.iLineHeight = x 'высота строки по GetControlLineHeight
    GetCtrlParam.iTopMargin = ctrl.TopMargin
    GetCtrlParam.iBottomMargin = ctrl.BottomMargin
    GetCtrlParam.iLineSpacing = ctrl.LineSpacing
    
'Кол-во строк расчётное по высоте строки:
    x = ctrl.Height \ GetCtrlParam.iLineHeight
    GetCtrlParam.iLines = x 'Записали кол-во строк

'Внимание! Высота поля по расчётной высоте строки
    GetCtrlParam.iHeight = x * GetCtrlParam.iLineHeight
    x = GetCtrlParam.iTop

'Учли поправку на Top контрола (смотри константу iFixLineT вверху !)
    x = x + iFixLineT
    If x < 0 Then x = 0
    GetCtrlParam.iTop = x 'Top контрола (верхней границы первой строки)
    
GetCtrlParam_End:
    On Error Resume Next
    Err.Clear
    Exit Function

GetCtrlParam_Err:
    Debug.Print "Error: " & Err.Number & vbCrLf & Err.Description
    Err.Clear
    Resume GetCtrlParam_End
End Function

Private Function GetControlLineHeight(ctrl As Control) As Integer
'Возвращает высоту строки с учётом шрифта и LineSpacing
'   + учитывается поправка iFixLineH на высоту строки (смотри константу iFixLineH вверху !)
'--------------------------------------------------------------------------
' twips (twip: Unit of measurement that is equal to 1/20 of a point, _
    or 1/1,440 of an inch. There are 567 twips in a centimeter.).
'--------------------------------------------------------------------------
Dim iLineH%, iLines%, x%, a%
    iLineH = WizHook_TwipsFromFont(ctrl)

    iLineH = iLineH + ctrl.LineSpacing
    
'Поправка на высоту строки (смотри константу iFixLineH вверху !)
    iLineH = iLineH + iFixLineH
    GetControlLineHeight = iLineH

End Function

Private Function WizHook_TwipsFromFont(ctrl As Control, Optional sText$ = "", Optional iWhatReturn = 0) As Long 'wzCaption
'   Возврашает высоту или длинну текста в контроле в твипах
'   в звисимости от параметра:
'   iWhatReturn
'       0 =  Высота
'       1 =  Длинна
'--------------------------------------------------------------------------
  Dim wzFontName As String
  Dim wzSize As Long
  Dim wzWeight As Long
  Dim wzItalic As Boolean
  Dim wzUnderline As Boolean
  Dim wzCch As Long
  Dim wzCaption As String
  Dim wzMaxWidthCch As Long
  Dim wzdx As Long
  Dim wzdy As Long

On Error GoTo WizHook_TwipsFromFont_Err
    WizHook.Key = 51488399
    
    wzFontName = ctrl.FontName '"Arial"
    wzSize = ctrl.FontSize
    wzWeight = ctrl.FontWeight
    wzItalic = ctrl.FontItalic
    wzUnderline = ctrl.FontUnderline
    
    If sText <> "" Then
        wzCaption = sText
    Else
        wzCaption = ctrl.Text
    End If
    WizHook.TwipsFromFont wzFontName, wzSize, wzWeight, _
                          wzItalic, wzUnderline, wzCch, _
                          wzCaption, wzMaxWidthCch, _
                          wzdx, wzdy

'    If wzdx > 2500 Then
'        Debug.Print "Ширина в твипах: " & wzdx
'        Debug.Print "Высота в твипах: " & wzdy
'    End If
    Select Case iWhatReturn
        Case 0
        WizHook_TwipsFromFont = wzdy
        Case Else
        WizHook_TwipsFromFont = wzdx
    End Select

WizHook_TwipsFromFont_End:
    On Error Resume Next
    Err.Clear
    Exit Function

WizHook_TwipsFromFont_Err:
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in Function: WizHook_TwipsFromFont in module: modReports", vbCritical, "Error in Application"
    Err.Clear
    Resume WizHook_TwipsFromFont_End
End Function

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