'*********************************************************************
' HTML2Excel/Directory2Excel Ver 1.02
'
' HTML の TABLE を Excel のワークシートに読み込みます
' HTML2Excel は HTML文書に含まれる TABLE の内容を読み込みます
' Directory2Excel はディレクトリ中の全 HTML文書を対象にします
'
'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
'作者の許可なく改変・盗用・配布することを歓迎します
'*********************************************************************

Sub Directory2Excel()
    Dim dir_name As String, file_name As String
    Dim rn As Integer
        
    dir_name = Application.GetOpenFilename( _
         "HTMLファイル (*.htm),*.htm", 1, _
         "HTMLファイルをどれか一つ選んでください" _
         )
    If dir_name = "False" Then Exit Sub
    
    file_name = Dir("*.htm", vbNormal)
    
    Do Until file_name = ""
        Call ImportHTML(file_name, rn)
        rn = rn + 1
        file_name = Dir()
    Loop
    
    Application.StatusBar = "HTMLタグを削除しています。"
    Call ReplaceTags("<*>", "")  '// HTMLタグ削除
    Call ReplaceTags("&nbsp;", "")   '// 空白文字削除
    Call ReplaceTags("&amp;", "&")     '// &記号
    Call ReplaceTags("&lt;", "<")     '// 小なり
    Call ReplaceTags("&gt;", ">")     '// 大なり
    Call ReplaceTags(Chr(9), "")   '// タブ文字削除
    Application.StatusBar = False
    Beep
    MsgBox dir_name & "が入っているディレクトリの内容を読み込みました。", 0, "Directory2Excel"
End Sub

Sub HTML2Excel()
    Dim file_name As String
    Dim rn As Integer
    
    file_name = Application.GetOpenFilename("HTML文書 (*.htm),*.htm")
    If file_name = "False" Then Exit Sub
    
    rn = 0
    'rn = ActiveSheet.UsedRange.Rows.Count
    
    Call ImportHTML(file_name, rn)
    
    Application.StatusBar = "HTMLタグを削除しています。"
    Call ReplaceTags("<*>", "")  '// HTMLタグ削除
    Call ReplaceTags("&nbsp;", "")   '// 空白文字削除
    Call ReplaceTags("&amp;", "&")     '// &記号
    Call ReplaceTags("&lt;", "<")     '// 小なり
    Call ReplaceTags("&gt;", ">")     '// 大なり
    Call ReplaceTags(Chr(9), "")   '// タブ文字削除
    Application.StatusBar = False
    Beep
    MsgBox file_name & "の内容を読み込みました。", 0, "HTML2Excel"
End Sub

Sub ImportHTML(file_name As String, rn As Integer)
    Dim FileNum As Integer
    Dim TRn As String, TextLine As String
    Dim TRs As Long

    Application.StatusBar = "HTMLファイルを開いています。"

    FileNum = FreeFile()
    Open file_name For Input Access Read As #FileNum
    
    On Error GoTo CloseFile

    Do Until EOF(FileNum)
        Line Input #FileNum, TextLine
        TRn = TRn & TextLine
    Loop

    TRs = InStr(1, TRn, "<TR", 1)
    
    If TRs = 0 Then
        Application.StatusBar = False
        MsgBox Title:="処理できませんでした。", _
            prompt:=file_name & " :" & Chr(13) & Chr(10) & _
            "このファイルには、表の内容が見当たりません。"
        Exit Sub
    End If
    
    Application.StatusBar = "TABLEの内容を読み込んでいます。処理が終わるまでお待ちください。"

    Do While TRs > 0
    
        rn = rn + 1
        Call ReadTRs(TRn, TRs, rn)
        TRs = InStr(1, TRn, "<TR", 1)
    Loop
    
CloseFile:
    Application.StatusBar = False
    Close #FileNum
End Sub

Sub ReadTRs(TextLine As String, TRs As Long, rn As Integer)
    Dim TR As String, TBLe As Long
    
    TextLine = TagTrim(TextLine, TRs)
    TRs = InStr(1, TextLine, "<TR", 1)

    Do
        TR = Left(TextLine, TRs - 1)
        Call ReadContents(TR, rn)
        
        TextLine = TagTrim(TextLine, TRs)
        rn = rn + 1
        TRs = InStr(1, TextLine, "<TR", 1)
        TBLe = InStr(1, TextLine, "</TABLE>", 1)
        
    Loop Until TRs > TBLe Or TRs = 0
    
    TR = Left(TextLine, TBLe - 1)
    Call ReadContents(TR, rn)
End Sub

Sub ReadContents(TextLine As String, rn As Integer)
    Dim THp As Integer, TDp As Integer, THTDp As Long
    Dim tagc As Integer
    Dim cn As Integer, cont As String
    
    THTDp = THTD(TextLine)
            
    TextLine = TagTrim(TextLine, THTDp)
    
    THTDp = THTD(TextLine)
          
    Do
        cn = cn + 1
        cont = Left(TextLine, THTDp - 1)
        
        Cells(rn, cn).Value = Trim(cont)
        
        TextLine = TagTrim(TextLine, THTDp)
        
        THTDp = THTD(TextLine)
    Loop Until THTDp = 0
    
    Cells(rn, cn).Value = Trim(TextLine)
End Sub

Sub ReplaceTags(before As String, after As String)
    ActiveSheet.UsedRange.Replace _
        what:=before, Replacement:=after
End Sub

Function TagTrim(HTMLtext As String, TRs As Long) As String
    Dim TRn As Long
    
    TRs = Len(HTMLtext) - TRs
    HTMLtext = Right(HTMLtext, TRs) '開始タグ以前を削除
    
    TRn = Len(HTMLtext) - InStr(HTMLtext, ">")
    TagTrim = Right(HTMLtext, TRn) 'tagcを削除
End Function

Function THTD(TextLine As String) As Integer
    Dim THp As Integer, TDp As Integer
    
    THp = InStr(1, TextLine, "<TH", 1)
    TDp = InStr(1, TextLine, "<TD", 1)
    
    If THp < TDp And THp > 0 Then
        THTD = THp
    ElseIf TDp < THp And TDp > 0 Then
        THTD = TDp
    ElseIf THp > TDp Then
        THTD = THp
    ElseIf THp < TDp Then
        THTD = TDp
    End If
End Function