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.00;(£#,##0.00)", "£#,##0.00;(£#,##0.00)", "", "0.0%;(0.0%)")
DefFontSize = 10 ' this is the default size on the spreadsheet. Text which is larger or smaller will be modified
PageName = "d:\tempadv.htm" 'location and name of Saved file
HL_Locn = "b36" ' location on worksheet for a hyperlink
FirstRow = 4 ' *** the range of the worksheet to be ***
LastRow = 34 ' *** converted into an HTML table ***
FirstCol = 1
LastCol = 6
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, "" & Cells(1, 2).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) <> "" 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 = ChkBorders(MyRow, MyCol) ' 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 ChkBorders(MR As Integer, MC As Integer) As String
Dim Temp As String, MyBcol As String, MySides(4) As Integer, Tn As Integer
If Cells(MR, MC).Borders(xlEdgeTop).LineStyle <> xlNone Then
If Cells(MR, MC).Borders(xlEdgeTop).LineStyle <> xlContinuous Then
MySides(1) = 2
Else
MySides(1) = 1
End If
End If
If Cells(MR, MC).Borders(xlEdgeRight).LineStyle <> xlNone Then
If Cells(MR, MC).Borders(xlEdgeRight).LineStyle <> xlContinuous Then
MySides(2) = 2
Else
MySides(2) = 1
End If
End If
If Cells(MR, MC).Borders(xlEdgeBottom).LineStyle <> xlNone Then
If Cells(MR, MC).Borders(xlEdgeBottom).LineStyle <> xlContinuous Then
MySides(3) = 2
Else
MySides(3) = 1
End If
End If
If Cells(MR, MC).Borders(xlEdgeLeft).LineStyle <> xlNone Then
If Cells(MR, MC).Borders(xlEdgeLeft).LineStyle <> xlContinuous Then
MySides(4) = 2
Else
MySides(4) = 1
End If
End If
' MySides 1-4: T-R-B-L where 1 is solid, 2 is dotted
Tn = MySides(1) + MySides(2) + MySides(3) + MySides(4)
If Tn > 0 Then
If Tn = 1 Then
If MySides(1) = 1 Then Temp = " class='tdt'"
If MySides(2) = 1 Then Temp = " class='tdr'"
If MySides(3) = 1 Then Temp = " class='tdb'"
If MySides(4) = 1 Then Temp = " class='tdl'"
Else
Temp = ""
If MySides(1) = 2 Then Temp = Temp & "border-top-style: dotted;"
If MySides(2) = 2 Then Temp = Temp & " border-right-style: dotted;"
If MySides(3) = 2 Then Temp = Temp & " border-bottom-style: dotted;"
If MySides(4) = 2 Then Temp = Temp & " border-left-style: dotted;"
MyBcol = " border-color:"
For n = 1 To 4
If MySides(n) = 0 Then
MyBcol = MyBcol & " #FFFFFF"
Else
MyBcol = MyBcol & " #000000"
End If
Next n
Temp = " style= '" & Temp & MyBcol & "' "
End If
End If
If Cells(MR, MC).Interior.Color <> 16777215 Then
Temp = Temp & " bgcolor='" & GetRGB(Cells(MR, MC).Interior.Color) & "'"
End If
If Cells(MR, MC).HorizontalAlignment = xlHAlignRight Then
Temp = Temp & " align='right'"
End If
If Cells(MR, MC).HorizontalAlignment = xlHAlignCenter Then
Temp = Temp & " align='center'"
End If
ChkBorders = Temp
End Function
Function GetRGB(RGB As Long) As String
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