feat: restore VBA source code modules

Co-Authored-By: Claude Sonnet 4.5 <noreply@anthropic.com>

VBA/ClassModules/clsErrorLogger.cls

@@ -0,0 +1,55 @@
+' ==============================================================================
+' 类模块: clsErrorLogger
+' 职责: 错误日志记录器 (修正版：移除UDT，使用数组存储)
+' ==============================================================================
+Option Explicit
+
+Private pErrors As Collection
+
+Private Sub Class_Initialize()
+    Set pErrors = New Collection
+End Sub
+
+' 记录错误
+Public Sub Record(RowIndex As Long, SourceFunc As String, ErrorType As String, Desc As String, Context As String)
+    ' 使用数组存储单条错误信息：行号, 来源, 类型, 描述, 上下文
+    pErrors.Add Array(RowIndex, SourceFunc, ErrorType, Desc, Context)
+End Sub
+
+' 是否有错误
+Public Property Get HasErrors() As Boolean
+    HasErrors = (pErrors.count > 0)
+End Property
+
+' 输出报告到新工作表
+Public Sub PrintReport(targetWb As Workbook)
+    If pErrors.count = 0 Then Exit Sub
+
+    Dim ws As Worksheet
+    Set ws = targetWb.Worksheets.Add(After:=targetWb.Worksheets(targetWb.Worksheets.count))
+    ws.Name = "错误报告_" & Format(Now, "hhmmss")
+
+    ' 表头
+    ws.Range("A1:E1").Value = Array("原表行号", "来源模块", "错误类型", "详细描述", "原始数据")
+    ws.Range("A1:E1").Font.Bold = True
+    ws.Range("A1:E1").Interior.Color = RGB(255, 200, 200)
+
+    ' 准备输出数组
+    Dim arrOutput() As Variant
+    ReDim arrOutput(1 To pErrors.count, 1 To 5)
+
+    Dim i As Long
+    Dim vItem As Variant
+
+    For i = 1 To pErrors.count
+        vItem = pErrors(i)
+        arrOutput(i, 1) = vItem(0)
+        arrOutput(i, 2) = vItem(1)
+        arrOutput(i, 3) = vItem(2)
+        arrOutput(i, 4) = vItem(3)
+        arrOutput(i, 5) = vItem(4)
+    Next i
+
+    ws.Range("A2").Resize(UBound(arrOutput, 1), 5).Value = arrOutput
+    ws.Columns.AutoFit
+End Sub

VBA/Modules/M01_Main.bas

