Attribute VB_Name = "Module3"
Option Base 1 ' sets first array element to 1, not 0
Sub MakeHTM()
' This macro was originally written by Chris Mead (www.meadinkent.co.uk)
' You are free to use it for private use provided this copyright message is left unchanged.
Dim PageName As String, FirstRow As Integer, LastRow As Integer
Dim FirstCol As Integer, LastCol As Integer, MyBold As Byte, MySize As Integer
Dim TempStr As String, MyRow As Integer, MyCol As Integer, InsideTD As String
Dim MyFormats As Variant, Vtype As Integer, DefFontSize As Integer
Dim MergeCount As Integer, MyCell As Range, HL_Locn As String
Dim MyWidths() As Single, TotWidth As Single
' MyFormats is an array which can contain formats for numbers and dates. Add one element for each table column.
MyFormats = Array("", "#", "", "#,##0;(#,##0)", "#,##0;(#,##0)", "#,##0;(#,##0)", "#,##0;(#,##0)", "0.0%;(0.0%)", "", "")
DefFontSize = 10 ' this is the default size on the spreadsheet. Text which is larger or smaller will be modified
PageName = "C:\temp\tempadv.htm" 'location and name of Saved file
HL_Locn = "b54" ' location on worksheet for a hyperlink to the web page
FirstRow = 4 ' *** the range of the worksheet to be ***
LastRow = 52 ' *** converted into an HTML table ***
FirstCol = 1
LastCol = 10
If UBound(MyFormats) < (LastCol - FirstCol + 1) Then
MsgBox "The 'MyFormats' array has insufficient elements", vbOKOnly + vbCritical, "MakeHTM macro (CiM)"
Exit Sub
End If
ReDim MyWidths(LastCol)
For MyCol = FirstCol To LastCol
MyWidths(MyCol) = Cells(FirstRow, MyCol).ColumnWidth
TotWidth = TotWidth + MyWidths(MyCol)
Next
' --- You may choose to modify the title and heading ---
Open PageName For Output As #1
Print #1, ""
Print #1, ""
Print #1, "Excel worksheet converted to HTML - MeadInKent"
' --- these lines add some CSS instructions - enabling the HTML page size to be typically halved ---
Print #1, ""
Print #1, ""
Print #1, ""
' --- Any text details for header above the main data table ---
Print #1, "" & Range("b1").Value & "
"
Print #1, "All figures shown in £'s
"
' --- end of hard coded header section ---
Print #1, ""
Print #1, "" 'an initial row to set col widths to those on the worksheet
For MyCol = FirstCol To LastCol
Print #1, "| | "
Next MyCol
Print #1, "
"
For MyRow = FirstRow To LastRow
Print #1, ""
MyCol = FirstCol
Do While MyCol <= LastCol
Set MyCell = Cells(MyRow, MyCol) ' sets variable to the current cell
MyBold = 0
MySize = 0
If MyCell.Font.Bold = True Then MyBold = 1
If MyCell.Font.Size > DefFontSize Then MySize = 1
If MyCell.Font.Size < DefFontSize Then MySize = 2
Vtype = 0 ' check whether the cell is numeric
If IsNumeric(MyCell.Value) Then Vtype = 1
If IsDate(MyCell.Value) Then Vtype = 2
If "-" & MyCell.Value & "-" = "--" Then
TempStr = " " ' a space character to be entered in empty cells
Else
' if numeric and a format code has been created, apply it
If Vtype > 0 And MyFormats(MyCol - FirstCol + 1) <> "" Then
TempStr = Format(MyCell.Value, MyFormats(MyCol - FirstCol + 1))
Else
TempStr = MyCell.Value
End If
If MyBold = 1 Then
TempStr = "" & TempStr & ""
End If
If MySize = 1 Then
TempStr = "" & TempStr & ""
End If
If MySize = 2 Then
TempStr = "" & TempStr & ""
End If
If MyCell.Font.ColorIndex <> 1 And MyCell.Font.ColorIndex <> -4105 Then
TempStr = "" & TempStr & ""
End If
End If
'if cells are merged, count the number of columns. If not merged it will return 1
MergeCount = MyCell.MergeArea.Columns.Count
InsideTD = ChkB(MyRow, MyCol) ' ChkB is a function in this module to set Border commands
If MergeCount > 1 Then
InsideTD = InsideTD & " align='center' colspan='" & Format(MergeCount, "#") & "'"
MyCol = MyCol + MergeCount - 1
Else
If Vtype = 1 And InStr(InsideTD, "align") = 0 Then InsideTD = InsideTD & " align='right'"
End If
TempStr = "| " & TempStr & " | "
Print #1, TempStr
MyCol = MyCol + 1
Loop ' MyCol
Print #1, "
"
Next MyRow
Print #1, "
"
Print #1, "This page was generated on " & Format(Date, "dd mmm yy") & "
"
Print #1, "
"
Range(HL_Locn).Value = "[Goto WebPage]"
Range(HL_Locn).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=PageName
For MyCol = Len(PageName) To 1 Step -1
If Mid(PageName, MyCol, 1) = "\" Then
PageName = Trim(Mid(PageName, MyCol + 1, 50))
Exit For
End If
Next MyCol
Print #1, "Source file: '" & ThisWorkbook.Name & "' | Page name: '" & PageName & "' | XL Macro from www.MeadInKent.co.uk
"
Print #1, ""
Print #1, ""
Close #1
End Sub
Function GetRGB(RGB As Long) As String
' convert an Excel colour value into a Hex value suitable for HTML
Dim Red As Integer, Green As Integer, Blue As Integer
Red = RGB And 255
Green = RGB \ 256 And 255
Blue = RGB \ 256 ^ 2 And 255
GetRGB = "#" & Format(Hex(Red), "00") & Format(Hex(Green), "00") & Format(Hex(Blue), "00")
End Function
Function ChkB(MyRow As Integer, MyCol As Integer) As String
' add borders and table cell properties
Dim Temp As String, MyLine(10) As String, x As Variant
Dim cmW As String, cmS As String
MyLine(7) = "border-left: "
MyLine(8) = "border-top: "
For n = 7 To 8
' left 7 top 8 btm 9 right 10
'Debug.Print GetRGB(Cells(MyRow, MyCol).Borders(n).Color), Cells(MyRow, MyCol).Borders(n).Weight, Cells(MyRow, MyCol).Borders(n).LineStyle
If Cells(MyRow, MyCol).Borders(n).LineStyle = -4142 Then
MyLine(n) = MyLine(n) & " none; "
Else
' weight thick 4 thin 2 medium -4138
x = Cells(MyRow, MyCol).Borders(n).Weight
If x = -4138 Then
cmW = " 1.5pt"
ElseIf x = 4 Then
cmW = " 2.5pt"
Else
cmW = " 0.5pt"
End If
' linestyle 1 solid -4118 dotted -4142 0
x = Cells(MyRow, MyCol).Borders(n).LineStyle
If x = -4118 Then
cmS = " dotted"
Else
cmS = " solid"
End If
MyLine(n) = MyLine(n) & GetRGB(Cells(MyRow, MyCol).Borders(n).Color) & cmW & cmS & "; "
End If
'Debug.Print MyLine(n)
ChkB = ChkB & MyLine(n)
Next
ChkB = "style ='" & Left(Trim(ChkB), Len(Trim(ChkB)) - 1) & "'"
If ChkB = "style ='border-left: none; border-top: none'" Then ChkB = ""
If ChkB = "style ='border-left: none; border-top: #000000 0.5pt solid'" Then ChkB = "Class='TopLine'"
If Cells(MyRow, MyCol).Interior.Color <> 16777215 Then
ChkB = ChkB & " bgcolor='" & GetRGB(Cells(MyRow, MyCol).Interior.Color) & "'"
End If
If Cells(MyRow, MyCol).HorizontalAlignment = xlHAlignRight Then
ChkB = ChkB & " align='right'"
End If
If Cells(MyRow, MyCol).HorizontalAlignment = xlHAlignCenter Then
ChkB = ChkB & " align='center'"
End If
End Function