Public Sub CVBMakeandSendHTM()
' This macro requires a local c:\FTPSend Directory
' and a remote /hdoc
' Written by Charles Balch. charlie@balch.org
' Public Domain 1998-2009. Copyright. All rights reserved.
'
'Information for local Document
DefaultFile = LCase(ActiveSheet.Name & ".htm") 'Use sheet name for document name
DefaultFile = InputBox("Send to: ", "Make & Send", DefaultFile)
LocalDestination = "U:\FTPSend\" & DefaultFile
If Len(DefaultFile) < 2 Then End
'Create document
Names.Add Name:="FastHTMLExport", RefersTo:=Selection
Call RangeToHTM("FastHTMLExport", LocalDestination, False)
'Establish Destination
FTPDestination = "/hdoc/" & DefaultFile
FTPServer = "http://balch.org"
Call FTPSendFile(LocalDestination, FTPDestination)
DoEvents
'put address in clipboard
subPutInClipboard "http://balch.org" & FTPDestination
Beep
End Sub
Public Sub RangeToHTM(MyRange, DocDestination, blnAWC)
' This macro converts an Excel range to a HTML Table.
'
' Copywrite 1996 - 2008 by Charles Balch, mailto:charlie@balch.edu
' Original Source is at http://balch.org/charlie/hdoc
' MyRange is an Excel range you wish to convert.
' DocDestination is the FileName and Path to send the document to.
'
Dim lRGB As Long
Dim strTitle, MV, CellV, CellA, BGC, Red, Green, Blue, SFC1, strComment As String
Dim RowStart, Row, RowCount, RowEnd, ColStart, Col, ColEnd, Hza, ColSpan, iFreeFile As Integer
Dim SameTitle As Boolean
iFreeFile = FreeFile
RowStart = Range(MyRange).Row
ColStart = Range(MyRange).Column
ColCount = Range(MyRange).Columns.Count
RowCount = Range(MyRange).Rows.Count
RowEnd = RowStart + RowCount - 1
ColEnd = ColStart + ColCount - 1
If Len(Dir(DocDestination)) > 1 Then Kill DocDestination
Open DocDestination For Output As iFreeFile
'create Code
Print #iFreeFile, ""
Print #iFreeFile, "" & vbCr
Print #iFreeFile, "" & vbCr
Print #iFreeFile, "" & vbCr
strTitle = Replace(Cells(RowStart, ColStart), Chr(10), " ")
Print #iFreeFile, "" & strTitle & "" & vbCr ' Use first cell as title
If blnAWC Then
Print #iFreeFile, "" & vbCr
Else
Print #iFreeFile, "" & vbCr
End If
MyTitle = Cells(RowStart, ColStart) ' Use first cell as title
Print #iFreeFile, "" & vbCr
Print #iFreeFile, "" & vbCr
Print #iFreeFile, "
" & vbCr
While Row < RowCount
Row = Row + 1
DoEvents
If (Not Range(MyRange).Rows(Row).Hidden) Then
MV = ""
Col = 0
While Col < ColCount
Col = Col + 1
CellV = ""
CellA = ""
If (Not Range(MyRange).Columns(Col).Hidden) Then
'Define cell color
lRGB = Range(MyRange).Cells(Row, Col).Interior.Color
Red = Hex(lRGB And 255)
If Len(Red) = 1 Then Red = "0" & Red
Green = Hex(lRGB \ 256 And 255)
If Len(Green) = 1 Then Green = "0" & Green
Blue = Hex(lRGB \ 256 ^ 2 And 255)
If Len(Blue) = 1 Then Blue = "0" & Blue
BGC = " bgcolor=""#" & Red & Green & Blue & """ "
If BGC = " bgcolor=""#FFFFFF"" " Then BGC = ""
CellV = Range(MyRange).Cells(Row, Col).Text
If CellV = "" Then
CellV = " "
Else
CellV = Replace(CellV, Chr(10), (Chr(10) & " ")) 'Show Line Feeds
'Define cell alignment
Hza = Range(MyRange).Cells(Row, Col).HorizontalAlignment
CellA = " align=""left"" "
If IsNumeric(CellV) Then CellA = " align=""right"" "
If Hza = -4108 Then CellA = " align=""center"" "
If Hza = -4131 Then CellA = " align=""left"" "
If Hza = -4152 Then CellA = " align=""right"" "
If Range(MyRange).Cells(Row, Col).Font.Bold Then CellV = "" & CellV & ""
If Range(MyRange).Cells(Row, Col).Font.Italic Then CellV = "" & CellV & ""
'Define cell font color
lRGB = Range(MyRange).Cells(Row, Col).Font.Color
SFC1 = ""
Red = Hex(lRGB And 255)
If Len(Red) = 1 Then Red = "0" & Red
Green = Hex(lRGB \ 256 And 255)
If Len(Green) = 1 Then Green = "0" & Green
Blue = Hex(lRGB \ 256 ^ 2 And 255)
If Len(Blue) = 1 Then Blue = "0" & Blue
SFC1 = " "
If SFC1 = " " Then
SFC1 = ""
SFC2 = ""
Else
SFC2 = ""
End If
End If
'Check for Merged Cells (rowes only)
If Hza = 7 Or Range(MyRange).Cells(Row, Col).MergeCells Then
ColSpan = 0
SameTitle = True
While (Range(MyRange).Cells(Row, Col).HorizontalAlignment = 7 Or Range(MyRange).Cells(Row, Col).MergeCells) And SameTitle
' The following code must be changed for versions of Excel earlier than 97
If Not Range(MyRange).Columns(Col).Hidden Then ColSpan = ColSpan + 1
Col = Col + 1
If Len(Range(MyRange).Cells(Row, Col).Text) > 1 Or Not Range(MyRange).Cells(Row, Col).MergeCells Then
SameTitle = False
Col = Col - 1
End If
Wend
CellA = CellA & " colspan=" & ColSpan & " "
End If
'Check for Comment (Idea from Michal Matula)
sComment = funTestForComment(Range(MyRange).Cells(Row, Col))
If sComment <> "" Then 'The cell does not have a comment
sComment = Replace(sComment, Chr(34), Chr(147))
sComment = " title=""" & sComment & """"
CellV = "" & CellV & ""
End If
MV = MV & "