@@ -0,0 +1,110 @@
+' ==============================================================================
+' 模块: M01_Main
+' 职责: 程序入口，调度器，UI交互(进度条)
+' ==============================================================================
+Option Explicit
+
+Public Sub RunBOMConversion()
+    Dim wsSrc As Worksheet
+    Dim arrData As Variant
+    Dim logger As New clsErrorLogger
+    Dim i As Long
+    ' 使用 Dictionary 替代 Collection 来存储类别，方便查找
+    Dim catData As Object
+    Set catData = CreateObject("Scripting.Dictionary")
+
+    ' 1. 环境初始化
+    On Error GoTo MainErrorHandler
+    'Application.ScreenUpdating = False
+    Application.Calculation = xlCalculationManual
+
+    ' 2. 检查工作表
+    On Error Resume Next
+    Set wsSrc = ActiveWorkbook.Sheets("平台配置清单")
+    On Error GoTo MainErrorHandler
+
+    If wsSrc Is Nothing Then
+        MsgBox "错误：未找到名为 '平台配置清单' 的工作表。", vbCritical
+        GoTo ExitHandler
+    End If
+
+    ' 读取数据
+    Application.StatusBar = "正在读取源数据..."
+    arrData = M02_DataIO.ReadSourceData(wsSrc)
+
+    If IsEmpty(arrData) Then
+        MsgBox "未找到数据。", vbExclamation
+        GoTo ExitHandler
+    End If
+
+    ' 3. 初始化逻辑模块
+    M03_Logic.InitLogic logger
+
+    ' 4. 主循环
+    Dim rowIdx As Long
+    Dim strCat As String, strCond As String
+    Dim colResult As Collection
+    Dim itm As Variant
+    Dim baseInfo As Variant
+
+    Dim totalRows As Long
+    Dim pct As Long
+    totalRows = UBound(arrData, 1)
+
+    For i = 1 To totalRows
+        rowIdx = M04_Config.SRC_START_ROW + i - 1
+        strCat = Trim(CStr(arrData(i, M04_Config.COL_IDX_CAT)))
+
+        ' --- 进度条更新 ---
+        pct = CLng((i / totalRows) * 100)
+        Application.StatusBar = "正在处理: " & pct & "% | 行: " & rowIdx & " | 类别: " & strCat
+        If i Mod 10 = 0 Then DoEvents ' 每10行刷新一次界面，防止卡顿但不过度拖慢速度
+        ' ------------------
+
+        ' 忽略空类别
+        If Len(strCat) > 0 Then
+            strCond = CStr(arrData(i, M04_Config.COL_IDX_COND))
+            If IsEmpty(arrData(i, M04_Config.COL_IDX_COND)) Then strCond = ""
+
+            ' 解析
+            Set colResult = M03_Logic.ParseRule(strCond, rowIdx)
+
+            If Not colResult Is Nothing Then
+                If Not catData.Exists(strCat) Then
+                    catData.Add strCat, New Collection
+                End If
+
+                ' 基础信息: 代号, 名称, 数量
+                baseInfo = Array(arrData(i, M04_Config.COL_IDX_CODE), _
+                                 arrData(i, M04_Config.COL_IDX_NAME), _
+                                 arrData(i, M04_Config.COL_IDX_QTY))
+
+                ' 将展开的记录存入
+                For Each itm In colResult
+                    catData(strCat).Add Array(itm, baseInfo)
+                Next itm
+            End If
+        End If
+    Next i
+
+    ' 5. 输出
+    Application.StatusBar = "正在生成新工作簿..."
+    M02_DataIO.WriteCategoryToNewBook catData
+
+    ' 6. 错误报告
+    If logger.HasErrors Then
+        logger.PrintReport ActiveWorkbook
+        MsgBox "转换完成，但发现部分数据存在逻辑冲突，已生成错误报告。", vbExclamation
+    End If
+
+ExitHandler:
+    ' 清理状态
+    Application.StatusBar = False
+    Application.ScreenUpdating = True
+    Application.Calculation = xlCalculationAutomatic
+    Exit Sub
+
+MainErrorHandler:
+    MsgBox "发生运行时错误: " & Err.Description, vbCritical
+    Resume ExitHandler
+End Sub

VBA/Modules/M02_DataIO.bas

