Sub RangeToHTM(MyRange, DocDestination)
' This macro will convert a named Excel range to a HTML Table.
' Most formating is preserved. Font size, row & column hight
' are ignored. I may add those at a later date.
'
' MyRange is an Excel range you wish to convert.
' DocDestination is the FileName and Path to send the document to.
'
' Hacked by Charles Balch, Feb 96 cbalch@uvi.edu
' Email Ware! Send me Email if you use it. Redistribute at will.
' Adjusting is OK but add your name and leave my name in the comments.
'
ColCount = Range(MyRange).Columns.Count
RowCount = Range(MyRange).Rows.Count
CalcState = Application.Calculation
Calculate
MyTitle = Range(MyRange).Cells(1, 1)
Application.Calculation = xlManual
If Len(Dir(DocDestination)) > 1 Then Kill DocDestination
Open DocDestination For Output As 1
'create Code
Print #1, "" & Chr$(13)
Print #1, "" & Chr$(13)
Print #1, "" & MyTitle & "" & Chr$(13)
Print #1, "" & Chr$(13)
Print #1, "" & Chr$(13)
'Print #1, "" & MyTitle & "" & Chr$(13)
While Row < RowCount
Row = Row + 1
DoEvents
If (Not Range(MyRange).Rows(Row).Hidden) Then
MV = ""
col = 0
While col < ColCount
col = col + 1
If (Not Range(MyRange).Columns(col).Hidden) Then
CellV = Range(MyRange).Cells(Row, col).Text
If CellV = "" Then CellV = "
"
HzA = Range(MyRange).Cells(Row, col).HorizontalAlignment
CellA = " Align=Right "
If HzA = -4108 Then CellA = " Align=Center "
If HzA = -4131 Then CellA = " Align=Left "
If Range(MyRange).Cells(Row, col).Font.Bold Then CellV =
"" & CellV & ""
If Range(MyRange).Cells(Row, col).Font.Italic Then CellV =
"" & CellV & ""
If HzA = 7 Then
ColSpan = 0
SameTitle = True
While Range(MyRange).Cells(Row, col).HorizontalAlignment
= 7 And SameTitle
If Not Range(MyRange).Columns(col).Hidden Then
ColSpan = ColSpan + 1
col = col + 1
If Len(Range(MyRange).Cells(Row, col).Text) > 1 Then
SameTitle = False: col = col - 1
Wend
CellA = " ColSpan=" & ColSpan & " Align=center "
End If
CC = Range(MyRange).Cells(Row, col).Interior.ColorIndex
BGC = ""
If CC = 1 Then BGC = "#000000" 'black"
If CC = 4 Then BGC = "#00FF00" 'green"
If CC = 6 Then BGC = "#FFFF00" 'yellow"
If CC = 8 Then BGC = "#80FFFF" 'blue
If CC = 9 Then BGC = "#C04000" 'burgandy
If CC = 15 Then BGC = "#DFDFDF" 'grey"
If Len(BGC) > 2 Then BGC = " bgcolor=" & Chr(34) & BGC & Chr(34)
MV = MV & "" & CellV & ""
End If
Wend
Print #1, "" & MV & "
" & Chr$(13)
End If
Wend
Print #1, "
" & Chr$(13)
Print #1, "" & Chr$(13)
Application.Calculation = CalcState
Close
Beep
End Sub