Вымучил небольшую функцию для преобразования: - значений - частично размера шрифта - наклона и толщины шрифта - названия шрифта - цвета фона и шрифта из непрерывного диапазона ячеек в текстовую строку в виде HTML кода для дальнейшей вставки HTMLbody письма Outlook. Или иными словами - функция для пост.обработки диапазона в HTML для вставки таблицы в тело письма.
Собственно функция:
Скрытый текст
Код
Function RangeToHTML(RR As Range) As String
Dim dt$, a&, b&, c&, aa(), t$, MM(), m&, tt$(), q&
Dim t0$, t1$, t2$, t3$, n&, ro%, co%, dd()
'---------------------------------
ReDim aa(1 To RR.Columns.Count)
ReDim MM(1 To RR.Rows.Count, 1 To RR.Columns.Count)
For a = 1 To RR.Rows.Count
For b = 1 To RR.Columns.Count
If RR(a, b).MergeCells And Len(MM(a, b)) = 0 Then
For ro = a To RR(a, b).MergeArea.Rows.Count + a - 1
For co = b To RR(a, b).MergeArea.Columns.Count + b - 1: MM(ro, co) = "*": Next
Next
MM(a, b) = RR(a, b).MergeArea.Rows.Count & ";" & RR(a, b).MergeArea.Columns.Count
End If
If RR(a, b).NumberFormat <> "General" Then
t2 = Format(RR(a, b), RR(a, b).NumberFormat)
Else: t2 = RR(a, b)
End If
If Len(t2) > aa(b) Then aa(b) = Len(t2)
Next
Next
dt = "<html xmlns:v=""urn:schemas-microsoft-com:vml"" xmlns:o=""urn:schemas-microsoft-com:office:office""": wtArr tt, q, dt
dt = "xmlns:x=""urn:schemas-microsoft-com:office:excel"" xmlns=""http://www.w3.org/TR/REC-html40"">": wtArr tt, q, dt
dt = "<head><meta http-equiv=Content-Type content=""text/html; charset=windows-1251"">": wtArr tt, q, dt
dt = "<meta name=ProgId content=Excel.Sheet>": wtArr tt, q, dt
dt = "<meta name=Generator content=""Microsoft Excel 15""></head>": wtArr tt, q, dt
dt = "<body><table style=""border-collapse: collapse; "">": wtArr tt, q, dt
For a = 1 To RR.Rows.Count
dt = "<tr height=""" & Int(RR(a, b).Height) & """>": wtArr tt, q, dt
For b = 1 To RR.Columns.Count
c = RR(a, b).Interior.Color: t = PreHEX(c): t2 = vbNullString
m = RR(a, b).HorizontalAlignment: t3 = t2: n = RR(a, b).Width
Select Case m 'выравнивание по горизонтали
Case Is = -4131: t1 = """left"""
Case Is = -4108: t1 = """center"""
Case Is = -4152: t1 = """right"""
Case Is = 1: t1 = """justify"""
End Select
If Len(RR(a, b)) = 0 Then t2 = "width=""" & Int(n + n * 0.05) & """ "
If InStr(MM(a, b), ";") Then 'проверка на совмещенность ячеек
ro = Split(MM(a, b), ";")(0): co = Split(MM(a, b), ";")(1)
t2 = t2 & " rowspan=""" & ro & """ colspan=""" & co & """;"
End If
If MM(a, b) <> "*" Then 'проверка на совмещенность ячеек
dd = Array("-left:", "-right:", "-top:", "-bottom:"): t3 = "margin: 0px 2px 0px 2px;" 'отступы
If RR(a, b).IndentLevel > 0 Then t3 = t3 & " text-indent:" & RR(a, b).IndentLevel * 8 & "px;"
For n = 1 To 4 'бордюры
m = RR(a, b).Borders.Item(n).Weight
If m = 2 Then m = 1
If m = -4138 Then m = 2
c = RR(a, b).Borders.Item(n).LineStyle
Select Case c
Case Is = -4115: t0 = "dashed"
Case Is = 5: t0 = "dashed"
Case Is = -4118: t0 = "dotted"
Case Is = 13: t0 = "outset"
Case Is = -4119: t0 = "double"
Case Is > 0: t0 = "solid"
End Select
If c <> -4142 Then
t3 = t3 & " border" & dd(n - 1) & m & "px " & t0
t3 = t3 & " " & PreHEX(RR(a, b).Borders.Item(n).Color) & ";"
End If
Next
If InStr(t3, "border") < 1 And InStr(t3, "indent") < 1 Then t3 = t3 & " text-indent:2px;"
dt = "<td " & t2 & " align= " & t1 & " bgcolor= " & Chr(34) & t & Chr(34) & _
" style=""" & t3 & """><font": wtArr tt, q, dt 'цвет фона + рамка
dt = " face= """ & RR(a, b).Font.Name & """": wtArr tt, q, dt 'установка шрифта
dt = " color= """ & PreHEX(RR(a, b).Font.Color) & """": wtArr tt, q, dt
dt = "style=""font-size:" & RR(a, b).Font.Size & "pt"";>": wtArr tt, q, dt 'цвет шрифта + размер шрифта
If RR(a, b).Font.Bold Then dt = " <b>": wtArr tt, q, dt 'толщина шрифта
If RR(a, b).Font.Italic Then dt = " <i>": wtArr tt, q, dt 'наклон шрифта
If RR(a, b).NumberFormat <> "General" Then
t2 = Format(RR(a, b), RR(a, b).NumberFormat)
Else: t2 = RR(a, b)
End If
If Len(t2) < aa(b) Then
dt = t2 & String(aa(b) - Len(t2), " "): wtArr tt, q, dt
Else: dt = t2: wtArr tt, q, dt
End If
If RR(a, b).Font.Italic Then dt = "</i>": wtArr tt, q, dt
If RR(a, b).Font.Bold Then dt = "</b>": wtArr tt, q, dt
dt = "</font></td>": wtArr tt, q, dt
End If
Next
dt = "</tr>": wtArr tt, q, dt
Next
dt = "</table></body></html>": wtArr tt, q, dt: RangeToHTML = Join(tt, ""): Erase tt
End Function
Private Sub wtArr(arr$(), x&, dt$)
x = x + 1: ReDim Preserve arr(1 To x): arr(x) = dt
End Sub
Вспомогательные функции:
Скрытый текст
Код
Function PreHEX$(ByVal nn#)
Dim t$
t = D2xz(nn, 16, 6)
If Len(t) = 6 Then t = Right$(t, 2) & Mid$(t, 3, 2) & Left$(t, 2) Else t = Right$(t, 6)
PreHEX = "#" & t
End Function
Function D2xz(ByVal d, N As Long, Optional ByVal c%) As String
'автор Игорь Гончаренко
Const ch$ = "0 1 2 3 4 5 6 7 8 9 A B C D E F G H I J K L M N O P Q R S T U V W X Y Z"
Dim r%, D2C
If d > 0 Then
r = Int(Round(Log(d) / Log(N), 7)): D2C = Split(ch)
Do
D2xz = D2xz & D2C(Int(d / N ^ r)): d = d - Int(d / N ^ r) * N ^ r: r = r - 1
Loop Until r = -1
Else: D2xz = "0"
End If
If c > 0 Then
If c > Len(D2xz) Then D2xz = String(c - Len(D2xz), "0") & D2xz
End If
End Function
Функция заметно потолстела по кол-ву строк кода. Изменения: - корректно преобразует большинство форматов перед помещением в HTML - схлопнул бордюры, а также по левому верхнему ушлу диапазона автоматом определяется тип бордюра в исходной таблице. Итого реализовано пока три варианта6 тонкие границы с обводом каждой ячейки, без границ, с двойными адаптивными по цвету. - теперь понимает объединенные ячейки и корректно их отображает в HTML. - ну и добавлено горизонтальное выравнивание, как в оригинальной таблице по каждой ячейке
Изменения: - теперь по каждой ячейке бордюры отрисовываются индивидуально. Все виды бордюров, их толщина и цвет. - высота строк из экспортируемой таблицы - добавлены отступы (IndentLevel), точнее их отслеживание и отображение