@@ -0,0 +1,160 @@
+' ==============================================================================
+' 模块: M02_DataIO
+' 职责: 数据读写
+' ==============================================================================
+Option Explicit
+
+Public Function ReadSourceData(ws As Worksheet) As Variant
+    Dim lastRow As Long
+    ' 查找C列最后一行
+    lastRow = ws.Cells(ws.Rows.count, M04_Config.COL_IDX_CODE).End(xlUp).row
+
+    If lastRow < M04_Config.SRC_START_ROW Then
+        ReadSourceData = Empty
+        Exit Function
+    End If
+
+    ' 读取整张表的数据区域 (假设列数不超过20列，足以覆盖到类别列)
+    ReadSourceData = ws.Range(ws.Cells(M04_Config.SRC_START_ROW, 1), ws.Cells(lastRow, M04_Config.COL_IDX_CAT)).Value
+End Function
+
+Public Sub WriteCategoryToNewBook(catData As Object)
+    Dim newWb As Workbook
+    Dim ws As Worksheet
+    Dim catName As Variant
+    Dim colRows As Collection
+    Dim finalArr() As Variant
+    Dim headerKeys As Collection
+    Dim i As Long, r As Long, c As Long
+    Dim rowDict As Object
+    Dim key As Variant
+
+    If catData.count = 0 Then Exit Sub
+
+    Set newWb = Workbooks.Add
+
+    For Each catName In catData.keys
+        Set colRows = catData(catName)
+
+        If colRows.count > 0 Then
+            ' 创建新Sheet
+            Set ws = newWb.Worksheets.Add
+            ws.Name = CleanSheetName(CStr(catName))
+
+            ' 1. 扫描该类别所有Key
+            Dim allKeysDict As Object
+            Set allKeysDict = CreateObject("Scripting.Dictionary")
+
+            For i = 1 To colRows.count
+                ' colRows(i) 是一个 Array(Dict, BaseInfoArr)
+                Set rowDict = colRows(i)(0)
+                For Each key In rowDict.keys
+                    If Not allKeysDict.Exists(key) Then allKeysDict.Add key, 0
+                Next key
+            Next i
+
+            ' 2. 排序Key
+            Dim sortedHeaders() As String
+            sortedHeaders = SortHeaders(allKeysDict.keys)
+
+            ' 3. 准备输出数组
+            Dim condCount As Long
+            condCount = UBound(sortedHeaders) - LBound(sortedHeaders) + 1
+            ' 检查是否为空数组（如果全是无条件的物料）
+            If sortedHeaders(0) = "" And condCount = 1 Then condCount = 0
+
+            Dim totalCols As Long
+            totalCols = condCount + 3 ' 条件列 + 名称/编码/数量
+
+            ReDim finalArr(1 To colRows.count + 1, 1 To totalCols)
+
+            ' 3.1 写表头
+            Dim colOffset As Long
+            colOffset = 0
+
+            If condCount > 0 Then
+                For c = 0 To condCount - 1
+                    finalArr(1, c + 1) = sortedHeaders(c)
+                Next c
+                colOffset = condCount
+            End If
+
+            finalArr(1, colOffset + 1) = "名称"
+            finalArr(1, colOffset + 2) = "编码"
+            finalArr(1, colOffset + 3) = "数量"
+
+            ' 3.2 填充内容
+            For r = 1 To colRows.count
+                Dim baseInfo As Variant
+                Set rowDict = colRows(r)(0)
+                baseInfo = colRows(r)(1) ' Array: Code, Name, Qty
+
+                ' 填条件
+                If condCount > 0 Then
+                    For c = 0 To condCount - 1
+                        key = sortedHeaders(c)
+                        If rowDict.Exists(key) Then
+                            finalArr(r + 1, c + 1) = rowDict(key)
+                        End If
+                    Next c
+                End If
+
+                ' 填基础信息
+                finalArr(r + 1, colOffset + 1) = baseInfo(1) ' Name
+                finalArr(r + 1, colOffset + 2) = baseInfo(0) ' Code
+                finalArr(r + 1, colOffset + 3) = baseInfo(2) ' Qty
+            Next r
+
+            ' 4. 写入Excel
+            ws.Range("A1").Resize(UBound(finalArr, 1), UBound(finalArr, 2)).Value = finalArr
+            ws.Range("A1").Resize(1, totalCols).Font.Bold = True
+            ws.Columns.AutoFit
+        End If
+    Next catName
+
+    MsgBox "处理完成！", vbInformation
+End Sub
+
+Private Function SortHeaders(keys As Variant) As String()
+    ' 冒泡排序
+    Dim i As Long, j As Long
+    Dim temp As String
+    Dim arr() As String
+    Dim count As Long
+
+    count = UBound(keys) - LBound(keys) + 1
+
+    If count = 0 Then
+        ReDim arr(0 To 0)
+        arr(0) = ""
+        SortHeaders = arr
+        Exit Function
+    End If
+
+    ReDim arr(0 To count - 1)
+    For i = 0 To count - 1
+        arr(i) = keys(i)
+    Next i
+
+    For i = LBound(arr) To UBound(arr) - 1
+        For j = i + 1 To UBound(arr)
+            If M04_Config.GetHeaderPriority(arr(i)) > M04_Config.GetHeaderPriority(arr(j)) Then
+                temp = arr(i)
+                arr(i) = arr(j)
+                arr(j) = temp
+            End If
+        Next j
+    Next i
+
+    SortHeaders = arr
+End Function
+
+Private Function CleanSheetName(s As String) As String
+    Dim invalid As String, i As Long
+    invalid = ":\/?*[]"
+    CleanSheetName = s
+    For i = 1 To Len(invalid)
+        CleanSheetName = Replace(CleanSheetName, Mid(invalid, i, 1), "_")
+    Next i
+    If Len(CleanSheetName) > 31 Then CleanSheetName = Left(CleanSheetName, 31)
+End Function

VBA/Modules/M03_Logic.bas

