Экспорт отчетов в HTML

Пока в моей программе отчёт, который нужно было посылать по емйлу, был один - я писал программульку 'конвертации индивидуально для него.
Но покупатели оценили возможность отправки отчёта по емейлу - причём в теле письма. Число отчётов теперь с катастрофической скоростью растёт - и приходится придумывать что-то хоть немного уиверсальное.

Причём крайне важно придумать что-то такое, чтоб чутко реагировало на зменения МАКЕТА отчётов.
Поддерживать-то программу надо... И кое-что я придумал. Может, это поможет и Вам.

Attribute VB_Name = "export_to_HTML"
Option Compare Database
Option Explicit
Public subreportHTML As String

' 1. Как нам обустроить экспорт
'---------------------------------
'У отчёта в Аксессе есть следующие области: заголовок, верхний колонтитул, данные, нижний колонтитул, примечание
'У всех у них сть событие "Форматирование" (Format). Именно на него имеет смысл вешать программу, преобразующую содержание
'области в HTML-код

'Все эти программы могут дописывать один и тот же файл.
'(Если Вы считаете, что умнее собирать код в переменную String -- я соглашусь, но напомню,
'что ЗДЕСЬ ВАМ НЕ ТУТ: в MS Access стринг-переменная в один не самый лучший момент просто перестаёт удлиняться, ничего не сообщая системе и Вашей программе)

'Итак, для областей отчёта нужна функция, пробегающая контролы и сохраняющая их содержание и оформление в HTML

'Напишем функцию section_to_HTML(), которая это сделает. Она преобразует секцию в DIV
'с абсолютной позицией, и внутри него спозиционирует все контролы

'В Аксессе есть полезные констаты для обозначения типов контрола:

'acBoundObjectFrame Присоединённая рамка объекта
'acCheckBox         Флажок
'acComboBox         Комбобокс (выпадающий список)
'acCommandButton    Кнопка
'acCustomControl    ActiveX (custom) control
'acImage            Картинка
'acLabel            надпись
'acLine             линия
'acListBox          список
'acObjectFrame      свободная рамка объекта
'acOptionButton     переключатель (Радиокнопка)
'acOptionGroup      группа элементов управления
'acPage             Page
'acPageBreak        Page break
'acRectangle        Прямоугольник
'acSubform          подчинённая форма/отчёт
'acTabCtl           Набор вкладок
'acTextBox          текстовое поле
'acToggleButton     переключатель ("залипающая" кнопка)

'2. Так начнём же функцию сию...
'----------------------------------

Function section_to_HTML(ByRef our_section As Section, ByVal n As Integer, ByVal top As Long, Optional ByRef output As String) As Long
'our_section -- заголовок или примечание
'n   -- дескриптор файла, в который пишем
'       Если равен нулю -- никуда не пишем
'top -- сколько отступить от начала страницы в твип (1мм=56.7 твип)
'       Эту величину придётся высчитывать в процессе формирования файла
'output --  В эту переменную собирается весь HTML-код секции
'           Рекомендуется использовать только для совсем маленьких секций:
'           переменная типа String вопреки документации может "переполниться"

On Error GoTo oblom

Dim html As String

