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

msa.dimsign.ru

Администратор

MS Access 2000, под которым я сейчас сижу - достойный памятник тех времён, когда один известный человек думал, что Интернет "малоперспективен". Через то самое место, которым он в этот момент думал, в MS Access 2000 сделаны и экспорт в 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 & "

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 & "

" & 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 & "

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, "
")
html = html & "

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 & "

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 & ";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, "
")

html = html & "

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 & "

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 & ";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 & "

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 & "

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 & "

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 & "

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 & "

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 & "

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 & "

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 & """>

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 & "

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 & """>

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, ""
'Print #n, ""
'nextTOP=0

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

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

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

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

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

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

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

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

Страница сайта http://silicontaiga.ru
Оригинал находится по адресу http://silicontaiga.ru/home.asp?artId=5715