@@ -0,0 +1,289 @@
+' ==============================================================================
+' 模块: M03_Logic
+' 职责: 核心算法。使用后期绑定(Late Binding)避免引用错误。
+' ==============================================================================
+Option Explicit
+
+Private g_Logger As clsErrorLogger
+
+' 初始化日志引用
+Public Sub InitLogic(logger As clsErrorLogger)
+    Set g_Logger = logger
+End Sub
+
+' ------------------------------------------------------------------------------
+' 主入口: 解析规则字符串
+' 返回: Collection (包含多个 Dictionary 对象)
+' ------------------------------------------------------------------------------
+Public Function ParseRule(strRule As String, rowIdx As Long) As Collection
+    On Error GoTo ErrorHandler
+
+    Dim cleanStr As String
+    cleanStr = CleanString(strRule)
+
+    ' 空条件处理
+    If Len(cleanStr) = 0 Then
+        Dim col As New Collection
+        ' 创建一个空字典
+        col.Add CreateObject("Scripting.Dictionary")
+        Set ParseRule = col
+        Exit Function
+    End If
+
+    Set ParseRule = RecursiveParse(cleanStr, rowIdx)
+    Exit Function
+
+ErrorHandler:
+    g_Logger.Record rowIdx, "M03.ParseRule", "System Error", Err.Description, strRule
+    Set ParseRule = Nothing
+End Function
+
+' ------------------------------------------------------------------------------
+' 递归解析核心
+' ------------------------------------------------------------------------------
+Private Function RecursiveParse(strExpr As String, rowIdx As Long) As Collection
+    Dim splitIdx As Long
+
+    ' 1. 查找顶层 OR (最低优先级，先拆分)
+    splitIdx = FindSplitIndex(strExpr, "OR")
+    If splitIdx > 0 Then
+        Dim leftRes As Collection, rightRes As Collection
+        ' 递归左边
+        Set leftRes = RecursiveParse(Trim(Left(strExpr, splitIdx - 1)), rowIdx)
+        ' 递归右边 (+2 是 OR 的长度)
+        Set rightRes = RecursiveParse(Trim(Mid(strExpr, splitIdx + 2)), rowIdx)
+        ' 合并结果 (Union)
+        Set RecursiveParse = UnionCollections(leftRes, rightRes)
+        Exit Function
+    End If
+
+    ' 2. 查找顶层 AND
+    splitIdx = FindSplitIndex(strExpr, "AND")
+    If splitIdx > 0 Then
+        Dim leftCol As Collection, rightCol As Collection
+        ' 递归左边
+        Set leftCol = RecursiveParse(Trim(Left(strExpr, splitIdx - 1)), rowIdx)
+        ' 递归右边 (+3 是 AND 的长度)
+        Set rightCol = RecursiveParse(Trim(Mid(strExpr, splitIdx + 3)), rowIdx)
+        ' 笛卡尔积 (Intersection/Merge)
+        Set RecursiveParse = CartesianProduct(leftCol, rightCol, rowIdx)
+        Exit Function
+    End If
+
+    ' 3. 去除外层括号
+    If Left(strExpr, 1) = "(" And Right(strExpr, 1) = ")" Then
+        ' 防止像 (A) AND (B) 这种情况被误去括号，但这里已经被 FindSplitIndex 过滤了顶层操作符，
+        ' 所以如果这里首尾是括号，且中间没有暴露的操作符，说明是包裹的整体，例如 ((A AND B))
+        Set RecursiveParse = RecursiveParse(Mid(strExpr, 2, Len(strExpr) - 2), rowIdx)
+        Exit Function
+    End If
+
+    ' 4. 原子解析 (Base Case)
+    Set RecursiveParse = ParseAtom(strExpr, rowIdx)
+
+End Function
+
+' ------------------------------------------------------------------------------
+' 原子解析: key=val 或 key!=val
+' ------------------------------------------------------------------------------
+Private Function ParseAtom(strAtom As String, rowIdx As Long) As Collection
+    Dim dict As Object ' Late Binding
+    Set dict = CreateObject("Scripting.Dictionary")
+
+    Dim p As Long
+    Dim key As String, val As String
+
+    ' 移除多余空格，但保留值中间可能存在的(虽然通常没有)
+    strAtom = Trim(strAtom)
+
+    If InStr(strAtom, "!=") > 0 Then
+        p = InStr(strAtom, "!=")
+        key = Trim(Left(strAtom, p - 1))
+        val = Trim(Mid(strAtom, p + 2))
+        dict.Add key, "!=" & val
+    ElseIf InStr(strAtom, "=") > 0 Then
+        p = InStr(strAtom, "=")
+        key = Trim(Left(strAtom, p - 1))
+        val = Trim(Mid(strAtom, p + 1))
+        dict.Add key, val
+    Else
+        ' 无法解析的格式
+        If Len(strAtom) > 0 Then
+             g_Logger.Record rowIdx, "M03.ParseAtom", "Syntax Error", "No = or != found", strAtom
+        End If
+    End If
+
+    Dim col As New Collection
+    col.Add dict
+    Set ParseAtom = col
+End Function
+
+' ------------------------------------------------------------------------------
+' 笛卡尔积: AND 逻辑
+' ------------------------------------------------------------------------------
+Private Function CartesianProduct(col1 As Collection, col2 As Collection, rowIdx As Long) As Collection
+    Dim res As New Collection
+    Dim d1 As Object, d2 As Object
+    Dim merged As Object
+    Dim i As Long, j As Long
+
+    If col1 Is Nothing Or col2 Is Nothing Then
+        Set CartesianProduct = Nothing
+        Exit Function
+    End If
+
+    For i = 1 To col1.count
+        For j = 1 To col2.count
+            Set d1 = col1(i)
+            Set d2 = col2(j)
+            Set merged = MergeDictionaries(d1, d2, rowIdx)
+            If Not merged Is Nothing Then
+                res.Add merged
+            End If
+        Next j
+    Next i
+
+    Set CartesianProduct = res
+End Function
+
+' ------------------------------------------------------------------------------
+' 集合合并: OR 逻辑
+' ------------------------------------------------------------------------------
+Private Function UnionCollections(col1 As Collection, col2 As Collection) As Collection
+    Dim res As New Collection
+    Dim item As Variant
+
+    If Not col1 Is Nothing Then
+        For Each item In col1
+            res.Add item
+        Next item
+    End If
+
+    If Not col2 Is Nothing Then
+        For Each item In col2
+            res.Add item
+        Next item
+    End If
+
+    Set UnionCollections = res
+End Function
+
+' ------------------------------------------------------------------------------
+' 字典合并 (处理冲突和 !=)
+' ------------------------------------------------------------------------------
+Private Function MergeDictionaries(d1 As Object, d2 As Object, rowIdx As Long) As Object
+    Dim res As Object
+    Set res = CreateObject("Scripting.Dictionary")
+
+    Dim k As Variant
+    Dim v1 As String, v2 As String
+
+    ' 复制 d1
+    For Each k In d1.keys
+        res.Add k, d1(k)
+    Next k
+
+    ' 合并 d2
+    For Each k In d2.keys
+        If res.Exists(k) Then
+            v1 = CStr(res(k))
+            v2 = CStr(d2(k))
+
+            If v1 = v2 Then
+                ' 相同，无视
+            ElseIf Left(v1, 2) = "!=" And Left(v2, 2) = "!=" Then
+                ' 都是不等于，合并
+                res(k) = v1 & "," & v2
+            ElseIf Left(v1, 2) = "!=" And Left(v2, 2) <> "!=" Then
+                ' v1!=, v2=
+                If v2 = Mid(v1, 3) Then
+                    g_Logger.Record rowIdx, "M03.Conflict", "Logic Conflict", "Equals disallowed value", k & ": " & v1 & " AND " & v2
+                    Set MergeDictionaries = Nothing: Exit Function
+                Else
+                    res(k) = v2
+                End If
+            ElseIf Left(v1, 2) <> "!=" And Left(v2, 2) = "!=" Then
+                ' v1=, v2!=
+                If v1 = Mid(v2, 3) Then
+                    g_Logger.Record rowIdx, "M03.Conflict", "Logic Conflict", "Equals disallowed value", k & ": " & v1 & " AND " & v2
+                    Set MergeDictionaries = Nothing: Exit Function
+                Else
+                    res(k) = v1
+                End If
+            Else
+                ' 都是等于，但值不同
+                g_Logger.Record rowIdx, "M03.Conflict", "Logic Conflict", "Mutually Exclusive", k & "=" & v1 & " AND " & v2
+                Set MergeDictionaries = Nothing: Exit Function
+            End If
+        Else
+            res.Add k, d2(k)
+        End If
+    Next k
+
+    Set MergeDictionaries = res
+End Function
+
+' ------------------------------------------------------------------------------
+' 查找逻辑分割点 (忽略括号内容)
+' ------------------------------------------------------------------------------
+Private Function FindSplitIndex(strExpr As String, delimiter As String) As Long
+    Dim i As Long
+    Dim bracketLevel As Long
+    Dim subStr As String
+    Dim lenDelim As Long
+    Dim checkStr As String
+
+    bracketLevel = 0
+    lenDelim = Len(delimiter)
+
+    ' 预处理：为了防止匹配到变量名里的字符，我们检查 " AND " (带空格)
+    ' 或者简单起见，我们假设变量名不包含 AND/OR 且大小写敏感
+    ' 这里采用严格括号计数
+
+    For i = 1 To Len(strExpr) - lenDelim + 1
+        subStr = Mid(strExpr, i, 1)
+
+        If subStr = "(" Then
+            bracketLevel = bracketLevel + 1
+        ElseIf subStr = ")" Then
+            bracketLevel = bracketLevel - 1
+        ElseIf bracketLevel = 0 Then
+            ' 只有在第0层括号时才匹配逻辑符
+            checkStr = Mid(strExpr, i, lenDelim)
+
+            ' 关键修正：确保匹配的是独立单词，而不是变量名的一部分
+            ' 简单判断：前后字符是空格，或者处于字符串边界
+            If UCase(checkStr) = delimiter Then
+                Dim isWord As Boolean
+                isWord = True
+
+                ' 检查前一个字符
+                If i > 1 Then
+                    If Mid(strExpr, i - 1, 1) <> " " And Mid(strExpr, i - 1, 1) <> ")" Then isWord = False
+                End If
+
+                ' 检查后一个字符
+                If i + lenDelim <= Len(strExpr) Then
+                    If Mid(strExpr, i + lenDelim, 1) <> " " And Mid(strExpr, i + lenDelim, 1) <> "(" Then isWord = False
+                End If
+
+                If isWord Then
+                    FindSplitIndex = i
+                    Exit Function
+                End If
+            End If
+        End If
+    Next i
+
+    FindSplitIndex = 0
+End Function
+
+Private Function CleanString(s As String) As String
+    ' 移除多余的空格，将换行符替换为空格
+    Dim temp As String
+    temp = Replace(s, vbCrLf, " ")
+    temp = Replace(temp, vbCr, " ")
+    temp = Replace(temp, vbLf, " ")
+    temp = Trim(temp)
+    CleanString = temp
+End Function