html = vbCrLf & "<div style=""position:absolute;width:"
html = html & Int(our_section.Parent.width / 56.7) 'ширина отчёта в мм
html = html & "mm;height:" & Str(round(our_section.Height, 2)) & "mm"
html = html & ";top:" & top & "mm"
html = html & ";background-color:" & toRGB(our_section.BackColor)
html = html & """>" & vbCrLf

output = output & html
If (n <> 0) Then Print #n, html

'теперь пробегаем контролы
'Отсортируем их по возрастанию свойства TOP, а затем LEFT
'(сверху вниз и слева направо)
'Для этого загоним их в таблицу (чтоб с  массивами не бороться)

'Проверим, есть ли таблица tmpControls
Dim t As Dao.TableDef
Dim exists As Boolean
exists = False
For Each t In CurrentDb.TableDefs
    If t.Name = "tmpControls" Then
        exists = True
        Exit For
    End If
Next t

If exists Then 'Есть таблица
    CurrentDb.Execute ("delete from tmpControls")
Else 'Нет таблицы tmpControls. Сейчас будет
    
    Dim tbl As Dao.TableDef

    Set tbl = CurrentDb.CreateTableDef("tmpControls")
    
    With tbl
        .Fields.Append .CreateField("top_", dbLong) 'Чтоб отсортировать по отступу от верха
        .Fields.Append .CreateField("left_", dbLong) 'Чтоб отсортировать по отступу слева
        .Fields.Append .CreateField("controlName", dbText)
    End With
    
    CurrentDb.TableDefs.Append tbl
    CurrentDb.TableDefs.Refresh
End If

'Итак,таблица tmpControls с двумя полями у нас есть (в конце функции мы её... того..)
'заполним таблицу

Dim ctrl As Control
Dim p As Property
Dim query As String

For Each ctrl In our_section.Controls
    If (ctrl.Properties("Visible") = True) Then
        query = "insert into tmpControls (top_,left_,controlName)"
        query = query & " values (" & ctrl.Properties("Top") & "," & ctrl.Properties("Left") & ",'" & ctrl.Properties("Name") & "')"
        CurrentDb.Execute (query)
    End If
Next ctrl

Set ctrl = Nothing

'Итак,таблица tmpControls заполнена
'Пройдём по её записям

Dim rst As Dao.Recordset
Dim idx As String
Dim deltaTOP As Long
deltaTOP = 0

Set rst = CurrentDb.OpenRecordset("select * from tmpControls order by  top_,left_")
Do While Not rst.EOF
        idx = rst!ControlName
        Set ctrl = our_section.Parent.Controls(idx) 'Приходится "через верх" обращаться...
        Select Case ctrl.Properties("ControlType")
            Case acTextBox
                html = text_Box(ctrl, deltaTOP)
            Case acLabel
                html = label_Box(ctrl, deltaTOP)
            Case acComboBox
                html = combo_Box(ctrl, deltaTOP)
            Case acImage
                html = image_Box(ctrl, deltaTOP)
            Case acSubform
                html = subform_BOX(ctrl, deltaTOP)
            Case acLine
                html = line_BOX(ctrl, deltaTOP)
            Case acRectangle
                html = rect_BOX(ctrl, deltaTOP)
            
        
            Case Else
                'Признаться, мне просто пока незачем обрабатывать
                'остальные виды контролов
                'Если Вы испоьзуете что-то кроме перечисленного --
                'Вам придётся попрограммировать, взяв за основу
                'text_Box() и др.
                html = ""
        End Select
        output = output & html
        If (n <> 0) Then Print #n, html
        rst.MoveNext
Loop

rst.Close

'Прибьем таблицу
CurrentDb.TableDefs.Delete ("tmpControls")
        
'закроем ДИВ
html = vbCrLf & "</div>" & vbCrLf
output = output & html
If (n <> 0) Then Print #n, html

section_to_HTML = our_section.Properties("Height") / 56.7 + deltaTOP + 2
Exit Function
oblom:
section_to_HTML = False

End Function

'-----------------------------
'Ну а теперь -- вспомогательные функции
'-----------------------------

'перевод цвета в формате Access в RGB
Function toRGB(ByVal color As Long) As String
Dim r As Long
Dim g As Long
Dim b As Long

b = color \ 256 \ 256
g = (color - b * 256 * 256) \ 256
r = color - b * 256 * 256 - g * 256

toRGB = "#"

If (Len(Hex(r)) = 1) Then toRGB = toRGB & "0"
toRGB = toRGB & Hex(r)
If (Len(Hex(g)) = 1) Then toRGB = toRGB & "0"
toRGB = toRGB & Hex(g)
If (Len(Hex(b)) = 1) Then toRGB = toRGB & "0"
toRGB = toRGB & Hex(b)

End Function

Function text_Box(ctrl As Control, ByRef deltaTOP As Long) As String
On Error GoTo oblom
Dim html As String
html = vbCrLf & "<div style=""position:absolute;top:"
html = html & Str(round(((ctrl.Properties("Top") / 56.7) + deltaTOP), 2))
html = html & "mm;left:"
html = html & Str(round(ctrl.Properties("Left") / 56.7, 2))
html = html & "mm"
html = html & ";font-size:" & ctrl.Properties("FontSize") & "pt"
html = html & ";font-family:" & ctrl.Properties("FontName")
html = html & ";color:" & toRGB(ctrl.Properties("ForeColor"))

If (ctrl.Properties("BackStyle") = 1) Then 'Тип фона -- обычный
    html = html & ";background-color:" & toRGB(ctrl.Properties("BackColor"))
End If

html = html & ";text-align:"

Select Case (ctrl.Properties("TextAlign"))
    Case 0, 1
        html = html & "left"
    Case 2
        html = html & "center"
    Case 3
        html = html & "right"
End Select

'Есть ли граница?
html = html & ";border:"
If (ctrl.Properties("BorderStyle") = 0) Then
        html = html & "none"
Else
    html = html & ctrl.Properties("BorderWidth") & "px solid "
    html = html & toRGB(ctrl.Properties("BorderColor "))
    html = html & ";padding:2px"
End If

html = html & ";width:" & Int(ctrl.Properties("Width") / 56.7) & "mm"
If (ctrl.Properties("FontItalic") = True) Then
    html = html & ";font-style:italic"
End If

If (ctrl.Properties("FontWeight") >= 600) Then
    html = html & ";font-weight:bold"
End If

If (ctrl.Properties("FontUnderline") = True) Then
    html = html & ";text-decoration:underline"
End If

'А теперь проверим: не расширилось ли поле
If ctrl.Properties("CanGrow") Then 'Если поле может расширяться
    'Прикинем (грубо!), насколько поле расширилось
    'используемые функции можно со временем улучшать
    Dim w, h As Integer
    w = charWidth(ctrl)     'Ширина символа
    h = charHeight(ctrl)    'Высота символа
    
    'Сколько строк будет в "штатном" размере?
    Dim rows_plan As Integer
    rows_plan = Int(ctrl.Properties("Height") / 56.7 / h) + 1
    'Debug.Print "rows_plan=" & rows_plan
    
    'Сколько строк будет реально? Можем только гадать:
    Dim rows_real As Integer
    rows_real = Len(ctrl.Properties("Text")) / (Int(ctrl.Properties("Width") / 56.7 / w) - 3) + 1
    'Debug.Print "Len(ctrl.Properties(""Text""))=" & Len(ctrl.Properties("Text")) & ", w=" & w & ", rows_real=" & rows_real
    'зададим смещение
    deltaTOP = deltaTOP + Max((rows_real - rows_plan) * h, 1)
End If

html = html & ";height:" & Int(ctrl.Properties("Height") / 56.7) + deltaTOP & "mm"
html = html & """>"
html = html & replace(ctrl.Properties("Text"), vbCrLf, "<br />")
html = html & "</div>"

