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, "" 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, "
" & TableName & "
" 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