VBA/Modules/M04_Config.bas

@@ -0,0 +1,37 @@
+' ==============================================================================
+' 模块: M04_Config
+' 职责: 系统配置、常量定义
+' ==============================================================================
+Option Explicit
+
+' 源数据列号定义 (根据你的描述)
+Public Const COL_IDX_CODE As Long = 3      ' 代号 (C列)
+Public Const COL_IDX_NAME As Long = 4      ' 名称 (D列)
+Public Const COL_IDX_QTY As Long = 5       ' 数量 (E列)
+Public Const COL_IDX_COND As Long = 6      ' 选择条件 (F列)
+Public Const COL_IDX_CAT As Long = 8       ' 类别 (H列)
+Public Const SRC_START_ROW As Long = 4     ' 数据起始行
+
+' 获取表头排序索引 (越小越靠前)
+Public Function GetHeaderPriority(key As String) As Long
+    Dim vList As Variant
+    Dim i As Long
+
+    ' 定义标准排序顺序
+    vList = Array("azxs", "bkxs", "gclj", "jycz", "lcdw", "lcfw", _
+                  "fjgn", "btcy", "bp", "dskd", "nqlc", "bptx", _
+                  "jddj", "cpdm", "tsjz", "tsyq", "bpts", "kdxh")
+
+    Dim sKey As String
+    sKey = LCase(Trim(key))
+
+    For i = LBound(vList) To UBound(vList)
+        If sKey = LCase(vList(i)) Then
+            GetHeaderPriority = i
+            Exit Function
+        End If
+    Next i
+
+    ' 未知变量排在最后
+    GetHeaderPriority = 999
+End Function

