サンプルコード

Option Explicit

' =========================
' Entry Point
' =========================
Public Sub BuildParseMaterial()
    ' 元テーブル（必須列）:
    '   [コード].[コードラインID], [コード].[ProcID], [コード].[LineNo], [コード].[TrimCode], [コード].[コメント行フラグ]
    ' 出力テーブル:
    '   [構造解析行]（既に作成済み）
    
    Dim objDb As DAO.Database
    Dim rsSrc As DAO.Recordset
    Dim rsDst As DAO.Recordset
    
    Dim lngCurrentProcID As Long
    Dim strBuffer As String
    Dim blnInContinuation As Boolean
    Dim lngTokenSeq As Long          ' @txt の通し番号（ジョブ内で一意）
    
    Dim strSql As String
    
    On Error GoTo EH
    
    Set objDb = CurrentDb
    
    ' 出力を初期化（必要に応じてコメントアウト可）
    objDb.Execute "DELETE FROM [構造解析行]", dbFailOnError
    
    ' 解析対象の取得：コメント行は除外し、ProcID→LineNoで安定化
    strSql = ""
    strSql = strSql & "SELECT [コード].[コードラインID], [コード].[ProcID], [コード].[LineNo], [コード].[TrimCode], Nz([コード].[コメント行フラグ], False) AS コメント行フラグ "
    strSql = strSql & "FROM [コード] "
    strSql = strSql & "WHERE Nz([コード].[コメント行フラグ], False) = False "
    strSql = strSql & "ORDER BY [コード].[ProcID], [コード].[LineNo]"
    
    Set rsSrc = objDb.OpenRecordset(strSql, dbOpenSnapshot)
    Set rsDst = objDb.OpenRecordset("[構造解析行]", dbOpenDynaset)
    
    lngCurrentProcID = 0
    strBuffer = vbNullString
    blnInContinuation = False
    lngTokenSeq = 0
    
    Do While Not rsSrc.EOF
        Dim lngProcID As Long
        Dim lngLineID As Long
        Dim strLine As String
        Dim blnHasCont As Boolean
        
        lngProcID = Nz(rsSrc.Fields("ProcID").Value, 0&)
        lngLineID = Nz(rsSrc.Fields("コードラインID").Value, 0&)
        strLine = Nz(rsSrc.Fields("TrimCode").Value, vbNullString)
        
        ' プロシージャ切替時：バッファ吐き出し
        If (lngCurrentProcID <> 0) And (lngProcID <> lngCurrentProcID) Then
            If Len(strBuffer) > 0 Then
                Call WriteParsedRows(rsDst, lngCurrentProcID, lngLineID, strBuffer, lngTokenSeq)
                strBuffer = vbNullString
                blnInContinuation = False
            End If
        End If
        lngCurrentProcID = lngProcID
        
        ' 実質空行はスキップ
        If Len(Trim$(strLine)) = 0 Then
            rsSrc.MoveNext
            GoTo ContinueLoop
        End If
        
        ' 行継続の判定
        blnHasCont = HasLineContinuation(strLine)
        
        If blnHasCont Then
            ' 末尾の「 _」を外して結合
            strBuffer = Trim$(strBuffer & " " & StripContinuationSuffix(strLine))
            blnInContinuation = True
        Else
            ' 最終行：ここでひと束完成 → 整形して出力
            strBuffer = Trim$(strBuffer & " " & strLine)
            Call WriteParsedRows(rsDst, lngProcID, lngLineID, strBuffer, lngTokenSeq)
            strBuffer = vbNullString
            blnInContinuation = False
        End If
        
ContinueLoop:
        rsSrc.MoveNext
    Loop
    
    ' ファイル末尾の残りを出力
    If Len(strBuffer) > 0 Then
        Call WriteParsedRows(rsDst, lngCurrentProcID, 0&, strBuffer, lngTokenSeq)
    End If
    
    rsDst.Close: Set rsDst = Nothing
    rsSrc.Close: Set rsSrc = Nothing
    Set objDb = Nothing
    
    MsgBox "構造解析の素材作成が完了しました。", vbInformation
    Exit Sub
    
