﻿Option Explicit

Public Function RC_Dict() As Object
    Set RC_Dict = CreateObject("Scripting.Dictionary")
End Function

Public Function RC_Node(ByVal nodeId As String, ByVal kind As String, ByVal prefix As String, ByVal gap As String, ByVal body As String, ByVal line As Long) As Object
    Dim n As Object, children As Collection
    Set n = RC_Dict()
    Set children = New Collection
    n.Add "id", nodeId
    n.Add "kind", kind
    n.Add "prefix", prefix
    n.Add "gap", gap
    n.Add "body", body
    n.Add "raw", prefix & gap & body
    n.Add "heading", ""
    n.Add "line", line
    n.Add "children", children
    Set RC_Node = n
End Function

Public Function RC_ParseText(ByVal text As String, ByVal source As String, ByVal issues As Collection) As Object
    Dim lines As Variant
    lines = Split(Replace(Replace(text, vbCrLf, vbCr), vbLf, vbCr), vbCr)
    Set RC_ParseText = RC_ParseLines(lines, source, issues)
End Function

Public Function RC_ReadDocument(ByVal path As String, ByVal issues As Collection) As Object
    Dim d As Document, p As Paragraph, lines() As String, i As Long, s As String
    Dim result As Object, shape As Shape, savedErr As Long, savedDesc As String, ownsDocument As Boolean
    Dim footnote As footnote, endnote As endnote, field As field
    On Error GoTo Failed
    ' 開いているユーザー文書の所有権を取得/閉じない。
    For Each d In Application.Documents
        If StrComp(d.FullName, path, vbTextCompare) = 0 Then
            Err.Raise vbObjectError + 110, , "入力をWordで閉じてから実行してください: " & path
        End If
    Next d
    Set d = Nothing
    Set d = Application.Documents.Open(FileName:=path, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
    ownsDocument = True
    ReDim lines(0 To d.Paragraphs.Count - 1)
    For Each p In d.Paragraphs
        s = p.Range.Text
        If Right$(s, 1) = Chr$(7) Then s = Left$(s, Len(s) - 1)
        If Right$(s, 1) = vbCr Then s = Left$(s, Len(s) - 1)
        lines(i) = s
        If p.Range.ListFormat.ListType <> wdListNoNumbering Then
            RC_AddIssue issues, "入力形式", path & " 段落" & CStr(i + 1), "自動採番は未対応。表示番号を原文へ保全し暫定処理。", p.Range.ListFormat.ListString & " " & s
            lines(i) = p.Range.ListFormat.ListString & " " & s
        End If
        i = i + 1
    Next p
    If d.Tables.Count > 0 Then RC_AddIssue issues, "入力形式", path, "表を段落として保全。列/セルの関係は未対応。原本の表を確認してください。", "表数=" & d.Tables.Count
    If d.InlineShapes.Count > 0 Then RC_AddIssue issues, "入力形式", path, "画像/埋込みオブジェクトは本文抽出できません。原本に保全されています。", "個数=" & d.InlineShapes.Count
    For Each shape In d.Shapes
        s = "図形: " & shape.Name
        If shape.Type = msoTextBox Then s = s & vbCrLf & shape.TextFrame.TextRange.Text
        RC_AddIssue issues, "入力形式", path & " 図形アンカー" & shape.Anchor.Start, "本文外の図形は自動掲載せず原文をレポート/原本に保全。", s
    Next shape
    If d.Revisions.Count > 0 Then RC_AddIssue issues, "入力形式", path, "変更履歴あり。現行のRange.Textで暫定比較。履歴は原本で確認してください。", "履歴数=" & d.Revisions.Count
    For Each footnote In d.Footnotes
        RC_AddIssue issues, "入力形式", path & " 脚注参照位置" & footnote.Reference.Start, "脚注は本則として解析しません。全文をここに保全。", footnote.Range.Text
    Next footnote
    For Each endnote In d.Endnotes
        RC_AddIssue issues, "入力形式", path & " 文末脚注参照位置" & endnote.Reference.Start, "文末脚注は本則として解析しません。全文をここに保全。", endnote.Range.Text
    Next endnote
    For Each field In d.Fields
        RC_AddIssue issues, "入力形式", path & " フィールド位置" & field.Code.Start, "主本文のフィールドは暫定テキストで比較。コードと結果を保全。", field.Code.Text & vbCrLf & field.Result.Text
    Next field
    Set result = RC_ParseLines(lines, path, issues)
    d.Close SaveChanges:=wdDoNotSaveChanges
    Set RC_ReadDocument = result
    Exit Function
Failed:
    savedErr = Err.Number: savedDesc = Err.Description
    On Error Resume Next
    If ownsDocument Then d.Close SaveChanges:=wdDoNotSaveChanges
    On Error GoTo 0
    Err.Raise savedErr, "RC_ReadDocument", path & vbCrLf & savedDesc
End Function

Public Function RC_ParseLines(ByVal lines As Variant, ByVal source As String, ByVal issues As Collection) As Object
    Dim result As Object, articles As Collection, history As Collection, extras As Collection
    Dim a As Object, para As Object, n As Object, m As Object
    Dim ar As Object, pr As Object, it As Object, hd As Object, hi As Object
    Dim pending As String, pendingLine As Long, inHistory As Boolean
    Dim i As Long, ln As Long, s As String, t As String, nodeCount As Long
    Set result = RC_Dict(): Set articles = New Collection: Set history = New Collection: Set extras = New Collection
    result.Add "source", source: result.Add "title", "": result.Add "articles", articles
    result.Add "history", history: result.Add "extras", extras
    Set ar = RC_Regex(RC_ARTICLE_PATTERN): Set pr = RC_Regex(RC_PARAGRAPH_PATTERN)
    Set it = RC_Regex(RC_ITEM_PATTERN): Set hd = RC_Regex(RC_HEADING_PATTERN): Set hi = RC_Regex(RC_HISTORY_PATTERN)
    For i = LBound(lines) To UBound(lines)
        ln = i - LBound(lines) + 1: s = CStr(lines(i)): t = RC_TrimSpace(s)
        If Len(t) > 0 Then
            nodeCount = nodeCount + 1
            If nodeCount > RC_MAX_NODES Then Err.Raise vbObjectError + 111, , "段落数の上限を超えました。設定RC_MAX_NODESを確認してください: " & source
            If hi.Test(s) Or inHistory Then
                inHistory = True
                If Len(pending) > 0 Then
                    Set n = RC_Node("U" & ln, "unknown", "", "", pending, pendingLine)
                    extras.Add n: pending = ""
                    RC_AddIssue issues, "解析", source & " 段落" & pendingLine, "条に属さない見出しを保全。", n("raw")
                End If
                Set n = RC_Node("H" & Format$(history.Count + 1, "000"), "history", "", "", s, ln)
                history.Add n
                If Not hi.Test(s) Then RC_AddIssue issues, "解析", source & " 段落" & ln, "履歴開始後の未認識段落を末尾として全文保全。", s
            ElseIf ar.Test(s) Then
                Set m = ar.Execute(s)(0)
                Set a = RC_Node("A" & Format$(articles.Count + 1, "000"), "article", CStr(m.SubMatches(0)), CStr(m.SubMatches(1)), "", ln)
                a("heading") = pending: pending = ""
                a("headingLine") = pendingLine
                Set para = RC_Node(a("id") & ".P001", "paragraph", a("prefix"), a("gap"), CStr(m.SubMatches(2)), ln)
                a("children").Add para: articles.Add a
            ElseIf hd.Test(s) Then
                If Len(pending) > 0 Then
                    Set n = RC_Node("U" & pendingLine, "unknown", "", "", pending, pendingLine)
                    extras.Add n
                    RC_AddIssue issues, "解析", source & " 段落" & pendingLine, "連続見出しの先行段落を別掲保全。", pending
                End If
                pending = s: pendingLine = ln
            ElseIf Not a Is Nothing And pr.Test(s) Then
                Set m = pr.Execute(s)(0)
                Set para = RC_Node(a("id") & ".P" & Format$(a("children").Count + 1, "000"), "paragraph", CStr(m.SubMatches(0)), CStr(m.SubMatches(1)), CStr(m.SubMatches(2)), ln)
                a("children").Add para
            ElseIf Not para Is Nothing And it.Test(s) Then
                Set m = it.Execute(s)(0)
                Set n = RC_Node(para("id") & ".I" & Format$(para("children").Count + 1, "000"), "item", CStr(m.SubMatches(0)), CStr(m.SubMatches(1)), CStr(m.SubMatches(2)), ln)
                para("children").Add n
            ElseIf articles.Count = 0 And Len(result("title")) = 0 And Len(pending) = 0 Then
                result("title") = s
            Else
                Set n = RC_Node("U" & ln, "unknown", "", "", s, ln)
                If Not para Is Nothing Then
                    para("children").Add n
                Else
                    extras.Add n
                End If
                RC_AddIssue issues, "解析", source & " 段落" & ln, "未認識段落を全文保全。別表/続き段落/見出し構造を確認してください。", s
            End If
        End If
    Next i
    If Len(pending) > 0 Then
        Set n = RC_Node("U" & pendingLine, "unknown", "", "", pending, pendingLine): extras.Add n
        RC_AddIssue issues, "解析", source & " 段落" & pendingLine, "末尾の未対応見出しを別掲保全。", pending
    End If
    If articles.Count = 0 Then RC_AddIssue issues, "解析", source, "条を認識できませんでした。本文は別掲で全文保全。", result("title")
    Set RC_ParseLines = result
End Function

Public Function RC_NodeText(ByVal n As Object, Optional ByVal includePrefix As Boolean = False) As String
    Dim child As Variant, s As String
    If includePrefix Then s = n("heading") & vbCr & n("raw") Else s = n("body")
    For Each child In n("children")
        s = s & vbCr & RC_NodeText(child, includePrefix)
    Next child
    RC_NodeText = s
End Function


' Reportを外した後も使う共通処理。確認レポートは出力しない。
Public Sub RC_AddIssue(ByVal issues As Collection, ByVal kind As String, ByVal location As String, ByVal reason As String, ByVal raw As String)
    Dim issue As Object
    Set issue = RC_Dict()
    issue.Add "kind", kind: issue.Add "location", location: issue.Add "reason", reason: issue.Add "raw", raw
    issues.Add issue
End Sub