VBA/Modules/M99_TestRunner.bas

@@ -0,0 +1,212 @@
+' ==============================================================================
+' 模块: M99_TestRunner
+' 职责: 单元测试，验证 M03_Logic 的核心算法
+' 依赖: M03_Logic, clsErrorLogger (无需引用 Scripting Runtime)
+' ==============================================================================
+Option Explicit
+
+Private m_Logger As clsErrorLogger
+Private m_FailCount As Long
+Private m_PassCount As Long
+
+' ------------------------------------------------------------------------------
+' 主入口: 运行所有测试
+' ------------------------------------------------------------------------------
+Public Sub RunAllTests()
+    ' 初始化环境
+    Set m_Logger = New clsErrorLogger
+    M03_Logic.InitLogic m_Logger
+    m_FailCount = 0
+    m_PassCount = 0
+
+    Debug.Print String(50, "=")
+    Debug.Print "开始运行单元测试: " & Now
+    Debug.Print String(50, "-")
+
+    ' 执行测试用例
+    Test_01_SimpleAtom
+    Test_02_SimpleAND
+    Test_03_SimpleOR
+    Test_04_CartesianProduct    ' 核心：测试 (A OR B) AND C
+    Test_05_InequalityMerge     ' 核心：测试 !=A AND !=B
+    Test_06_LogicConflict       ' 核心：测试 A=1 AND A=2
+    Test_07_ComplexNested       ' 核心：多层括号
+
+    ' 汇总结果
+    Debug.Print String(50, "-")
+    If m_FailCount = 0 Then
+        Debug.Print "测试结果: ALL PASS! (共 " & m_PassCount & " 个测试点)"
+    Else
+        Debug.Print "测试结果: 失败 " & m_FailCount & " 个, 通过 " & m_PassCount & " 个"
+    End If
+    Debug.Print String(50, "=")
+End Sub
+
+' ------------------------------------------------------------------------------
+' 测试用例 01: 简单赋值
+' 输入: gclj=M20
+' 期望: 1行数据, gclj字段为M20
+' ------------------------------------------------------------------------------
+Private Sub Test_01_SimpleAtom()
+    Dim col As Collection
+    Dim row As Object ' Dictionary
+
+    Set col = M03_Logic.ParseRule("gclj=M20", 1)
+
+    Assert_NotNull col, "T01_Col_Not_Null"
+    Assert_Equal col.count, 1, "T01_Count"
+
+    Set row = col(1)
+    Assert_Equal row("gclj"), "M20", "T01_Value_Check"
+End Sub
+
+' ------------------------------------------------------------------------------
+' 测试用例 02: AND 逻辑 (属性合并)
+' 输入: gclj=M20 AND jycz=1
+' 期望: 1行数据, 包含两个字段
+' ------------------------------------------------------------------------------
+Private Sub Test_02_SimpleAND()
+    Dim col As Collection
+    Dim row As Object
+
+    Set col = M03_Logic.ParseRule("gclj=M20 AND jycz=1", 2)
+
+    Assert_Equal col.count, 1, "T02_Count"
+    Set row = col(1)
+    Assert_Equal row("gclj"), "M20", "T02_Key1"
+    Assert_Equal row("jycz"), "1", "T02_Key2"
+End Sub
+
+' ------------------------------------------------------------------------------
+' 测试用例 03: OR 逻辑 (记录分裂)
+' 输入: azxs=A0 OR azxs=A1
+' 期望: 2行数据
+' ------------------------------------------------------------------------------
+Private Sub Test_03_SimpleOR()
+    Dim col As Collection
+
+    Set col = M03_Logic.ParseRule("azxs=A0 OR azxs=A1", 3)
+
+    Assert_Equal col.count, 2, "T03_Count"
+End Sub
+
+' ------------------------------------------------------------------------------
+' 测试用例 04: 笛卡尔积 (AND 连接 OR)
+' 输入: gclj=M20 AND (azxs=A0 OR azxs=A1)
+' 期望: 2行数据。行1(gclj=M20, azxs=A0), 行2(gclj=M20, azxs=A1)
+' ------------------------------------------------------------------------------
+Private Sub Test_04_CartesianProduct()
+    Dim col As Collection
+    Dim r1 As Object, r2 As Object
+
+    Set col = M03_Logic.ParseRule("gclj=M20 AND (azxs=A0 OR azxs=A1)", 4)
+
+    Assert_Equal col.count, 2, "T04_Count"
+
+    Set r1 = col(1)
+    Set r2 = col(2)
+
+    ' 验证公共部分
+    Assert_Equal r1("gclj"), "M20", "T04_Row1_Common"
+    Assert_Equal r2("gclj"), "M20", "T04_Row2_Common"
+
+    ' 验证差异部分
+    Dim hasA0 As Boolean, hasA1 As Boolean
+    If r1("azxs") = "A0" Or r2("azxs") = "A0" Then hasA0 = True
+    If r1("azxs") = "A1" Or r2("azxs") = "A1" Then hasA1 = True
+
+    Assert_Equal hasA0, True, "T04_Has_A0"
+    Assert_Equal hasA1, True, "T04_Has_A1"
+End Sub
+
+' ------------------------------------------------------------------------------
+' 测试用例 05: 不等于逻辑合并
+' 输入: gclj!=M20 AND gclj!=M30
+' 期望: 1行数据, gclj字段为 "!=M20,!=M30"
+' ------------------------------------------------------------------------------
+Private Sub Test_05_InequalityMerge()
+    Dim col As Collection
+    Dim row As Object
+
+    Set col = M03_Logic.ParseRule("gclj!=M20 AND gclj!=M30", 5)
+
+    Assert_Equal col.count, 1, "T05_Count"
+    Set row = col(1)
+    Assert_Equal row("gclj"), "!=M20,!=M30", "T05_Value_Merge"
+End Sub
+
+' ------------------------------------------------------------------------------
+' 测试用例 06: 逻辑冲突检测 (修正版)
+' 输入: gclj=M20 AND gclj=M30
+' 期望: 返回 Nothing 或 空集合，且 Logger 中有记录
+' ------------------------------------------------------------------------------
+Private Sub Test_06_LogicConflict()
+    Dim col As Collection
+
+    ' 重置 Logger
+    Set m_Logger = New clsErrorLogger
+    M03_Logic.InitLogic m_Logger
+
+    ' 此时 ParseRule 内部会捕捉冲突
+    Set col = M03_Logic.ParseRule("gclj=M20 AND gclj=M30", 6)
+
+    ' 检查结果: 应该是 Nothing 或者 Count=0
+    Dim isInvalid As Boolean
+    If col Is Nothing Then
+        isInvalid = True
+    Else
+        If col.count = 0 Then isInvalid = True Else isInvalid = False
+    End If
+
+    Assert_Equal isInvalid, True, "T06_Should_Return_Empty_Or_Nothing"
+    Assert_Equal m_Logger.HasErrors, True, "T06_Should_Log_Error"
+End Sub
+
+' ------------------------------------------------------------------------------
+' 测试用例 07: 复杂嵌套
+' 输入: A=1 AND (B=1 OR (B=2 AND C=3))
+' 期望: 2行
+'       Row 1: A=1, B=1
+'       Row 2: A=1, B=2, C=3
+' ------------------------------------------------------------------------------
+Private Sub Test_07_ComplexNested()
+    Dim col As Collection
+    Set col = M03_Logic.ParseRule("A=1 AND (B=1 OR (B=2 AND C=3))", 7)
+
+    Assert_Equal col.count, 2, "T07_Count"
+
+    Dim count2 As Long, count3 As Long
+    Dim i As Long
+    Dim r As Object
+
+    For i = 1 To col.count
+        Set r = col(i)
+        If r.count = 2 Then count2 = count2 + 1
+        If r.count = 3 Then count3 = count3 + 1
+    Next i
+
+    Assert_Equal count2, 1, "T07_Row_With_2_Keys"
+    Assert_Equal count3, 1, "T07_Row_With_3_Keys"
+End Sub
+
+' ==============================================================================
+' 辅助断言函数
+' ==============================================================================
+Private Sub Assert_Equal(actual As Variant, expected As Variant, testName As String)
+    If CStr(actual) = CStr(expected) Then
+        ' Debug.Print " [PASS] " & testName
+        m_PassCount = m_PassCount + 1
+    Else
+        Debug.Print " [FAIL] " & testName & " | Expected: " & expected & ", Actual: " & actual
+        m_FailCount = m_FailCount + 1
+    End If
+End Sub
+
+Private Sub Assert_NotNull(obj As Object, testName As String)
+    If Not obj Is Nothing Then
+        m_PassCount = m_PassCount + 1
+    Else
+        Debug.Print " [FAIL] " & testName & " | Object is Nothing"
+        m_FailCount = m_FailCount + 1
+    End If
+End Sub