text_Box = html

Exit Function
oblom:
Resume Next
End Function
'Опрделяем высоту символа в мм по размеру кегля (как умеем :( )
Function charHeight(ctrl As Control) As Integer
charHeight = Int(ctrl.Properties("FontSize") / 2.5)
End Function
'Опрделяем ширину символа в мм по размеру кегля (как умеем :( )
Function charWidth(ctrl As Control) As Integer
charWidth = Int(ctrl.Properties("FontSize") / 3)
End Function

Function label_Box(ctrl As Control, ByRef deltaTOP As Long) As String
On Error GoTo oblom
Dim html As String
html = vbCrLf & "<div style=""position:absolute;top:"
html = html & Str(round((ctrl.Properties("Top") / 56.7) + deltaTOP, 2))

html = html & "mm;left:"
html = html & Str(round(ctrl.Properties("Left") / 56.7, 2))
html = html & "mm"
html = html & ";font-size:" & ctrl.Properties("FontSize") & "pt"
html = html & ";font-family:" & ctrl.Properties("FontName")
html = html & ";color:" & toRGB(ctrl.Properties("ForeColor"))

If (ctrl.Properties("BackStyle") = 1) Then 'Тип фона -- обычный
    html = html & ";background-color:" & toRGB(ctrl.Properties("BackColor"))
