Attribute VB_Name = "XL2HTML4"
Option Explicit
'*************************************************************
'Excel2HTML4 Ver 1.0
'
'Excelのワークシートをスタイル付 HTML 4.0 形式に書き出します
'
'Designed for HPCF http://www.hpcf.com/
'by poetlabo http://www.bekkoame.ne.jp/%7Epoetlabo/
'also available at http://www.vector.co.jp/authors/VA014833/
'Copyleft:1999, 魔術幻燈 poetlabo@cap.bekkoame.ne.jp
'作者の許可なく改変・盗用・配布することを歓迎します
'*************************************************************
Const amp As String = "&", lt As String = "<", _
gt As String = ">", quot As String = """"
Const neamp As String = "&", nelt As String = "<", _
negt As String = ">", nequot As String = """
Const tleft As String = "text-align:left;", _
tcenter As String = "text-align:center;", _
tright As String = "text-align:right;", _
middle As String = "vertical-align:middle;", _
htop As String = "vertical-align:top;", _
color As String = "color:#", ret As String = ";", _
bgcolor As String = "background-color:#", _
fbold As String = "font-weight:bold;"
Const ST As String = " style="""
Dim h_a As String, f_c As String, i_c As String, v_a As String, _
f_b As String
Sub Excel2HTML4() 'Version 1 for Windows95/98
Const TRs As String = "", TRe As String = "
", _
THs As String = ""
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, "" & TableName & ""
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, "" & TableName & ""
Print #1, TRs '一行目をTHにします
For Each TI In Range(Cells(1, 1), Cells(1, colmax))
Print #1, String(1, 9) & THs & THStyle(TI) & tagc & EscMkUps(TI.Value) & THe
Next
Print #1, TRe
rn = 2
For Each RI In Range(Cells(2, 1), Cells(rowmax, 1))
Print #1, TRs '二行目以下の一列目をTHにします
Print #1, String(1, 9) & THs & THStyle(RI) & tagc & EscMkUps(RI.Value) & THe
'二行目以下の二列目以下をTDにします
For Each TI In Range(Cells(rn, 2), Cells(rn, colmax))
Print #1, String(1, 9) & TDs & TDStyle(TI) & tagc & EscMkUps(TI.Value) & TDe
Next
Print #1, TRe
rn = rn + 1
Next
Print #1, "
"
Print #1, ""
Print #1, "";
MsgBox "HTML形式のファイル" & file_name & "を作成しました。", _
vbOKOnly, "変換終了"
Close #1
End Sub
Function EscMkUps(cont As String) As String
cont = Application.Substitute(cont, amp, neamp)
cont = Application.Substitute(cont, lt, nelt)
cont = Application.Substitute(cont, gt, negt)
cont = Application.Substitute(cont, quot, nequot)
EscMkUps = cont
End Function
Function RRGGBB(Dec As Long) As String
Dim HexColor As String
Dim RR As String, GG As String, BB As String
HexColor = Format(Hex$(Dec), "@@@@@@")
RR = Mid(HexColor, 5, 2)
GG = Mid(HexColor, 3, 2)
BB = left(HexColor, 2)
RRGGBB = Application.Substitute(RR & GG & BB, " ", "0")
End Function
Property Get THStyle(CurCell As Range) As String
THStyle = "" 'スタイル設定用意
h_a = "" '横位置指定
Select Case CurCell.HorizontalAlignment
Case xlLeft '左寄せ
h_a = tleft
Case xlRight '右寄せ
h_a = tright
End Select
v_a = "" '縦位置指定
Select Case CurCell.VerticalAlignment
Case xlTop '上付き
v_a = htop
End Select
f_c = "" '文字色指定 '黒以外なら色を取得
If CurCell.Font.color > 0 Then _
f_c = color & RRGGBB(CurCell.Font.color) & ret
i_c = "" '背景色指定 '白以外なら色を取得
If CurCell.Interior.color < 16777215 Then _
i_c = bgcolor & RRGGBB(CurCell.Interior.color) & ret
'スタイル設定 必要ない項目は両辺から削除してください
If h_a & v_a & f_c & i_c <> "" Then _
THStyle = ST & h_a & v_a & f_c & i_c & quot
End Property
Property Get TDStyle(CurCell As Range) As String
TDStyle = "" 'スタイル設定用意
h_a = "" '横位置指定
Select Case CurCell.HorizontalAlignment
Case xlCenter '中央揃え
h_a = tcenter
Case xlRight '右寄せ
h_a = tright
End Select
v_a = "" '縦位置指定
Select Case CurCell.VerticalAlignment
Case xlCenter '中央揃え
v_a = middle
Case xlTop '上付き
v_a = htop
End Select
f_c = "" '文字色指定 '黒以外なら色を取得
If CurCell.Font.color > 0 Then _
f_c = color & RRGGBB(CurCell.Font.color) & ret
i_c = "" '背景色指定 '白以外なら色を取得
If CurCell.Interior.color < 16777215 Then _
i_c = bgcolor & RRGGBB(CurCell.Interior.color) & ret
f_b = "" '太字指定
If CurCell.Font.bold = True Then _
f_b = fbold
'スタイル設定 必要ない項目は両辺から削除してください
If h_a & v_a & f_c & i_c & f_b <> "" Then _
TDStyle = ST & h_a & v_a & f_c & i_c & f_b & quot
End Property