VBA/Modules/模块1.bas

@@ -0,0 +1,36 @@
+Sub TestStatusBarColor()
+    Dim i As Integer
+
+    ' --- 第一阶段：观察初始状态 ---
+    ' 此时还没有修改状态栏
+    MsgBox "【步骤 1/3】" & vbCrLf & vbCrLf & _
+           "请现在看一眼 Excel 左下角的状态栏。" & vbCrLf & _
+           "它应该是【白色/灰白色】的，显示'就绪'。" & vbCrLf & vbCrLf & _
+           ">>> 准备好观察变色了吗？点击确定开始写入文字。", vbInformation, "初始状态检查"
+
+    ' --- 第二阶段：写入自定义内容 ---
+    ' Excel 应该会在这一行代码执行的瞬间，改变状态栏样式
+    For i = 1 To 5
+        Application.StatusBar = "【正在测试】状态栏底色变了吗？计数: " & i
+
+        ' 强制刷新界面，确保你能看到变化
+        DoEvents
+
+        ' 暂停 1 秒，让你有时间观察
+        Application.Wait (Now + TimeValue("0:00:01"))
+    Next i
+
+    ' --- 第三阶段：暂停在修改状态，再次确认 ---
+    MsgBox "【步骤 2/3】" & vbCrLf & vbCrLf & _
+           "代码正在运行中，状态栏内容已被修改。" & vbCrLf & _
+           "请看左下角：底色是否变成了【深绿色】或【深灰色】？" & vbCrLf & _
+           "文字是否变成了不易辨认的细黑体？" & vbCrLf & vbCrLf & _
+           ">>> 点击确定后，我将重置状态栏。", vbExclamation, "接管状态检查"
+
+    ' --- 第四阶段：重置 ---
+    Application.StatusBar = False ' 这一句是关键，False 代表交还控制权给 Excel
+
+    MsgBox "【步骤 3/3】" & vbCrLf & vbCrLf & _
+           "测试结束。状态栏应该已经恢复为【白色/灰白色】的'就绪'状态。", vbInformation, "恢复状态检查"
+
+End Sub