Option Explicit
't07a_論理コード：継続行 _ を先頭に畳んで 1レコード=1論理文。
' CodeIDは読まない／TrimCodeHashは使う／診断表なし／完了メッセージあり。
' 実行順：CreateT07aTable → BuildLogicalCode
Public Sub CreateT07aTable()
Dim db As DAO.Database
Set db = CurrentDb
If TableExists07("t07a_論理コード") Then
MsgBox "t07a_論理コード は既に存在します。作成をスキップしました。", vbInformation
Exit Sub
End If
db.Execute "CREATE TABLE [t07a_論理コード] (" & _
"論理行ID LONG CONSTRAINT PK_t07a PRIMARY KEY, " & _
"プロシージャID LONG, " & _
"先頭コードラインID LONG, " & _
"末尾コードラインID LONG, " & _
"連結行数 LONG, " & _
"論理コード MEMO, " & _
"コメント行 YESNO, " & _
"空白行 YESNO, " & _
"シェイプ作成対象 YESNO, " & _
"シェイプ作成対象外 YESNO, " & _
"シェイプID LONG, " & _
"TrimCodeHash TEXT(16))", dbFailOnError
MsgBox "t07a_論理コード を作成しました。", vbInformation
End Sub
Public Sub BuildLogicalCode()
Dim db As DAO.Database
Set db = CurrentDb
If Not TableExists07("t07a_論理コード") Then
MsgBox "t07a_論理コード がありません。先に CreateT07aTable を実行してください。", vbCritical
Exit Sub
End If
db.Execute "DELETE FROM [t07a_論理コード]", dbFailOnError
Dim n As Long
n = DCount("*", "t01a_コード")
If n = 0 Then Exit Sub
Dim aP() As Long, aCid() As Long, aTC() As String
Dim aCmt() As Boolean, aBlk() As Boolean, aHash() As String
ReDim aP(1 To n): ReDim aCid(1 To n): ReDim aTC(1 To n)
ReDim aCmt(1 To n): ReDim aBlk(1 To n): ReDim aHash(1 To n)
Dim rsIn As DAO.Recordset
Set rsIn = db.OpenRecordset( _
"SELECT プロシージャID, コードラインID, TrimCode, コメント行, 空白行, TrimCodeHash " & _
"FROM [t01a_コード] ORDER BY プロシージャID, コードラインID", dbOpenSnapshot)
Dim i As Long
i = 0
Do While Not rsIn.EOF
i = i + 1
aP(i) = CLng(Nz(rsIn.Fields("プロシージャID").Value, 0))
aCid(i) = CLng(Nz(rsIn.Fields("コードラインID").Value, 0))
aTC(i) = CStr(Nz(rsIn.Fields("TrimCode").Value, ""))
aCmt(i) = (rsIn.Fields("コメント行").Value = True)
aBlk(i) = (rsIn.Fields("空白行").Value = True)
aHash(i) = CStr(Nz(rsIn.Fields("TrimCodeHash").Value, ""))
rsIn.MoveNext
Loop
rsIn.Close
Dim rsOut As DAO.Recordset
Set rsOut = db.OpenRecordset("SELECT * FROM [t07a_論理コード]", dbOpenDynaset)
Dim seq As Long: seq = 0
Dim k As Long: k = 1
Do While k <= n
Dim curProc As Long, headLine As Long
Dim headCmt As Boolean, headBlk As Boolean, headHash As String
Dim buf As String, cnt As Long, lastLine As Long
curProc = aP(k): headLine = aCid(k)
headCmt = aCmt(k): headBlk = aBlk(k): headHash = aHash(k)
buf = "": cnt = 0
Dim j As Long: j = k
Do
Dim seg As String, cont As Boolean
seg = aTC(j)
cont = IsContinuation(seg, aCmt(j))
If cont Then seg = DropTrailingUnderscore(seg)
If Len(buf) = 0 Then buf = seg Else buf = buf & " " & seg
cnt = cnt + 1
lastLine = aCid(j)
If cont And j < n Then
If aP(j + 1) = curProc Then j = j + 1 Else Exit Do
Else
Exit Do
End If
Loop
seq = seq + 1
rsOut.AddNew
rsOut.Fields("論理行ID").Value = seq
rsOut.Fields("プロシージャID").Value = curProc
rsOut.Fields("先頭コードラインID").Value = headLine
rsOut.Fields("末尾コードラインID").Value = lastLine
rsOut.Fields("連結行数").Value = cnt
rsOut.Fields("論理コード").Value = buf
rsOut.Fields("コメント行").Value = headCmt
rsOut.Fields("空白行").Value = headBlk
rsOut.Fields("シェイプ作成対象").Value = False
rsOut.Fields("シェイプ作成対象外").Value = False
rsOut.Fields("シェイプID").Value = Null
rsOut.Fields("TrimCodeHash").Value = headHash
rsOut.Update
k = j + 1
Loop
rsOut.Close
MsgBox "t07a_論理コード を作成しました。論理文 " & seq & " 件。", vbInformation
End Sub
Private Function IsContinuation(ByVal s As String, ByVal isCmt As Boolean) As Boolean
IsContinuation = False
If isCmt Then Exit Function
Dim t As String
t = RTrim$(s)
If Len(t) >= 2 Then
If Right$(t, 1) = "_" Then
Dim c As String
c = Mid$(t, Len(t) - 1, 1)
If c = " " Or c = vbTab Then IsContinuation = True
End If
End If
End Function
Private Function DropTrailingUnderscore(ByVal s As String) As String
Dim t As String
t = RTrim$(s)
If Right$(t, 1) = "_" Then t = Left$(t, Len(t) - 1)
DropTrailingUnderscore = RTrim$(t)
End Function
Private Function TableExists07(ByVal nm As String) As Boolean
Dim td As DAO.TableDef
On Error Resume Next
Set td = CurrentDb.TableDefs(nm)
TableExists07 = (Not td Is Nothing)
On Error GoTo 0
End Function
Excel