End If

html = html & ";text-align:"

Select Case (ctrl.Properties("TextAlign"))
    Case 0, 1
        html = html & "left"
    Case 2
        html = html & "center"
    Case 3
        html = html & "right"

End Select

'Есть ли граница?
html = html & ";border:"
If (ctrl.Properties("BorderStyle") = 0) Then
        html = html & "none"
Else
    html = html & ctrl.Properties("BorderWidth") & "px solid "
    html = html & toRGB(ctrl.Properties("BorderColor "))
    html = html & ";padding:2px"
End If

html = html & ";width:" & Int(ctrl.Properties("Width") / 56.7) & "mm"
If (ctrl.Properties("FontItalic") = True) Then
    html = html & ";font-style:italic"
End If

If (ctrl.Properties("FontWeight") >= 600) Then
    html = html & ";font-weight:bold"
End If
If (ctrl.Properties("FontUnderline") = True) Then
    html = html & ";text-decoration:underline"
End If

html = html & ";height:" & Int(ctrl.Properties("Height") / 56.7) & "mm"
html = html & """>"
html = html & replace(ctrl.Properties("Caption"), vbCrLf, "<br />")

html = html & "</div>"

label_Box = html

Exit Function
oblom:
Resume Next
End Function
Function combo_Box(ctrl As Control, ByRef deltaTOP As Long) As String
On Error GoTo oblom
Dim html As String
html = vbCrLf & "<div style=""position:absolute;top:"
html = html & Str(round(((ctrl.Properties("Top") / 56.7) + deltaTOP), 2))
html = html & "mm;left:"
html = html & Str(round(ctrl.Properties("Left") / 56.7, 2))
html = html & "mm"
html = html & ";font-size:" & ctrl.Properties("FontSize") & "pt"
html = html & ";font-family:" & ctrl.Properties("FontName")
html = html & ";color:" & toRGB(ctrl.Properties("ForeColor"))

If (ctrl.Properties("BackStyle") = 1) Then 'Тип фона -- обычный
    html = html & ";background-color:" & toRGB(ctrl.Properties("BackColor"))
End If

html = html & ";text-align:"

Select Case (ctrl.Properties("TextAlign"))
    Case 0, 1
        html = html & "left"
    Case 2
        html = html & "center"
    Case 3
        html = html & "right"

End Select

'Есть ли граница?
html = html & ";border:"
If (ctrl.Properties("BorderStyle") = 0) Then
        html = html & "none"
Else
    html = html & ctrl.Properties("BorderWidth") & "px solid "
    html = html & toRGB(ctrl.Properties("BorderColor "))
End If

html = html & ";width:" & Int(ctrl.Properties("Width") / 56.7) & "mm"
If (ctrl.Properties("FontItalic") = True) Then
    html = html & ";font-style:italic"
End If

If (ctrl.Properties("FontWeight") >= 600) Then
    html = html & ";font-weight:bold"
End If
If (ctrl.Properties("FontUnderline") = True) Then
    html = html & ";text-decoration:underline"
End If

html = html & ";height:" & Int(ctrl.Properties("Height") / 56.7) & "mm"
html = html & """>"

'Узнаём, что выбрано в поле
'Для этого посмотрим, сколько колонок в списке и ширина каких из них не равна нулю
Dim cols As Integer
cols = ctrl.Properties("ColumnCount")
Dim i As Integer
Dim txt, ColumnWidths, token As String
txt = ""
ColumnWidths = ctrl.Properties("ColumnWidths")
    'Debug.Print " * * * "
