From cbalch@uvi.edu Tue Feb 27 14:29:07 1996
Article: 51504 of comp.infosystems.www.authoring.html
From: cbalch@uvi.edu (Charles V. Balch)
Subject: Here is Excel Range to HTML Table VB Code
Organization: University of the Virgin Islands
Date: Fri, 16 Feb 96 17:58:35 MET
Hope that some of you can use this. It was a fun hack!
I've done a few others if this sort of thing is of interest.
Sub RangeToHTM(MyRange, DocDestination)
' This Macro converts a Excel Range to a HTML document.
' It preserves most of the formatting.
' 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
' Feel free to redistribute but please keep my name on it.
' Email me if you find the code useful.
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
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