EH:
    MsgBox "エラー " & Err.Number & " : " & Err.Description, vbExclamation
    On Error Resume Next
    If Not rsDst Is Nothing Then rsDst.Close
    If Not rsSrc Is Nothing Then rsSrc.Close
    Set rsDst = Nothing
    Set rsSrc = Nothing
    Set objDb = Nothing
End Sub

' =========================
' Core: 1束 → 1文ずつ出力
' =========================
Private Sub WriteParsedRows(ByRef rsDst As DAO.Recordset, _
                            ByVal lngProcID As Long, _
                            ByVal lngAnyLineID As Long, _
                            ByVal strMerged As String, _
                            ByRef lngTokenSeq As Long)
    Dim strWork As String
    Dim strTokenMap As String
    Dim arrSentences() As String
    Dim lngI As Long
    Dim lngSentIdx As Long
    
    strWork = Trim$(strMerged)
    If Len(strWork) = 0 Then Exit Sub
    
    ' 1) 文字列 → @txtN 置換（対応表は文字列で保持）
    strTokenMap = vbNullString
    strWork = TokenizeStrings(strWork, strTokenMap, lngTokenSeq)
    
    ' 2) 行内コメントの削除（' と Rem）
    strWork = RemoveInlineComment(strWork)
    If Len(Trim$(strWork)) = 0 Then Exit Sub
    
    ' 3) コロン（:）で文に分割（@txt に退避済みなので安全）
    arrSentences = SplitStatements(strWork)
    
    ' 4) 各文を整形して保存
    lngSentIdx = 0
    For lngI = LBound(arrSentences) To UBound(arrSentences)
        Dim strSentence As String
        strSentence = NormalizeSpaces(arrSentences(lngI))
        If Len(strSentence) = 0 Then GoTo NextI
        
        lngSentIdx = lngSentIdx + 1
        
        rsDst.AddNew
        rsDst.Fields("コードラインID").Value = lngAnyLineID
        rsDst.Fields("ProcID").Value = lngProcID
        rsDst.Fields("文インデックス").Value = lngSentIdx
        rsDst.Fields("構造解析用コード").Value = strSentence
        rsDst.Fields("文字列トークン一覧").Value = strTokenMap
        rsDst.Fields("生成日時").Value = Now
        rsDst.Update
NextI:
    Next lngI
End Sub

' =========================
' Helpers: 行継続
' =========================
Private Function HasLineContinuation(ByVal strS As String) As Boolean
    Dim strT As String
    strT = RTrimSpaces(strS)
    HasLineContinuation = (Len(strT) > 0 And Right$(strT, 1) = "_")
End Function

Private Function StripContinuationSuffix(ByVal strS As String) As String
    Dim strT As String
    strT = RTrimSpaces(strS)
    If Len(strT) > 0 And Right$(strT, 1) = "_" Then
        strT = Left$(strT, Len(strT) - 1)
    End If
    StripContinuationSuffix = RTrimSpaces(strT)
End Function

Private Function RTrimSpaces(ByVal strS As String) As String
    Do While Len(strS) > 0
        Dim strCh As String
        strCh = Right$(strS, 1)
        If (strCh = " ") Or (strCh = vbTab) Then
            strS = Left$(strS, Len(strS) - 1)
        Else
            Exit Do
        End If
    Loop
    RTrimSpaces = strS
End Function