For i = 0 To (cols - 1)
    'Debug.Print ColumnWidths
    If (InStr(1, ColumnWidths, ";") <> 0) Then
        token = Trim(left(ColumnWidths, InStr(1, ColumnWidths, ";") - 1))
    Else
        token = ColumnWidths
    End If
    'Debug.Print token
    If (token <> "0") Then
        txt = ctrl.column(i, ctrl.Properties("ListIndex"))
        Exit For
    End If
    ColumnWidths = Mid(ColumnWidths, InStr(1, ColumnWidths, ";") + 1)
    'Debug.Print ColumnWidths
Next i
    'Debug.Print " * * * "

html = html & txt
html = html & "</div>"

combo_Box = html

Exit Function
oblom:
Resume Next
End Function
Function image_Box(ctrl As Control, ByRef deltaTOP As Long) As String
On Error GoTo oblom
Dim html As String
html = vbCrLf & "<div style=""position:absolute;top:"
html = html & Int(ctrl.Properties("Top") / 56.7) + deltaTOP
html = html & "mm;left:"
html = html & Int(ctrl.Properties("Left") / 56.7)
html = html & "mm"

'Есть ли граница?
html = html & ";border:"
If (ctrl.Properties("BorderStyle") = 0) Then
        html = html & "none"
Else
    html = html & ctrl.Properties("BorderWidth") & "px solid black"
End If

html = html & ";width:" & Int(ctrl.Properties("Width") / 56.7) & "mm"
html = html & ";height:" & Int(ctrl.Properties("Height") / 56.7) & "mm"

html = html & ";height:" & Int(ctrl.Properties("Height") / 56.7) & "mm"
html = html & """>"

'А теперь, собственно, картинка

html = html & vbCrLf & "<img src="""

Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
html = html & fs.GetFileName(ctrl.Picture)
html = html & """"

html = html & " style="""
html = html & "width:" & Int(ctrl.Properties("Width") / 56.7) & "mm"
html = html & ";height:" & Int(ctrl.Properties("Height") / 56.7) & "mm"
html = html & """"

html = html & ">"
html = html & "</div>"

image_Box = html

Exit Function
oblom:
Resume Next
End Function

Function subform_BOX(ctrl As Control, ByRef deltaTOP As Long) As String
'Мои подчинённые отчёты уже знают, что они будут подчинёнными
'Поэтому они на открытие помещают свой ХТМЛ-код в глобальную переменную subreportHTML,
'Для чего можно использовать section_to_html без записи в файл, например:
'    subreportHTML = ""
'    Call section_to_HTML(DataField, 0, 0, subreportHTML)
'Где DataField -- присвоенное мной имя области данных (если подчинённый отчёт состоит только из неё)

On Error GoTo oblom
Dim html As String
html = vbCrLf & "<div style=""position:absolute;top:"
html = html & Int(ctrl.Properties("Top") / 56.7) + deltaTOP
html = html & "mm;left:"
html = html & Int(ctrl.Properties("Left") / 56.7)
html = html & "mm"

'Есть ли граница?
html = html & ";border:"
If (ctrl.Properties("BorderStyle") = 0) Then
        html = html & "none"
Else
    html = html & ctrl.Properties("BorderWidth") & "px solid black"
End If
html = html & """>"
html = html & subreportHTML

html = html & "</div>"

subform_BOX = html

Exit Function
oblom:
Resume Next
End Function

Function line_BOX(ctrl As Control, ByRef deltaTOP As Long) As String

On Error GoTo oblom
Dim html As String
html = vbCrLf & "<div style=""position:absolute;top:"
html = html & Int(ctrl.Properties("Top") / 56.7) + deltaTOP
html = html & "mm;left:"
html = html & Int(ctrl.Properties("Left") / 56.7)
html = html & "mm"

If (Int(ctrl.Properties("Width")) = 0) Then
    html = html & ";width:"
    html = html & ctrl.Properties("BorderWidth") + 1
    html = html & "mm"
    html = html & ";height:"
    html = html & Str(round((ctrl.Properties("Height") / 56.7), 2))
    html = html & "mm"
    html = html & ";border-left:" & ctrl.Properties("BorderWidth") & "px solid "
    html = html & toRGB(ctrl.Properties("BorderColor"))
