Public Sub 構造解析_素材を作成

Option Explicit

' ==== 公開エントリーポイント ===========================================
Public Sub 構造解析_素材を作成()
    ' 元：コード（TrimCode, コメント行フラグ, ProcID, LineNo, コードラインID）
    ' 先：構造解析行（1文＝1レコード）
    
    Dim db As DAO.Database
    Dim rsSrc As DAO.Recordset
    Dim rsDst As DAO.Recordset
    
    Dim lngCurrentProcID As Long
    Dim strBuf As String                ' 行継続を結合するバッファ
    Dim blnInContinuation As Boolean    ' 継続行の最中か
    
    Dim strSQL As String
    Dim lngTokenSeq As Long             ' @txt の通し番号（ジョブ内で一意）
    
    On Error GoTo EH
    
    Set db = CurrentDb
    
    ' 出力を一旦クリア（必要に応じてコメントアウト）
    db.Execute "DELETE FROM 構造解析行", dbFailOnError
    
    ' 解析対象を取得：コメント行は除外、ProcID→LineNo で安定順
    strSQL = _
        "SELECT コードラインID, ProcID, LineNo, TrimCode, コメント行フラグ " & _
        "FROM コード " & _
        "WHERE Nz(コメント行フラグ, False) = False " & _
        "ORDER BY ProcID, LineNo"
    Set rsSrc = db.OpenRecordset(strSQL, dbOpenSnapshot)
    Set rsDst = db.OpenRecordset("構造解析行", dbOpenDynaset)
    
    lngCurrentProcID = 0
    strBuf = vbNullString
    blnInContinuation = False
    lngTokenSeq = 0
    
    Do While Not rsSrc.EOF
        Dim procID As Long
        Dim lineID As Long
        Dim lineText As String
        
        procID = Nz(rsSrc!ProcID, 0)
        lineID = Nz(rsSrc!コードラインID, 0)
        lineText = Nz(rsSrc!TrimCode, vbNullString)
        
        ' プロシージャが変わったら、未処理バッファを吐き出してリセット
        If lngCurrentProcID <> 0 And procID <> lngCurrentProcID Then
            If Len(strBuf) > 0 Then
                Call 出力_構造解析行(rsDst, lngCurrentProcID, lineID, strBuf, lngTokenSeq)
                strBuf = vbNullString
                blnInContinuation = False
            End If
        End If
        lngCurrentProcID = procID
        
        ' 空行は無視
        If Len(Trim$(lineText)) = 0 Then
            rsSrc.MoveNext
            GoTo ContinueLoop
        End If
        
        ' 行継続の判定（末尾がアンダースコア。末尾空白は無視）
        Dim hasCont As Boolean
        hasCont = 行継続あり(lineText)
        
        ' バッファへ結合（末尾の _ とその手前の空白を除去してから結合）
        If hasCont Then
            strBuf = strBuf & " " & 継続記号を外す(lineText)
            blnInContinuation = True
        Else
            ' 最終行：これで1つの“文候補の束”が完成
            strBuf = strBuf & " " & lineText
            ' ここで整形・分割して出力
            Call 出力_構造解析行(rsDst, procID, lineID, strBuf, lngTokenSeq)
            ' リセット
            strBuf = vbNullString
            blnInContinuation = False
        End If
        
ContinueLoop:
        rsSrc.MoveNext
    Loop
    
    ' ファイル末尾で継続バッファが残っていれば出力
    If Len(strBuf) > 0 Then
        Call 出力_構造解析行(rsDst, lngCurrentProcID, 0, strBuf, lngTokenSeq)
    End If
    
    rsDst.Close
    rsSrc.Close
    Set rsDst = Nothing
    Set rsSrc = Nothing
    Set db = Nothing
    
    MsgBox "構造解析の素材作成が完了しました。", vbInformation
    Exit Sub
    
EH:
    MsgBox "エラー: " & Err.Number & " / " & Err.Description, vbExclamation
End Sub

' ==== 1束のテキスト（継続解決済み）を「構造解析行」へ出力 =================
Private Sub 出力_構造解析行(ByRef rsDst As DAO.Recordset, _
                        ByVal procID As Long, _
                        ByVal anyLineID As Long, _
                        ByVal mergedLine As String, _
                        ByRef tokenSeq As Long)
    ' ここで：文字列→@txt 置換 → 行内コメント削除 → コロン分割 → 空白整え
    
    Dim tokList As Collection
    Dim mapText As String
    Dim work As String
    Dim parts() As String
    Dim i As Long, sentIdx As Long
    
    work = Trim$(mergedLine)
    If Len(work) = 0 Then Exit Sub
    
    ' 1) 文字列を @txtN へ置換し、対応表を作る
    Set tokList = New Collection
    work = 文字列をトークン化(work, tokList, tokenSeq)
    mapText = トークン一覧を文字列化(tokList)
    
    ' 2) 行内コメントを除去（' と Rem）
    work = 行内コメントを削除(work)
    
    ' 空になったら出力不要
    If Len(Trim$(work)) = 0 Then Exit Sub
    
    ' 3) コロンで分割（すでに文字列は @txt に退避済み）
    parts = 文を分割(work)
    
    ' 4) 各文を空白整形して保存
    sentIdx = 0
    For i = LBound(parts) To UBound(parts)
        Dim sent As String
        sent = 空白を整える(parts(i))
        If Len(sent) = 0 Then GoTo NextI
        
        sentIdx = sentIdx + 1
        
        rsDst.AddNew
        rsDst!コードラインID = anyLineID
        rsDst!ProcID = procID
        rsDst!文インデックス = sentIdx
        rsDst!構造解析用コード = sent
        rsDst!文字列トークン一覧 = mapText
        rsDst!生成日時 = Now
        rsDst.Update