' =========================
' Helpers: 文字列 → @txtN
' =========================
Private Function TokenizeStrings(ByVal strS As String, _
                                 ByRef strTokenMap As String, _
                                 ByRef lngTokenSeq As Long) As String
    Dim lngI As Long, lngN As Long
    Dim blnInString As Boolean
    Dim lngStart As Long
    Dim strRes As String
    
    lngN = Len(strS)
    lngI = 1
    blnInString = False
    lngStart = 0
    strRes = vbNullString
    
    Do While lngI <= lngN
        Dim strC As String
        strC = Mid$(strS, lngI, 1)
        
        If Not blnInString Then
            If strC = """" Then
                blnInString = True
                lngStart = lngI
            Else
                strRes = strRes & strC
            End If
            lngI = lngI + 1
        Else
            ' 文字列内
            If strC = """" Then
                If (lngI < lngN) And (Mid$(strS, lngI + 1, 1) = """") Then
                    ' 連続の "" はエスケープ（1文字の "）
                    lngI = lngI + 2
                Else
                    ' 文字列終端
                    Dim strRaw As String
                    Dim strTkn As String
                    strRaw = Mid$(strS, lngStart, lngI - lngStart + 1) ' 引用符込み
                    
                    lngTokenSeq = lngTokenSeq + 1
                    strTkn = "@txt" & CStr(lngTokenSeq)
                    
                    strRes = strRes & strTkn
                    
                    ' マッピング文字列へ追記 （区切りは ; ）
                    If Len(strTokenMap) > 0 Then strTokenMap = strTokenMap & ";"
                    strTokenMap = strTokenMap & strTkn & "=" & strRaw
                    
                    blnInString = False
                    lngI = lngI + 1
                End If
            Else
                lngI = lngI + 1
            End If
        End If
    Loop
    
    ' 不正な未終端の " があっても、そのまま返す（後工程で検出可能）
    TokenizeStrings = strRes
End Function

' =========================
' Helpers: コメント削除
' =========================
Private Function RemoveInlineComment(ByVal strS As String) As String
    Dim lngApo As Long
    Dim lngRem As Long
    Dim strL As String
    Dim strOut As String
    
    strOut = strS
    
    ' アポストロフィ（'）以降を削除
    lngApo = InStr(1, strOut, "'", vbBinaryCompare)
    If lngApo > 0 Then
        strOut = Left$(strOut, lngApo - 1)
    End If
    
    ' Rem は行頭または空白の直後を有効とみなす（簡易）
    strL = LCase$(strOut)
    lngRem = InStr(1, strL, " rem ", vbBinaryCompare)
    If lngRem = 1 Then
        strOut = ""
    ElseIf lngRem > 1 Then
        If Mid$(strOut, lngRem - 1, 1) = " " Then
            strOut = Left$(strOut, lngRem - 1)
        End If
    End If
    
    RemoveInlineComment = Trim$(strOut)
End Function

' =========================
' Helpers: 文分割（:）
' =========================
Private Function SplitStatements(ByVal strS As String) As String()
    Dim arr() As String
    Dim lngI As Long
    Dim lngStart As Long
    Dim strTmp As String
    
    ReDim arr(0 To 0)
    lngStart = 1
    
    For lngI = 1 To Len(strS)
        If Mid$(strS, lngI, 1) = ":" Then
            strTmp = Trim$(Mid$(strS, lngStart, lngI - lngStart))
            If Len(strTmp) > 0 Then Call AppendString(arr, strTmp)
            lngStart = lngI + 1
        End If
    Next lngI
    
    strTmp = Trim$(Mid$(strS, lngStart))
    If Len(strTmp) > 0 Then Call AppendString(arr, strTmp)
    
    SplitStatements = arr
End Function

Private Sub AppendString(ByRef arr() As String, ByVal strV As String)
    Dim lngN As Long
    If (UBound(arr) = 0) And (Len(arr(0)) = 0) Then
        arr(0) = strV
        Exit Sub
    End If
    lngN = UBound(arr) + 1
    ReDim Preserve arr(0 To lngN)
    arr(lngN) = strV
End Sub

' =========================
' Helpers: 空白整形
' =========================
Private Function NormalizeSpaces(ByVal strS As String) As String
    Dim strOut As String
    strOut = Replace$(strS, vbTab, " ")
    Do While InStr(strOut, "  ") > 0
        strOut = Replace$(strOut, "  ", " ")
    Loop
    NormalizeSpaces = Trim$(strOut)
End Function