Attribute VB_Name = "McRitchie_HTML"
Attribute VB_Description = "HTML conversion"
'--remove or comment out this and above lines if pasting into a module
Option Explicit
Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal _
lpOperation As String, ByVal lpFile As _
String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal _
nShowCmd As Long) As Long
Declare Function GetForegroundWindow Lib "user32" () As Long
Public filename As String
'XL2HTML, Convert selection to HTML
'XL2HTMLx, Convert selection to HTML with row/column headers
' does not yet include color changes, etc.
Sub XL2HTMLx()
Call [pesonal.xls].XL2HTML_Main(1, "OC") 'column and row headings with shading
MsgBox "Xl2HTMLx ended"
End Sub
Sub XL2HTML()
Call XL2HTML_Main(0, "OC") 'default no column nor row headings
End Sub
Sub XL2HTMLs()
'Example: output multiple selected sheets...
Dim optFile As String
Dim shtCnt As Integer
Dim mshtCnt As Integer
Dim sht As Variant
shtCnt = 0
mshtCnt = Application.ActiveWorkbook.Windows(1).SelectedSheets.Count
For Each sht In Application.ActiveWorkbook.Windows(1).SelectedSheets
Sheets(sht.Name).Select
shtCnt = shtCnt + 1
optFile = ""
If shtCnt = 1 Then optFile = "O" 'letter o
If shtCnt = mshtCnt Then optFile = optFile & "C"
Cells.Select
Call XL2HTML_Main(0, optFile)
Next sht
End Sub
Sub XL2HTML_Main(Optional shading As Integer, _
Optional opt2 As String, _
Optional optOutputFile As String)
'O=open,C=Close,""=default, 1=special, T=Time
Dim r%, c%
Dim nr As Long, nC As Integer
Dim lastcell As Range
'Dim xtra As Integer
'Dim filename As Variant
'Dim shadehd As Variant
Dim retval As Variant
Dim x As String
Dim shadehd As String:
shadehd = " bgcolor=""#d8d8d8"""
Dim i As Integer, iPos As Integer
Dim newx As String
'Worksheets(1).Select
nr = Selection.Rows.Count
nC = Selection.Columns.Count
Set lastcell = Cells.SpecialCells(xlLastCell)
If nr > lastcell.Row Then nr = lastcell.Row
If nC > lastcell.Column Then nC = lastcell.Column
'iRows = Selection.Rows.Count
'iColumns = Selection.Columns.Count
'To Be Added: radio buttons, Row hdr, Col hdr, Shade hdr
' include suggested filename of c:\temp\XL2test.htm
'(I include that file in my browsers bookmarks/favorites)
filename = "c:\temp\XL2test.htm"
If optOutputFile <> "" Then filename = optOutputFile
If InStr(opt2, "O") Then
filename = InputBox("Supply filename for HTML generated from " _
& "selected range", "Filename for XL2HTML", filename)
End If
If InStr(opt2, "O") Or InStr(opt2, "1") Then
Close #1
Open filename For Output As 1
End If
If InStr(opt2, "O") Then
Print #1, "<html><head><meta NAME=""robots"" CONTENT=""noindex,nofollow""></head><body>"
Print #1, "<!-- increasing cellpadding will make table bigger -->"
End If
Print #1, "<!-- ======================================= -->"
Print #1, "<table border=""1"" bgcolor=""#FFFFFF""" _
; " cellspacing=""0"" cellpadding=""2"" align=""center"">"
Dim urladdr As String
Dim xStr As String
Dim xColor As String, iColor As String
Dim TD As String, eTD As String
Dim xB As String
Dim TRstr As String
Dim CenterAC As Integer 'Center across Columns
Dim xFontname As String
If shading = 1 Then
'SHADING LINES ADDED...
Print #1, "<tr align=""center""" & shadehd & ">"
x = "<td> </td>"
For c = 1 To nC
x = x & "<td>" & Left(Selection.Cells(1, c).AddressLocal(0, 0), _
Len(Cells(1, c).AddressLocal(0, 0)) - 1) & "</td>"
Next c
x = x & "</tr>"
Print #1, x
End If
For r = 1 To nr
TRstr = "<TR>" 'want to combine several lines
'SHADING LINE ADDED...
If shading = 1 Then _
TRstr = TRstr & "<td" & shadehd & ">" & (Selection.Cells(r, 1).Row) & "</td>"
For c = 1 To nC
CenterAC = 0 'watch for Center Across Selection (Columns)
'numbers and text must be right aligned when generating HTML here
If Selection.Cells(r, c).Address = _
Selection.Cells(r, c).MergeArea.Cells(1).Address Then
'** secondary merged cells will not be processed **
TD = "td" 'No special support for THEAD
' <THEAD><tr><th>...</tr></thead><TBODY><TBody><tr><td>...</td></tr></tbody>
'If r = 1 Then TD = "TH": 'fix this up more if pages get support
eTD = TD
If Selection.Cells(r, c).MergeArea.Columns.Count > 1 Then _
TD = TD & " COLSPAN=""" & _
Selection.Cells(r, c).MergeArea.Columns.Count & """"
If Selection.Cells(r, c).HorizontalAlignment = 7 Then
For i = c + 1 To nC
If IsEmpty(Selection.Cells(r, i)) Then
If Selection.Cells(r, i).HorizontalAlignment = 7 Then
CenterAC = CenterAC + 1
Else: i = nC
End If
Else
i = nC
End If
Next i
If CenterAC > 0 Then TD = TD & " COLSPAN=""" _
& CenterAC + 1 & """ ALIGN=""Center"""
End If
If Selection.Cells(r, c).MergeArea.Rows.Count > 1 Then _
TD = TD & " ROWSPAN=""" & _
Selection.Cells(r, c).MergeArea.Rows.Count & """"
If Selection.Cells(r, c).HorizontalAlignment = -4108 Then _
TD = TD & " align=""center"""
If Selection.Cells(r, c).HorizontalAlignment = -4152 Then _
TD = TD & " align=""right"""
urladdr = "" 'include hyperlinks but not =HYPERLINK()
On Error Resume Next
urladdr = Selection.Cells(r, c).Hyperlinks(1).Address
On Error GoTo 0
Select Case Selection.Cells(r, c).FONT.Name
Case "webdings", "Wingdings", "Wingdings 2", "Wingdings 3"
xFontname = " face=""" & Selection.Cells(r, c).FONT.Name & """"
Case Else
xFontname = ""
End Select
xColor = Right("000000" & Hex(Selection.Cells(r, c).FONT.Color), 6)
xColor = "#" & Right(xColor, 2) & Mid(xColor, 3, 2) & Left(xColor, 2)
iColor = Right("000000" & Hex(Selection.Cells(r, c).Interior.Color), 6)
iColor = "#" & Right(iColor, 2) & Mid(iColor, 3, 2) & Left(iColor, 2)
If iColor <> "#FFFFFF" Then TD = TD & " BGCOLOR=""" & iColor & """"
If Len(urladdr) > 0 Then ' not = 0
If Left(LCase(urladdr) & " ", 7) <> "http://" Then
urladdr = "": xColor = "#000000" 'back to black for email
End If
End If
x = Selection.Cells(r, c).Text
If Trim(x) = "" Then
x = " "
Else
xStr = " " & LCase(Selection.Cells(r, c).FONT.FontStyle) & " "
If InStr(xStr, " bold ") Then _
x = "<b>" & x & "</b>"
If InStr(xStr, " italic ") Then _
x = "<i>" & x & "</i>"
If xColor = "#000000" Then
xColor = ""
Else
xColor = " color=""" & xColor & """"
End If
If xColor & xFontname <> "" Then _
x = "<font" & xFontname & xColor & ">" & x & "</font>"
End If
If Len(urladdr) > 1 Then x = "<a href=""" & urladdr & """>" & x & "</a>"
iPos = InStr(1, x, Chr(10))
If iPos > 0 Then
newx = Left(x, iPos - 1) & "<br>"
For i = iPos + 1 To Len(x)
If Mid(x, i, 1) = Chr(10) Then
newx = newx & "<br>"
Else
newx = newx & Mid(x, i, 1)
End If
Next i
x = newx
End If
x = "<" & TD & ">" & x & "</" & eTD & ">"
If Len(TRstr) + Len(x) > 80 Then
If Len(TRstr) > 0 Then
Print #1, TRstr
TRstr = ""
End If
End If
TRstr = TRstr & x
End If '* don't do secondary merged cells
c = c + CenterAC
Next c
Print #1, TRstr & "</tr>"
Next r
Print #1, "</table>"
If InStr(opt2, "T") Then Print #1, "<center><i><font size=""-2"">" & _
" " & _
Format(Date + Time, "yyyy-mm-dd hh:mm") & "</i></font></center>"
Print #1, "<! finished with " & ActiveSheet.Name & " >"
If InStr(opt2, "C") Then
'Print #1, "</body></html>"
Print #1, "<!-- ======================================= -->"
Close #1
MsgBox "XL2HTML placed your HTML code in" & Chr(10) & filename
ShellExecute 0, "open", filename, "", "", 0
ElseIf InStr(opt2, "1") Then
Close #1
Else 'The follow would be used for multiple sheets
Print #1, "<P>"
End If
End Sub