VBA, MS Access MS Access в примерах

Линии подчёркивания сразу под всеми полями (TextBox-ами) раздела отчёта

Подробности:
  ControlType Property:
  https://msdn.microsoft.com/en-us/library/office/aa224135%28v=office.11%29.aspx
  Report.Line Method:
  https://msdn.microsoft.com/en-us/library/office/ff198297.aspx

Рисуем линии подчёркивания под всеми TextBox-ами любого раздела отчёта (или только с определённым префиксом в названии)
Сильно экономит время при создании отчётов с подчёркнутыми полями: СФ, ТОРГ-12, УПД и т.п.


Public Sub RepFieldsUnderLine(objReportSection As Section, Optional strFieldPrefix As String = "", Optional lColor&)
'es - 01.06.2016 - 08.12.2017 L.E.
'Рисуем линии подчёркивания под всеми TextBox-ами любого раздела отчёта 
'(или только с опред. префиксом в названии)
'--------------------------------------------------------------------------
'Аргументы:
'   objReportSection - ссылка на раздел отчёта
'   strFieldPrefix   - Префикс названий элементов - не обязательный, и при пропуске
'                      - будут обработаны все элементы типа TextBox (Текстовое поле)
'   lColor           - Цвет (По умолчанию = 0 чёрный)
'--------------------------------------------------------------------------
'Вешается на событие Print (Печать) любой области отчета - например так:
'   RepFieldsUnderLine ReportFooter, "txt"
'   - Будут подчёркнуты все TextBox-ы с "txt" в начале названия элемента
'--------------------------------------------------------------------------

Dim objCtrl As Control        'обьект элемент управления
Dim StartX As Integer         'координата начала линии по оси X
Dim EndX As Integer           'координата конца линии по оси X
Dim StartY As Integer         'координата начала линии по оси Y
Dim EndY As Integer           'координата конца линии по оси Y
Dim l As Integer              'Длина префикса (если указан)

On Error GoTo RepFieldsUnderLine_Err
    If strFieldPrefix <> "" Then
        l = Len(strFieldPrefix) 'Длина префикса (если указан)
    End If
    
    With objReportSection
        .Parent.DrawWidth = 1   'Толщина линии (тут можно поиграться если нужно) _
                                 по умолчанию = 1 (...The default is 1, or 1 pixel wide.)
        'Перебор всех элементов внутри раздела отчёта
        For Each objCtrl In .Controls
            If objCtrl.ControlType = acTextBox Then 'Только если это TextBox
                'если это текстовое с указанным префиксом в названии
                If Mid(objCtrl.Name, 1, l) = strFieldPrefix Then
                    ' Координаты начала и конца по оси X
                    StartX = objCtrl.Left
                    EndX = StartX + objCtrl.Width
                    ' Координаты начала и конца по оси Y
                    StartY = objCtrl.Top + objCtrl.Height
                    EndY = StartY
                    ' Рисуем горизонтальную под текущим TextBox-ом
                    .Parent.Line (StartX, EndY)-(EndX, EndY), lColor
                End If
            End If
        Next
    End With

RepFieldsUnderLine_Bye:
    Exit Sub

RepFieldsUnderLine_Err:
    'MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "в процедуре: RepFieldsUnderLine", vbCritical, "Error in module modReports"
    Err.Clear
    Resume RepFieldsUnderLine_Bye
End Sub


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


Private Sub Detail_Print(Cancel As Integer, PrintCount As Integer)
Dim lColor&
    'lColor = RGB(127, 127, 127) ' Тёмно-Серый
    lColor = RGB(172, 181, 191) ' Светлее
    RepFieldsUnderLine Detail, "txt", lColor

End Sub


Private Sub ReportHeader_Print(Cancel As Integer, PrintCount As Integer)
'Заголовок отчёта (Header):
'Линии под полями с префиксом txt
    RepFieldsUnderLine ReportHeader, "txt"
End Sub


Private Sub ReportFooter_Print(Cancel As Integer, PrintCount As Integer)
'Примечание отчёта (Footer):
'Линии под полями с префиксом txt
    
    RepFieldsUnderLine ReportFooter, "txt"
End Sub


В результате - все поля в заголовке и примечании отчёта подчёркнуты.

Picture

Результат виден только в режиме Print Preview т.к. иначе событие Print не возникает.

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