ElseIf (Int(ctrl.Properties("Height")) = 0) Then
    html = html & ";width:"
    html = html & Str(round((ctrl.Properties("Width") / 56.7), 2))
    html = html & "mm"
    html = html & ";height:"
    html = html & ctrl.Properties("BorderWidth") + 1
    html = html & "mm"
    html = html & ";border-top:" & ctrl.Properties("BorderWidth") & "px solid "
    html = html & toRGB(ctrl.Properties("BorderColor"))
Else
    'Надеюсь не увидеть в своих отчётах косые линии
    'Увижу -- буду гиф вставлять :(
End If

html = html & """></div>"

line_BOX = html

Exit Function
oblom:
Resume Next
End Function

Function rect_BOX(ctrl As Control, ByRef deltaTOP As Long) As String

On Error GoTo oblom
Dim html As String
html = vbCrLf & "<div style=""position:absolute;top:"
html = html & Int(ctrl.Properties("Top") / 56.7) + deltaTOP
html = html & "mm;left:"
html = html & Int(ctrl.Properties("Left") / 56.7)
html = html & "mm"

html = html & ";width:"
html = html & Str(round((ctrl.Properties("Width") / 56.7), 2))
html = html & "mm"

html = html & ";height:"
html = html & Str(round((ctrl.Properties("Height") / 56.7), 2))
html = html & "mm"

html = html & ";border:" & ctrl.Properties("BorderWidth") & "px solid "
html = html & toRGB(ctrl.Properties("BorderColor"))

If (ctrl.Properties("BackStyle") = 1) Then 'Тип фона -- обычный
    html = html & ";background-color:" & toRGB(ctrl.Properties("BackColor"))
End If

html = html & """></div>"

rect_BOX = html

Exit Function
oblom:
Resume Next
End Function

'---------------------------
'3. Как это всё использовать
'---------------------------

'Думаю,  к концу этого эссе Вы уже забыли, с чего мы начали :)

'Напомню: мы хотели отчёт в HTML перегнать

' -= Делай-раз =-.
'В модуле отчёта, который хотим экспортнуть в HTML, длаем две глобальные переменные --
'1. дескриптор файла
'2. Отступ следующго ДИВа.

'Например:
'Dim n As Long
'Dim nextTOP As Long
'
' -= Делай-два =-.
'На событие ОТКРЫТИЕ отчёта, который хотим экспортнуть в HTML,
'Вешаем что-то вроде

'n = FreeFile
'Open "c:\test.html" For Output As #n
'Print #n, "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.0 Transitional//EN"">"
'Print #n, "<html><head></head><body>"
'nextTOP=0

' -= Делай-три =-.
'На событие ФОРМАТИРОВАНИЕ всех областей отчёта вешаете
'nextTOP = nextTOP+section_to_HTML(reportTitle, n, nextTOP)

' -= Делай-четыре =-.

'Событие ФОРМАТИРОВАНИЕ примечания отчёта закончите так:
'Print #n, "</body></html>"
'Close #n

'---------------------------
'4. Ну и что в итоге?
'---------------------------

'В итоге получается файл на диске, содержащий HTML-код отчёта. Проблем аж две:

'1. Подогнанные вплотную элементы отчёта в HTML иногда разделяются маленькими,
'   но заметными щелями. ЛЕЧИТСЯ корректировкой макета -- небольшим (не более 0.5 мм) "наезжанием"
'   правой области  на левую (затем левую область нужно вынести на первый план)
'2. Случается, что ДИВы разных областей отчёта немного налезают друг на друга.
'   ЛЕЧИТСЯ корректировкой третьего параметра функции section_to_HTML для нижней области,
'   отвечающего за отступ области от верхнего края

'Все проблемы лечатся в худшем случае несколькими минутами работы с HTML-кодом.

'Но зато получившийся результат можно быстро и легко послать по e-mail.
'Или подготовить HTML-страничку для выкладывания на сайт