From 58e84ddd25d2c5b781d3faa9637a3283e5153e87 Mon Sep 17 00:00:00 2001 From: Misaka_Company Date: Wed, 4 Feb 2026 11:07:36 +0800 Subject: [PATCH] feat: restore VBA source code modules Co-Authored-By: Claude Sonnet 4.5 --- VBA/ClassModules/clsErrorLogger.cls | 55 ++++++ VBA/Modules/M01_Main.bas | 110 +++++++++++ VBA/Modules/M02_DataIO.bas | 160 +++++++++++++++ VBA/Modules/M03_Logic.bas | 289 ++++++++++++++++++++++++++++ VBA/Modules/M04_Config.bas | 37 ++++ VBA/Modules/M99_TestRunner.bas | 212 ++++++++++++++++++++ VBA/Modules/模块1.bas | 36 ++++ 7 files changed, 899 insertions(+) create mode 100644 VBA/ClassModules/clsErrorLogger.cls create mode 100644 VBA/Modules/M01_Main.bas create mode 100644 VBA/Modules/M02_DataIO.bas create mode 100644 VBA/Modules/M03_Logic.bas create mode 100644 VBA/Modules/M04_Config.bas create mode 100644 VBA/Modules/M99_TestRunner.bas create mode 100644 VBA/Modules/模块1.bas diff --git a/VBA/ClassModules/clsErrorLogger.cls b/VBA/ClassModules/clsErrorLogger.cls new file mode 100644 index 0000000..3d50892 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/VBA/Modules/M01_Main.bas b/VBA/Modules/M01_Main.bas new file mode 100644 index 0000000..da2f725 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/VBA/Modules/M02_DataIO.bas b/VBA/Modules/M02_DataIO.bas new file mode 100644 index 0000000..e4a7a7a --- /dev/null +++ b/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 \ No newline at end of file diff --git a/VBA/Modules/M03_Logic.bas b/VBA/Modules/M03_Logic.bas new file mode 100644 index 0000000..f788ace --- /dev/null +++ b/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 \ No newline at end of file diff --git a/VBA/Modules/M04_Config.bas b/VBA/Modules/M04_Config.bas new file mode 100644 index 0000000..f26853e --- /dev/null +++ b/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 \ No newline at end of file diff --git a/VBA/Modules/M99_TestRunner.bas b/VBA/Modules/M99_TestRunner.bas new file mode 100644 index 0000000..4731266 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/VBA/Modules/模块1.bas b/VBA/Modules/模块1.bas new file mode 100644 index 0000000..72e3bce --- /dev/null +++ b/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 \ No newline at end of file