NextI:
    Next i
End Sub

' ==== 行継続判定／末尾 _ の除去 ============================================
Private Function 行継続あり(ByVal s As String) As Boolean
    Dim t As String: t = 右端空白を削除(s)
    行継続あり = (Len(t) > 0 And Right$(t, 1) = "_")
End Function

Private Function 継続記号を外す(ByVal s As String) As String
    Dim t As String: t = 右端空白を削除(s)
    If Len(t) > 0 And Right$(t, 1) = "_" Then
        t = Left$(t, Len(t) - 1)
    End If
    継続記号を外す = 右端空白を削除(t)
End Function

Private Function 右端空白を削除(ByVal s As String) As String
    Do While Len(s) > 0
        Dim ch As String: ch = Right$(s, 1)
        If ch = " " Or ch = vbTab Then
            s = Left$(s, Len(s) - 1)
        Else
            Exit Do
        End If
    Loop
    右端空白を削除 = s
End Function

' ==== 文字列 → @txtN 置換（"" は1文字の " として扱う） =====================
Private Function 文字列をトークン化(ByVal s As String, _
                                ByRef tokList As Collection, _
                                ByRef tokenSeq As Long) As String
    Dim i As Long, n As Long
    Dim res As String
    Dim inStr As Boolean
    Dim startPos As Long
    
    n = Len(s)
    i = 1
    res = ""
    inStr = False
    startPos = 0
    
    Do While i <= n
        Dim c As String
        c = Mid$(s, i, 1)
        
        If Not inStr Then
            If c = """" Then
                ' 文字列開始
                inStr = True
                startPos = i
            Else
                res = res & c
            End If
            i = i + 1
        Else
            ' 文字列内
            If c = """" Then
                If i < n And Mid$(s, i + 1, 1) = """" Then
                    ' エスケープ（""）は1文字の " として継続
                    i = i + 2
                Else
                    ' 文字列終端
                    Dim rawStr As String
                    rawStr = Mid$(s, startPos, i - startPos + 1) ' 引用符込み
                    
                    tokenSeq = tokenSeq + 1
                    Dim tkn As String
                    tkn = "@txt" & CStr(tokenSeq)
                    
                    ' 置換
                    res = res & tkn
                    
                    ' 対応表へ追加
                    tokList.Add rawStr, tkn
                    
                    inStr = False
                    i = i + 1
                End If
            Else
                i = i + 1
            End If
        End If
    Loop
    
    ' 終端抜け（不正な "）は、そのまま返す
    文字列をトークン化 = res
End Function

Private Function トークン一覧を文字列化(ByVal tokList As Collection) As String
    Dim i As Long
    Dim sb As String
    For i = 1 To tokList.Count
        Dim key As String
        key = tokList.Key(i)
        If Len(sb) > 0 Then sb = sb & ";"
        sb = sb & key & "=" & tokList(i)  ' 例：@txt1="ProcName"
    Next i
    トークン一覧を文字列化 = sb
End Function

' ==== 行内コメント削除（' と Rem） =======================================
Private Function 行内コメントを削除(ByVal s As String) As String
    Dim pApo As Long, pRem As Long, t As String
    
    ' アポストロフィ以降
    pApo = InStr(1, s, "'", vbBinaryCompare)
    If pApo > 0 Then s = Left$(s, pApo - 1)
    
    ' Rem は行頭または空白の直後のみ有効とみなす
    ' 簡易に LCase で検索してもよい
    Dim sL As String: sL = LCase$(s)
    pRem = InStr(1, sL, " rem ", vbBinaryCompare)
    If pRem = 1 Then
        s = ""
    ElseIf pRem > 1 Then
        ' 手前が空白なら Rem 以降をカット
        If Mid$(s, pRem - 1, 1) = " " Then
            s = Left$(s, pRem - 1)
        End If
    End If
    
    行内コメントを削除 = Trim$(s)
End Function

' ==== コロン分割（@txt 置換済みなので安全） ===============================
Private Function 文を分割(ByVal s As String) As String()
    Dim parts() As String
    Dim tmp As String
    Dim i As Long, cnt As Long
    Dim startPos As Long
    
    ' 連続コロンや前後空白にも耐えるよう手作り分割
    ReDim parts(0 To 0)
    startPos = 1
    For i = 1 To Len(s)
        If Mid$(s, i, 1) = ":" Then
            tmp = Trim$(Mid$(s, startPos, i - startPos))
            If Len(tmp) > 0 Then
                Call 追加(parts, tmp)
            End If
            startPos = i + 1
        End If
    Next i
    tmp = Trim$(Mid$(s, startPos))
    If Len(tmp) > 0 Then Call 追加(parts, tmp)
    
    文を分割 = parts
End Function

Private Sub 追加(ByRef arr() As String, ByVal v As String)
    Dim n As Long
    If Len(arr(0)) = 0 And UBound(arr) = 0 Then
        arr(0) = v
        Exit Sub
    End If
    n = UBound(arr) + 1
    ReDim Preserve arr(0 To n)
    arr(n) = v
End Sub

' ==== 空白の整え（タブ→空白、連続空白の圧縮、前後空白削除） ==============
Private Function 空白を整える(ByVal s As String) As String
    s = Replace$(s, vbTab, " ")
    ' 連続空白を1つに
    Do While InStr(s, "  ") > 0
        s = Replace$(s, "  ", " ")
    Loop
    空白を整える = Trim$(s)
End Function