From 40a9fe99f40301084d7559ec40b92ed693be8dfc Mon Sep 17 00:00:00 2001 From: Misaka_Company Date: Wed, 21 Jan 2026 09:51:37 +0800 Subject: [PATCH] feat: track and return missing material categories in BOM - Update GetValidMaterialsByModel to aggregate and return missing category names under the "MissingCategories" key. - Remove debug print statements and unused variables to improve code cleanliness. - Enhance result visualization to display completeness status with color formatting and detailed material tables. --- VBA/ClassModules/clsBOMManager.cls | 92 +- VBA/Modules/modModelParserExamples.bas | 120 +- VBA/combined_output.md | 2876 ++++++++++++++++++++++++ 3 files changed, 2965 insertions(+), 123 deletions(-) create mode 100644 VBA/combined_output.md diff --git a/VBA/ClassModules/clsBOMManager.cls b/VBA/ClassModules/clsBOMManager.cls index bdbda7a..8a0a6aa 100644 --- a/VBA/ClassModules/clsBOMManager.cls +++ b/VBA/ClassModules/clsBOMManager.cls @@ -692,6 +692,7 @@ End Function ' Collection中包含两个元素: ' (1) "Materials" - Collection对象,包含所有匹配的 clsMaterialItem 对象 ' (2) "IsComplete" - Boolean值,指示物料是否完整 +' (3) "MissingCategories" - Collection对象, 包含所有缺失的类别名称字符串 ' ' 完整性判断规则: ' - 对于每个需要领料的类别(顶层类别或其需要领取的子类别) @@ -709,6 +710,7 @@ End Function Public Function GetValidMaterialsByModel(modelStr As String) As collection Dim result As New collection Dim allMaterials As New collection + Dim allMissingCats As New collection ' 用于存储所有缺失的类别 Dim isComplete As Boolean ' 解析型号并提取条件 @@ -718,6 +720,7 @@ Public Function GetValidMaterialsByModel(modelStr As String) As collection isComplete = False result.Add allMaterials, "Materials" result.Add isComplete, "IsComplete" + result.Add allMissingCats, "MissingCategories" Set GetValidMaterialsByModel = result Exit Function End If @@ -726,23 +729,11 @@ Public Function GetValidMaterialsByModel(modelStr As String) As collection Dim conditions As Object Set conditions = extractor.ExtractConditions(parser) - ' 调试输出 - Debug.Print "【GetValidMaterialsByModel】" - Debug.Print "型号: " & modelStr - Debug.Print "提取的条件:" - Dim key As Variant - For Each key In conditions.Keys - Debug.Print " " & key & " = " & conditions(key) - Next key - Debug.Print "" - ' 条件匹配器 Dim matcher As New clsConditionMatcher ' 遍历所有根类别,检查完整性 isComplete = True - Dim categoryCheckResults As Object - Set categoryCheckResults = CreateObject("Scripting.Dictionary") Dim rootCat As clsCategory Dim i As Long @@ -753,7 +744,7 @@ Public Function GetValidMaterialsByModel(modelStr As String) As collection Dim catResult As Object Set catResult = CheckCategoryCompleteness(rootCat, matcher, conditions) - ' 合并物料 + ' 1. 合并匹配到的物料 Dim mat As clsMaterialItem Dim matCollection As collection Set matCollection = catResult("Materials") @@ -761,29 +752,25 @@ Public Function GetValidMaterialsByModel(modelStr As String) As collection allMaterials.Add mat Next mat - ' 检查完整性 + ' 2. 合并缺失的类别 (新增) + Dim missingCollection As collection + Set missingCollection = catResult("Missing") + Dim missingCatName As Variant + For Each missingCatName In missingCollection + allMissingCats.Add missingCatName + Next missingCatName + + ' 3. 检查完整性状态 If Not catResult("IsComplete") Then isComplete = False - Debug.Print "【不完整】类别 """ & rootCat.categoryName & """ 物料不完整" End If - - ' 保存类别检查结果(用于调试) - categoryCheckResults(rootCat.categoryName) = catResult("IsComplete") Next i - ' 调试输出总结 - Debug.Print "" - Debug.Print "【完整性检查结果】" - Debug.Print "总物料数: " & allMaterials.count - Debug.Print "是否完整: " & IIf(isComplete, "是", "否") - For Each key In categoryCheckResults.Keys - Debug.Print " " & key & ": " & IIf(categoryCheckResults(key), "完整", "不完整") - Next key - Debug.Print String(60, "=") - ' 返回结果 result.Add allMaterials, "Materials" result.Add isComplete, "IsComplete" + result.Add allMissingCats, "MissingCategories" ' 新增返回项 + Set GetValidMaterialsByModel = result End Function @@ -797,6 +784,7 @@ End Function ' 返回: Dictionary对象 ' "Materials" - Collection,包含该类别匹配的物料 ' "IsComplete" - Boolean,该类别是否完整 +' "Missing" - Collection, 缺失的类别名称列表 ' ' 完整性判断逻辑: ' 1. 如果类别没有子类别(叶子类别): @@ -817,6 +805,7 @@ Private Function CheckCategoryCompleteness(cat As clsCategory, _ Set result = CreateObject("Scripting.Dictionary") Dim materials As New collection + Dim missingCats As New collection ' 本层级及子层级缺失的类别 Dim isComplete As Boolean ' 首先在当前类别查找匹配的物料 @@ -837,36 +826,31 @@ Private Function CheckCategoryCompleteness(cat As clsCategory, _ If Not cat.HasSubCategories Then ' ======================================== ' 情况1: 叶子类别(无子类别) - ' 必须有且仅有1个物料 ' ======================================== If matchCount = 1 Then isComplete = True - Debug.Print "【完整】叶子类别 """ & cat.categoryName & """ 有1个匹配物料" Else isComplete = False + ' 如果是叶子节点且没有匹配到物料，记录该类别为缺失 If matchCount = 0 Then - Debug.Print "【不完整】叶子类别 """ & cat.categoryName & """ 无匹配物料" - Else - Debug.Print "【不完整】叶子类别 """ & cat.categoryName & """ 有" & matchCount & "个匹配物料(应为1个)" + missingCats.Add cat.categoryName End If + ' 注: matchCount > 1 属于配置错误(重复匹配)，算不完整，但通常不算"Missing" End If Else ' ======================================== ' 情况2: 有子类别 - ' 先检查父类别,如果父类别满足则使用父类别 - ' 否则降级到子类别,每个子类别都必须满足 ' ======================================== If matchCount = 1 Then - ' 父类别有且仅有1个物料,使用父类别 + ' 父类别有且仅有1个物料, 使用父类别 -> 完整 isComplete = True - Debug.Print "【完整】父类别 """ & cat.categoryName & """ 有1个匹配物料,使用父类别" + ' 不需要检查子类别了，missingCats 保持为空 ElseIf matchCount = 0 Then - ' 父类别无匹配物料,降级到子类别 - Debug.Print "【降级】父类别 """ & cat.categoryName & """ 无匹配物料,检查子类别..." + ' 父类别无匹配物料, 必须降级检查所有子类别 - ' 清空物料集合,准备收集子类别物料 + ' 清空当前物料集合(确保没东西), 准备收集子类别结果 Set materials = New collection - isComplete = True ' 假设完整,如果任一子类别不完整则设为False + isComplete = True ' 先假设完整, 若任一子类别不完整则置错 Dim subCat As clsCategory Dim j As Long @@ -877,7 +861,7 @@ Private Function CheckCategoryCompleteness(cat As clsCategory, _ Dim subResult As Object Set subResult = CheckCategoryCompleteness(subCat, matcher, conditions) - ' 合并子类别物料 + ' a) 合并子类别物料 Dim subMaterials As collection Set subMaterials = subResult("Materials") Dim k As Long @@ -885,26 +869,28 @@ Private Function CheckCategoryCompleteness(cat As clsCategory, _ materials.Add subMaterials(k) Next k - ' 检查子类别是否完整 + ' b) 合并子类别缺失列表 (关键步骤) + Dim subMissing As collection + Set subMissing = subResult("Missing") + Dim item As Variant + For Each item In subMissing + missingCats.Add item + Next item + + ' c) 更新完整性状态 If Not subResult("IsComplete") Then isComplete = False End If Next j - - If isComplete Then - Debug.Print "【完整】类别 """ & cat.categoryName & """ 所有子类别都完整" - Else - Debug.Print "【不完整】类别 """ & cat.categoryName & """ 存在不完整的子类别" - End If Else - ' 父类别有多个匹配物料,不完整 + ' 父类别有 >1 个匹配, 视为不完整(冲突) isComplete = False - Debug.Print "【不完整】父类别 """ & cat.categoryName & """ 有" & matchCount & "个匹配物料(应为0或1个)" End If End If - ' 返回结果 + ' 封装返回结果 Set result("Materials") = materials result("IsComplete") = isComplete + Set result("Missing") = missingCats Set CheckCategoryCompleteness = result -End Function \ No newline at end of file +End Function diff --git a/VBA/Modules/modModelParserExamples.bas b/VBA/Modules/modModelParserExamples.bas index d27ec8f..bb360e5 100644 --- a/VBA/Modules/modModelParserExamples.bas +++ b/VBA/Modules/modModelParserExamples.bas @@ -502,7 +502,7 @@ Sub Example6_CompareAutoFallback() End Sub ' ======================================== -' 示例7: 测试GetValidMaterialsByModel方法 +' 示例7: 测试GetValidMaterialsByModel方法 (使用内置的缺失列表) ' ======================================== Sub Example7_TestGetValidMaterialsByModel() Dim bomMgr As New clsBOMManager @@ -533,13 +533,11 @@ Sub Example7_TestGetValidMaterialsByModel() wsTest.Cells(row, 1).Font.Size = 14 row = row + 2 - ' 测试多个型号 + ' 定义测试型号 Dim testModels() As Variant testModels = Array( _ Array("YTHN-100.A0.532.M203.M16.Y3|BP-095.2312.M16.PA3", "完整型号测试1"), _ - Array("YTHN-100.A0.532.M203.M02.Y3|BP-095.2312.M02.PA3", "完整型号测试2"), _ - Array("YTHN-100.A0.532.M203.M12.Y3|BP-095.2312.M12.PA3", "完整型号测试3"), _ - Array("YTHN-100.A0.532.M203.M17.Y3", "可能不完整的型号") _ + Array("YTHN-100.A0.532.M203.M17.Y3", "缺失子类别测试") _ ) Dim i As Long @@ -549,18 +547,22 @@ Sub Example7_TestGetValidMaterialsByModel() modelStr = testModels(i)(0) testName = testModels(i)(1) - ' 调用GetValidMaterialsByModel + ' 1. 调用方法获取结果 Dim result As collection Set result = bomMgr.GetValidMaterialsByModel(modelStr) Dim materials As collection + Dim missingCats As collection Dim isComplete As Boolean + Set materials = result("Materials") + Set missingCats = result("MissingCategories") ' 直接获取缺失列表 isComplete = result("IsComplete") - ' 写入测试名称和型号 + ' 2. 写入头部信息 wsTest.Cells(row, 1).value = "测试 " & (i + 1) & ": " & testName wsTest.Cells(row, 1).Font.Bold = True + wsTest.Cells(row, 1).Interior.Color = RGB(240, 240, 240) row = row + 1 wsTest.Cells(row, 1).value = "型号:" @@ -568,41 +570,58 @@ Sub Example7_TestGetValidMaterialsByModel() row = row + 1 wsTest.Cells(row, 1).value = "完整性:" - wsTest.Cells(row, 2).value = IIf(isComplete, "?? 完整", "?? 不完整") + wsTest.Cells(row, 2).value = IIf(isComplete, "✓ 完整", "✕ 不完整") If isComplete Then - wsTest.Cells(row, 2).Font.Color = RGB(0, 128, 0) ' 绿色 + wsTest.Cells(row, 2).Font.Color = RGB(0, 128, 0) Else - wsTest.Cells(row, 2).Font.Color = RGB(255, 0, 0) ' 红色 + wsTest.Cells(row, 2).Font.Color = RGB(255, 0, 0) End If wsTest.Cells(row, 2).Font.Bold = True row = row + 1 - - wsTest.Cells(row, 1).value = "物料数量:" - wsTest.Cells(row, 2).value = materials.count + + ' 3. 打印匹配到的物料 + wsTest.Cells(row, 1).value = "【已匹配物料】" + wsTest.Cells(row, 1).Font.Bold = True row = row + 1 - - ' 写入物料明细表头 + wsTest.Cells(row, 1).value = "类别" wsTest.Cells(row, 2).value = "代号" wsTest.Cells(row, 3).value = "名称" wsTest.Cells(row, 4).value = "数量" - wsTest.Cells(row, 5).value = "选择条件" - wsTest.Range(wsTest.Cells(row, 1), wsTest.Cells(row, 5)).Font.Bold = True - wsTest.Range(wsTest.Cells(row, 1), wsTest.Cells(row, 5)).Interior.Color = RGB(200, 200, 200) + wsTest.Range(wsTest.Cells(row, 1), wsTest.Cells(row, 4)).Font.Bold = True + wsTest.Range(wsTest.Cells(row, 1), wsTest.Cells(row, 4)).Interior.Color = RGB(220, 220, 220) row = row + 1 - - ' 写入每个物料 + Dim mat As clsMaterialItem - Dim j As Long - For j = 1 To materials.count - Set mat = materials(j) - wsTest.Cells(row, 1).value = mat.Category - wsTest.Cells(row, 2).value = mat.code - wsTest.Cells(row, 3).value = mat.Name - wsTest.Cells(row, 4).value = mat.Quantity - wsTest.Cells(row, 5).value = IIf(mat.Condition = "", "(无条件)", mat.Condition) + If materials.count > 0 Then + For Each mat In materials + wsTest.Cells(row, 1).value = mat.Category + wsTest.Cells(row, 2).value = mat.code + wsTest.Cells(row, 3).value = mat.Name + wsTest.Cells(row, 4).value = mat.Quantity + row = row + 1 + Next mat + Else + wsTest.Cells(row, 1).value = "(无)" row = row + 1 - Next j + End If + + ' 4. 打印缺失的类别 (新增核心功能) + If missingCats.count > 0 Then + row = row + 1 + wsTest.Cells(row, 1).value = "【缺失类别】" + wsTest.Cells(row, 1).Font.Color = RGB(255, 0, 0) + wsTest.Cells(row, 1).Font.Bold = True + row = row + 1 + + Dim catName As Variant + For Each catName In missingCats + wsTest.Cells(row, 1).value = "❌ " & catName + wsTest.Cells(row, 1).Font.Color = RGB(255, 0, 0) + wsTest.Cells(row, 2).value = "未找到匹配物料" + row = row + 1 + Next catName + End If ' 添加分隔行 row = row + 1 @@ -610,45 +629,6 @@ Sub Example7_TestGetValidMaterialsByModel() row = row + 2 Next i - ' 添加统计汇总 - wsTest.Cells(row, 1).value = "测试汇总" - wsTest.Cells(row, 1).Font.Bold = True - wsTest.Cells(row, 1).Font.Size = 12 - row = row + 1 - - Dim completeCount As Long - Dim incompleteCount As Long - completeCount = 0 - incompleteCount = 0 - - For i = LBound(testModels) To UBound(testModels) - modelStr = testModels(i)(0) - Set result = bomMgr.GetValidMaterialsByModel(modelStr) - If result("IsComplete") Then - completeCount = completeCount + 1 - Else - incompleteCount = incompleteCount + 1 - End If - Next i - - wsTest.Cells(row, 1).value = "总测试数:" - wsTest.Cells(row, 2).value = UBound(testModels) - LBound(testModels) + 1 - row = row + 1 - - wsTest.Cells(row, 1).value = "完整:" - wsTest.Cells(row, 2).value = completeCount - wsTest.Cells(row, 2).Font.Color = RGB(0, 128, 0) - row = row + 1 - - wsTest.Cells(row, 1).value = "不完整:" - wsTest.Cells(row, 2).value = incompleteCount - wsTest.Cells(row, 2).Font.Color = RGB(255, 0, 0) - - ' 格式化 - wsTest.Columns("A:E").AutoFit - - MsgBox "物料完整性测试完成！" & vbCrLf & _ - "完整: " & completeCount & " 个" & vbCrLf & _ - "不完整: " & incompleteCount & " 个" & vbCrLf & vbCrLf & _ - "请查看工作表: 物料完整性测试", vbInformation + wsTest.Columns("A:D").AutoFit + MsgBox "测试完成！", vbInformation End Sub \ No newline at end of file diff --git a/VBA/combined_output.md b/VBA/combined_output.md new file mode 100644 index 0000000..f095227 --- /dev/null +++ b/VBA/combined_output.md @@ -0,0 +1,2876 @@ +# 目录 + +- [ClassModules\clsBOMManager.cls](#classmodules-clsbommanager-cls) +- [ClassModules\clsCategory.cls](#classmodules-clscategory-cls) +- [ClassModules\clsConditionExtractor.cls](#classmodules-clsconditionextractor-cls) +- [ClassModules\clsConditionMatcher.cls](#classmodules-clsconditionmatcher-cls) +- [ClassModules\clsMaterialItem.cls](#classmodules-clsmaterialitem-cls) +- [ClassModules\clsModelParser.cls](#classmodules-clsmodelparser-cls) +- [Modules\modBOMProcessor.bas](#modules-modbomprocessor-bas) +- [Modules\modModelParserExamples.bas](#modules-modmodelparserexamples-bas) +- [Modules\modModelParserTest.bas](#modules-modmodelparsertest-bas) + +--- + +## ClassModules\clsBOMManager.cls + +``` +' ======================================== +' 类模块: clsBOMManager +' 用途: 管理整个BOM数据结构 +' 功能: +' 1. 加载和组织BOM数据 +' 2. 建立类别层级关系 +' 3. 提供物料查询接口 +' 4. 支持领料逻辑处理 +' ======================================== +Option Explicit + +' ======================================== +' 私有成员变量 +' ======================================== +Private dictCategories As Object ' Dictionary对象: 类别名称 -> clsCategory对象 + ' 作用: 快速查找任意类别 +Private dictAllMaterials As Object ' Dictionary对象: 物料代号 -> clsMaterialItem对象 + ' 作用: 快速查找任意物料 +Private rootCategories As collection ' Collection: 存储所有顶层类别(无父类别的类别) + ' 作用: 遍历完整的类别树结构 + +' ======================================== +' 类初始化 +' 说明: 创建BOMManager实例时自动调用 +' ======================================== +Private Sub Class_Initialize() + Set dictCategories = CreateObject("Scripting.Dictionary") + Set dictAllMaterials = CreateObject("Scripting.Dictionary") + Set rootCategories = New collection +End Sub + +' ======================================== +' LoadData 方法 +' 功能: 从Excel工作表加载BOM数据并构建数据结构 +' 参数: +' wsConfig - [领料配置]工作表对象,包含类别层级和需要领料的物料 +' wsPlatform - [平台配置清单]工作表对象,包含完整的物料信息(代号/名称/数量/条件) +' 处理步骤: +' 1. 从[平台配置清单]加载所有物料的基础信息到dictAllMaterials +' 2. 从[领料配置]加载类别信息,筛选需要领料的物料 +' 3. 建立类别的父子关系,构建层级树 +' 注意: +' - 只有出现在[领料配置]中的物料才会被添加到类别中 +' - 未在[领料配置]中的物料表示不需要领料 +' ======================================== +Public Sub LoadData(wsConfig As Worksheet, wsPlatform As Worksheet) + Dim i As Long, lastRow As Long + Dim mat As clsMaterialItem + Dim cat As clsCategory + + ' ======================================== + ' 第一步: 从平台配置清单加载所有物料的基础信息 + ' 说明: + ' - 读取C列(代号)、D列(名称)、E列(数量)、F列(选择条件) + ' - 从第4行开始读取(前3行是标题) + ' - 所有物料存入dictAllMaterials字典,以代号为键 + ' 目的: 建立完整的物料信息库,供后续按代号查询 + ' ======================================== + lastRow = wsPlatform.Cells(wsPlatform.Rows.Count, "C").End(xlUp).row + For i = 4 To lastRow ' 从第4行开始(跳过标题) + Set mat = New clsMaterialItem + mat.code = Trim(wsPlatform.Cells(i, "C").value & "") ' 物料代号 + mat.Name = Trim(wsPlatform.Cells(i, "D").value & "") ' 物料名称 + On Error Resume Next + mat.Quantity = CDbl(wsPlatform.Cells(i, "E").value) ' 物料数量 + On Error GoTo 0 + mat.Condition = Trim(wsPlatform.Cells(i, "F").value & "") ' 选择条件 + + ' 只保存代号非空的物料 + If mat.code <> "" Then + Set dictAllMaterials(mat.code) = mat + End If + Next i + + ' ======================================== + ' 第二步: 从领料配置加载类别信息并建立层级 + ' 说明: + ' - 读取A列(代号)、C列(类别)、D列(上层类别) + ' - 从第2行开始读取(第1行是标题) + ' - 只有出现在此表中的物料才需要领料 + ' 处理逻辑: + ' 1. 为每个类别创建clsCategory对象 + ' 2. 从dictAllMaterials中查找对应的物料信息 + ' 3. 将物料添加到对应的类别中 + ' ======================================== + lastRow = wsConfig.Cells(wsConfig.Rows.Count, "A").End(xlUp).row + For i = 2 To lastRow ' 从第2行开始 + Dim code As String, catName As String, parentCatName As String + code = Trim(wsConfig.Cells(i, "A").value & "") ' 物料代号 + catName = Trim(wsConfig.Cells(i, "C").value & "") ' 类别名称 + parentCatName = Trim(wsConfig.Cells(i, "D").value & "") ' 上层类别名称 + + ' 跳过空行 + If code = "" Then GoTo NextRow + + ' 确保类别对象存在(如果类别不存在则创建) + If Not dictCategories.Exists(catName) Then + Set cat = New clsCategory + cat.categoryName = catName + cat.ParentCategoryName = parentCatName + Set dictCategories(catName) = cat + End If + + ' 将物料添加到类别 + ' 注意: 必须先在dictAllMaterials中查找到完整的物料信息 + If dictAllMaterials.Exists(code) Then + Set mat = dictAllMaterials(code) + mat.Category = catName ' 设置物料所属类别 + mat.ParentCategory = parentCatName ' 设置物料的上层类别 + dictCategories(catName).AddMaterial mat ' 将物料添加到类别对象中 + End If + +NextRow: + Next i + + ' ======================================== + ' 第三步: 建立类别层级关系 + ' 说明: + ' - 遍历所有类别,根据ParentCategoryName建立父子关系 + ' - 如果类别有父类别,将自己添加到父类别的SubCategories中 + ' - 如果类别没有父类别,则为根类别,添加到rootCategories中 + ' 结果: + ' - 构建完整的树形结构 + ' - rootCategories包含所有顶层类别 + ' - 每个类别的SubCategories包含其直接子类别 + ' ======================================== + Dim key As Variant + For Each key In dictCategories.Keys + Set cat = dictCategories(key) + If cat.ParentCategoryName <> "" Then + ' 有父类别,建立父子关系 + If dictCategories.Exists(cat.ParentCategoryName) Then + Dim parentCat As clsCategory + Set parentCat = dictCategories(cat.ParentCategoryName) + parentCat.AddSubCategory cat ' 将当前类别添加为父类别的子类别 + End If + Else + ' 无父类别,是根类别 + rootCategories.Add cat, cat.categoryName + End If + Next key +End Sub + +' ======================================== +' GetRootCategories 方法 +' 功能: 获取所有顶层类别的集合 +' 返回: Collection对象,包含所有无父类别的clsCategory对象 +' 用途: +' - 遍历整个BOM结构时的入口点 +' - 生成领料清单时遍历所有根类别 +' 示例: +' Dim cats As Collection +' Set cats = bomMgr.GetRootCategories() +' For i = 1 To cats.Count +' Debug.Print cats(i).CategoryName +' Next i +' ======================================== +Public Function GetRootCategories() As collection + Set GetRootCategories = rootCategories +End Function + +' ======================================== +' GetCategory 方法 +' 功能: 根据类别名称获取类别对象 +' 参数: +' categoryName - 要查询的类别名称(字符串) +' 返回: +' clsCategory对象 - 如果找到 +' Nothing - 如果未找到 +' 用途: 快速查找特定类别及其下的物料 +' 示例: +' Dim cat As clsCategory +' Set cat = bomMgr.GetCategory("部件") +' If Not cat Is Nothing Then +' Debug.Print cat.Materials.Count & " 个物料" +' End If +' ======================================== +Public Function GetCategory(categoryName As String) As clsCategory + If dictCategories.Exists(categoryName) Then + Set GetCategory = dictCategories(categoryName) + Else + Set GetCategory = Nothing + End If +End Function + +' ======================================== +' GetMaterialsForPicking 方法 +' 功能: 获取某类别下需要领料的物料清单(考虑层级逻辑) +' 参数: +' categoryName - 类别名称 +' useParent - 可选参数,默认True +' True: 使用父类别物料(默认领料方式) +' False: 使用子类别物料(库存不足时的替代方案) +' 返回: Collection对象,包含clsMaterialItem对象 +' +' 业务逻辑说明: +' 1. 默认领取父类别的物料(如"低压接头部件") +' 2. 当父类别库存不足时,才领取子类别的物料(如"接头"+"弹性元件") +' 3. 如果useParent=True但类别有子类别,仍返回父类别物料 +' 4. 如果useParent=False,递归获取所有子类别的物料 +' +' 示例1: 获取"部件"类别的物料(父类别) +' Set mats = bomMgr.GetMaterialsForPicking("部件", True) +' ' 返回: 低压接头部件、高压接头部件等组装好的部件 +' +' 示例2: 获取"部件"类别的物料(子类别展开) +' Set mats = bomMgr.GetMaterialsForPicking("部件", False) +' ' 返回: 径向低压接头、弹簧管、螺旋管等零件 +' ======================================== +Public Function GetMaterialsForPicking(categoryName As String, _ + Optional useParent As Boolean = True) As collection + Dim result As collection + Set result = New collection + + ' 查找指定类别 + Dim cat As clsCategory + Set cat = GetCategory(categoryName) + If cat Is Nothing Then + ' 类别不存在,返回空集合 + Set GetMaterialsForPicking = result + Exit Function + End If + + Dim i As Long + + If useParent Then + ' ======================================== + ' 使用父类别物料(默认领料方式) + ' 说明: + ' - 直接返回当前类别下的所有物料 + ' - 即使该类别有子类别,也仍然返回父类别物料 + ' - 这是正常情况下的领料方式(领取组装好的部件) + ' ======================================== + Dim m As clsMaterialItem + For i = 1 To cat.materials.Count + Set m = cat.materials(i) + result.Add m + Next i + Else + ' ======================================== + ' 使用子类别物料(库存不足时的替代方案) + ' 说明: + ' - 如果当前类别有子类别,递归获取所有子类别的物料 + ' - 如果当前类别是叶子类别(无子类别),返回本类别物料 + ' - 这用于父类别库存不足,需要领取零件自行组装的情况 + ' 示例: + ' 当"低压接头部件"库存不足时 + ' 改为领取"径向低压接头"+"弹簧管"零件 + ' ======================================== + If cat.HasSubCategories Then + ' 有子类别,递归获取所有子类别的物料 + Dim subCat As clsCategory + Dim j As Long + For j = 1 To cat.SubCategories.Count + Set subCat = cat.SubCategories(j) + Dim subMats As collection + ' 递归调用,继续展开子类别 + Set subMats = GetMaterialsForPicking(subCat.categoryName, False) + Dim k As Long + For k = 1 To subMats.Count + result.Add subMats(k) + Next k + Next j + Else + ' 叶子类别,返回本类别物料 + For i = 1 To cat.materials.Count + Set m = cat.materials(i) + result.Add m + Next i + End If + End If + + Set GetMaterialsForPicking = result +End Function + +' ======================================== +' PrintCategoryTree 方法 +' 功能: 将类别树结构打印到工作表(用于调试和查看) +' 参数: +' ws - 输出的目标工作表对象 +' 输出格式: +' - 第一列: 类别名称(带缩进显示层级) +' - 第二列: 物料数量信息 +' - 第三列: 选择条件 +' 说明: +' - 使用缩进显示类别层级(每层2个空格) +' - 递归打印所有子类别和物料 +' - 便于验证数据结构是否正确 +' 示例输出: +' 表壳 (物料数:1) +' - 01091004312 表壳(本色) 数量:1 条件: +' 部件 (物料数:20) +' - 01011019001 低压接头部件 数量:1 条件:lcfw=M02... +' 接头 (物料数:18) +' - 01081013833 径向低压接头 数量:1 条件:gclj=Z12... +' ======================================== +Public Sub PrintCategoryTree(ws As Worksheet) + Dim row As Long + row = 1 + ws.Cells(row, 1).value = "类别层级结构" + row = row + 1 + + ' 遍历所有根类别,递归打印整个树 + Dim rootCat As clsCategory + Dim i As Long + For i = 1 To rootCategories.Count + Set rootCat = rootCategories(i) + Call PrintCategory(ws, rootCat, row, 0) + Next i +End Sub + +' ======================================== +' PrintCategory 方法 (私有方法) +' 功能: 递归打印单个类别及其子类别(供PrintCategoryTree调用) +' 参数: +' ws - 输出的工作表对象 +' cat - 要打印的类别对象 +' row - 当前输出行号(ByRef,会被修改) +' level - 当前层级深度(0=根类别,1=一级子类别...) +' 说明: +' - 使用递归方式遍历整个类别树 +' - 根据level参数计算缩进空格数 +' - 先打印类别名,再打印该类别的所有物料,最后递归打印子类别 +' ======================================== +Private Sub PrintCategory(ws As Worksheet, cat As clsCategory, _ + ByRef row As Long, level As Integer) + ' 计算缩进(每层2个空格) + Dim indent As String + indent = String(level * 2, " ") + + ' 打印类别名称和物料数量统计 + ws.Cells(row, 1).value = indent & cat.categoryName & _ + " (物料数:" & cat.materials.Count & ")" + row = row + 1 + + ' 打印该类别下的所有物料 + Dim mat As clsMaterialItem + Dim i As Long + For i = 1 To cat.materials.Count + Set mat = cat.materials(i) + ' 物料行额外缩进2个空格,并加上"- "前缀 + ws.Cells(row, 1).value = indent & " - " & mat.code & " " & mat.Name + ws.Cells(row, 2).value = "数量:" & mat.Quantity + ws.Cells(row, 3).value = "条件:" & mat.Condition + row = row + 1 + Next i + + ' 递归打印所有子类别 + Dim subCat As clsCategory + Dim j As Long + For j = 1 To cat.SubCategories.Count + Set subCat = cat.SubCategories(j) + ' 递归调用,层级加1 + Call PrintCategory(ws, subCat, row, level + 1) + Next j +End Sub +' ======================================== +' GetMaterialsByModel 方法 +' +' 【功能概述】 +' 根据产品型号字符串自动解析规格参数,并返回符合这些规格的所有物料清单。 +' 这是BOM系统的核心方法,实现了从"产品型号"到"物料清单"的智能转换。 +' +' 【工作流程】 +' 1. 型号解析 (clsModelParser) → 将产品型号字符串拆解为结构化参数 +' 2. 条件提取 (clsConditionExtractor) → 从型号参数中提取匹配条件变量 +' 3. 物料筛选 (clsConditionMatcher) → 根据条件从物料库中筛选符合条件的物料 +' +' 【参数说明】 +' modelStr - 产品型号字符串 +' 格式: [型号]-[口径].[安装].[表壳].[连接].[量程]|[表盘]|[附件]|[法兰] +' 示例: "YTHN-100.A0.532.M203.M16.Y3|BP-095.2312.M16.PA3" +' 说明: 必须是完整的型号字符串,不能为空 +' +' categoryName - 类别名称(可选参数,默认为空字符串) +' 为空字符串 "": 返回所有类别的符合条件物料(默认行为) +' 指定类别名: 仅返回该类别下的符合条件物料 +' 示例: "部件"、"表壳"、"接头"、"机芯" +' +' autoFallback - 是否自动降级到子类别(可选参数,默认为True) +' True (默认): 当某个类别无匹配物料时,自动降级到其子类别继续查找 +' False: 仅在当前类别查找,不降级到子类别 +' 示例场景: +' 型号 "YTHN-100.A0.532.M203.M17.Y3" 的量程是M17 +' 类别"部件"下的物料条件是 "lcfw=M02" +' autoFallback=True: 自动降级到子类别"接头"、"弹性元件"等查找 +' autoFallback=False: "部件"类别返回空集合 +' +' 【返回值】 +' 返回类型: Collection对象 +' 元素类型: Collection中的每个元素都是 clsMaterialItem 对象 +' +' clsMaterialItem 对象属性: +' .code - String - 物料代号(如: "01011019001") +' .Name - String - 物料名称(如: "低压接头部件") +' .Quantity - Double - 物料数量(如: 1, 2, 0.5) +' .Condition - String - 选择条件(如: "lcfw=M02 AND gclj=Z12") +' .Category - String - 所属类别名称 +' .ParentCategory - String - 上层类别名称 +' +' 【注意事项】 +' 1. 调用前必须先执行 LoadData() 方法加载BOM数据 +' 2. 型号字符串必须完整且符合格式要求 +' 3. 返回的Collection可能为空(没有符合条件的物料),需要判断Count属性 +' 4. 调试信息会输出到VBA的"立即窗口"(Ctrl+G查看) +' 5. 物料的Condition属性为空表示该物料无条件限制(所有型号都使用) +' 6. autoFallback 参数影响查找范围: +' - True (默认): 会返回父类别和子类别的物料,更全面但可能包含不需要的物料 +' - False: 仅返回指定类别的物料,更精确但可能遗漏子类别的替代物料 +' +' 【相关方法】 +' - GetMaterialsByCategoryAndModel: 结合了类别层级逻辑的物料获取 +' - GetMaterialsForPicking: 纯粹按类别获取物料(不进行型号匹配) +' - ParseModelAndExtractConditions: 仅解析型号并返回条件字典 +' ======================================== +Public Function GetMaterialsByModel(modelStr As String, _ + Optional categoryName As String = "", _ + Optional autoFallback As Boolean = True) As collection + Dim result As collection + Set result = New collection + + ' ======================================== + ' 第1步: 解析型号并提取条件 + ' ======================================== + Dim parser As New clsModelParser + If Not parser.ParseModel(modelStr) Then + Debug.Print "型号解析失败: " & parser.ErrorMessage + Set GetMaterialsByModel = result + Exit Function + End If + + Dim extractor As New clsConditionExtractor + Dim conditions As Object + Set conditions = extractor.ExtractConditions(parser) + + ' 调试输出 + Debug.Print "【型号】: " & modelStr + Debug.Print "【提取的条件】:" + Dim key As Variant + For Each key In conditions.Keys + Debug.Print " " & key & " = " & conditions(key) + Next key + Debug.Print "" + + ' ======================================== + ' 第2步: 按类别筛选物料（根据参数决定是否自动降级到子类别） + ' ======================================== + Dim matcher As New clsConditionMatcher + Dim totalMatchCount As Long + Dim catResult As collection ' 提前声明，避免在If/Else中重复声明 + Dim cat As clsCategory + Dim rootCat As clsCategory + Dim i As Long, j As Long + totalMatchCount = 0 + + If autoFallback Then + Debug.Print "【降级模式】启用自动降级到子类别" + Else + Debug.Print "【降级模式】禁用自动降级，仅查找当前类别" + End If + Debug.Print "" + + If categoryName <> "" Then + ' ======================================== + ' 情况A: 指定了类别名称 + ' 只在该类别及其子类别中查找 + ' ======================================== + Set cat = GetCategory(categoryName) + + If Not cat Is Nothing Then + ' 从该类别开始查找（根据参数决定是否启用子类别降级逻辑） + Set catResult = FilterCategoryWithSubcategories(cat, matcher, conditions, autoFallback) + + ' 合并结果 + For i = 1 To catResult.Count + result.Add catResult(i) + Next i + totalMatchCount = catResult.Count + End If + Else + ' ======================================== + ' 情况B: 未指定类别名称 + ' 遍历所有根类别，对每个类别应用子类别降级逻辑 + ' ======================================== + For j = 1 To rootCategories.Count + Set rootCat = rootCategories(j) + + ' 对每个根类别应用筛选（根据参数决定是否启用子类别降级逻辑） + Set catResult = FilterCategoryWithSubcategories(rootCat, matcher, conditions, autoFallback) + + ' 合并结果 + For i = 1 To catResult.Count + result.Add catResult(i) + Next i + totalMatchCount = totalMatchCount + catResult.Count + Next j + End If + + Debug.Print "共匹配 " & totalMatchCount & " 个物料" + Debug.Print String(60, "=") + + Set GetMaterialsByModel = result +End Function + +' ======================================== +' FilterCategoryWithSubcategories 方法 (私有) +' 功能: 对指定类别进行筛选，根据参数决定是否自动降级到子类别 +' 参数: +' cat - 类别对象 +' matcher - 条件匹配器对象 +' conditions - 提取的条件字典 +' autoFallback - 是否自动降级到子类别（默认True） +' True: 当前类别无匹配时，自动降级到子类别查找 +' False: 仅在当前类别查找，不降级到子类别 +' 返回: Collection对象，包含匹配的物料 +' +' 工作逻辑: +' 1. 先尝试在当前类别下筛选物料 +' 2. 如果当前类别有匹配结果，直接返回 +' 3. 如果当前类别无匹配结果且 autoFallback=True，检查是否有子类别 +' 4. 如果有子类别且允许降级，递归对所有子类别进行筛选 +' 5. 如果无子类别或不允许降级，返回当前结果 +' +' 示例场景: +' 型号: "YTHN-100.A0.532.M203.M16.Y3" +' 类别"部件"下有物料"低压接头部件"（条件: lcfw=M02） +' 如果该型号的量程不是M02，则"部件"类别无匹配 +' 当 autoFallback=True 时，自动降级到子类别"接头"、"弹性元件"等查找 +' 当 autoFallback=False 时，返回空集合，不查找子类别 +' ======================================== +Private Function FilterCategoryWithSubcategories(ByVal cat As clsCategory, _ + ByVal matcher As clsConditionMatcher, _ + ByVal conditions As Object, _ + ByVal autoFallback As Boolean) As collection + Dim result As collection + Set result = New collection + + ' 类别不存在，返回空集合 + If cat Is Nothing Then + Set FilterCategoryWithSubcategories = result + Exit Function + End If + + ' ======================================== + ' 第一阶段: 尝试在当前类别下筛选 + ' ======================================== + Dim mat As clsMaterialItem + Dim i As Long + Dim matchCount As Long + matchCount = 0 + + ' 遍历当前类别的所有物料进行筛选 + For i = 1 To cat.materials.Count + Set mat = cat.materials(i) + If matcher.IsMatch(mat.Condition, conditions) Then + result.Add mat + matchCount = matchCount + 1 + + ' 调试输出 + Debug.Print "【匹配】" & cat.categoryName & " > " & _ + mat.code & " - " & mat.Name & _ + " | 条件: " & IIf(mat.Condition = "", "(无)", mat.Condition) + End If + Next i + + ' ======================================== + ' 第二阶段: 如果当前类别无匹配且允许降级，检查子类别 + ' ======================================== + If matchCount = 0 And cat.HasSubCategories And autoFallback Then + Debug.Print "【降级】类别 """ & cat.categoryName & """ 无匹配物料，降级到子类别查找..." + + ' 递归处理所有子类别 + Dim subCat As clsCategory + Dim j As Long + For j = 1 To cat.SubCategories.Count + Set subCat = cat.SubCategories(j) + + ' 递归调用，获取子类别的匹配结果（传递相同的 autoFallback 参数） + Dim subResult As collection + Set subResult = FilterCategoryWithSubcategories(subCat, matcher, conditions, autoFallback) + + ' 合并子类别的结果 + Dim k As Long + For k = 1 To subResult.Count + result.Add subResult(k) + Next k + Next j + ElseIf matchCount = 0 And cat.HasSubCategories And Not autoFallback Then + Debug.Print "【跳过】类别 """ & cat.categoryName & """ 无匹配物料，但降级已禁用，不查找子类别" + ElseIf matchCount > 0 Then + Debug.Print "【成功】类别 """ & cat.categoryName & """ 匹配 " & matchCount & " 个物料" + End If + + Set FilterCategoryWithSubcategories = result +End Function + +' ======================================== +' CollectAllMaterials 方法 (私有) +' 功能: 递归收集类别及其所有子类别的物料 +' 参数: +' cat - 类别对象 +' collection - 用于存储物料的Collection +' ======================================== +Private Sub CollectAllMaterials(cat As clsCategory, collection As collection) + Dim i As Long + + ' 添加当前类别的所有物料 + For i = 1 To cat.materials.Count + collection.Add cat.materials(i) + Next i + + ' 递归处理子类别 + Dim subCat As clsCategory + Dim j As Long + For j = 1 To cat.SubCategories.Count + Set subCat = cat.SubCategories(j) + Call CollectAllMaterials(subCat, collection) + Next j +End Sub + +' ======================================== +' GetMaterialsByCategoryAndModel 方法 +' 功能: 根据类别和型号获取物料（使用父类别或子类别逻辑） +' 参数: +' modelStr - 产品型号字符串 +' categoryName - 类别名称 +' useParent - True=使用父类别物料，False=使用子类别物料 +' 返回: Collection对象，包含符合条件的clsMaterialItem对象 +' 说明: 这是 GetMaterialsForPicking 和 GetMaterialsByModel 的结合 +' ======================================== +Public Function GetMaterialsByCategoryAndModel(modelStr As String, _ + categoryName As String, _ + Optional useParent As Boolean = True) As collection + Dim result As collection + Set result = New collection + + ' 1. 解析型号并提取条件 + Dim parser As New clsModelParser + If Not parser.ParseModel(modelStr) Then + Set GetMaterialsByCategoryAndModel = result + Exit Function + End If + + Dim extractor As New clsConditionExtractor + Dim conditions As Object + Set conditions = extractor.ExtractConditions(parser) + + ' 2. 获取类别的物料（根据 useParent 参数） + Dim materialsToFilter As collection + Set materialsToFilter = GetMaterialsForPicking(categoryName, useParent) + + ' 3. 筛选符合条件的物料 + Dim matcher As New clsConditionMatcher + Dim mat As clsMaterialItem + + For Each mat In materialsToFilter + If matcher.IsMatch(mat.Condition, conditions) Then + result.Add mat + End If + Next mat + + Set GetMaterialsByCategoryAndModel = result +End Function + +' ======================================== +' ParseModelAndExtractConditions 方法 +' 功能: 解析型号并返回条件字典（工具方法） +' 参数: modelStr - 产品型号字符串 +' 返回: Dictionary对象，包含提取的条件 +' 用途: 供外部调用，用于查看提取的条件 +' ======================================== +Public Function ParseModelAndExtractConditions(modelStr As String) As Object + Dim parser As New clsModelParser + Dim extractor As New clsConditionExtractor + Dim conditions As Object + + If parser.ParseModel(modelStr) Then + Set conditions = extractor.ExtractConditions(parser) + Else + Set conditions = CreateObject("Scripting.Dictionary") + End If + + Set ParseModelAndExtractConditions = conditions +End Function + +' ======================================== +' GetValidMaterialsByModel 方法 +' 功能: 根据产品型号获取物料，并判断是否为完整的物料集合 +' 参数: +' modelStr - 产品型号字符串 +' 返回: Collection对象 +' Collection中包含两个元素: +' (1) "Materials" - Collection对象,包含所有匹配的 clsMaterialItem 对象 +' (2) "IsComplete" - Boolean值,指示物料是否完整 +' +' 完整性判断规则: +' - 对于每个需要领料的类别(顶层类别或其需要领取的子类别) +' - 必须有且仅有一个物料被匹配 +' - 如果某个类别有0个或多于1个物料,则视为不完整 +' +' 示例: +' Dim result As Collection +' Set result = bomMgr.GetValidMaterialsByModel("YTHN-100.A0.532.M203.M16.Y3") +' Dim materials As Collection +' Dim isComplete As Boolean +' Set materials = result("Materials") +' isComplete = result("IsComplete") +' ======================================== +Public Function GetValidMaterialsByModel(modelStr As String) As collection + Dim result As New collection + Dim allMaterials As New collection + Dim isComplete As Boolean + + ' 解析型号并提取条件 + Dim parser As New clsModelParser + If Not parser.ParseModel(modelStr) Then + Debug.Print "型号解析失败: " & parser.ErrorMessage + isComplete = False + result.Add allMaterials, "Materials" + result.Add isComplete, "IsComplete" + Set GetValidMaterialsByModel = result + Exit Function + End If + + Dim extractor As New clsConditionExtractor + Dim conditions As Object + Set conditions = extractor.ExtractConditions(parser) + + ' 调试输出 + Debug.Print "【GetValidMaterialsByModel】" + Debug.Print "型号: " & modelStr + Debug.Print "提取的条件:" + Dim key As Variant + For Each key In conditions.Keys + Debug.Print " " & key & " = " & conditions(key) + Next key + Debug.Print "" + + ' 条件匹配器 + Dim matcher As New clsConditionMatcher + + ' 遍历所有根类别,检查完整性 + isComplete = True + Dim categoryCheckResults As Object + Set categoryCheckResults = CreateObject("Scripting.Dictionary") + + Dim rootCat As clsCategory + Dim i As Long + For i = 1 To rootCategories.count + Set rootCat = rootCategories(i) + + ' 检查该类别及其子类别的完整性 + Dim catResult As Object + Set catResult = CheckCategoryCompleteness(rootCat, matcher, conditions) + + ' 合并物料 + Dim mat As clsMaterialItem + Dim matCollection As collection + Set matCollection = catResult("Materials") + For Each mat In matCollection + allMaterials.Add mat + Next mat + + ' 检查完整性 + If Not catResult("IsComplete") Then + isComplete = False + Debug.Print "【不完整】类别 """ & rootCat.categoryName & """ 物料不完整" + End If + + ' 保存类别检查结果(用于调试) + categoryCheckResults(rootCat.categoryName) = catResult("IsComplete") + Next i + + ' 调试输出总结 + Debug.Print "" + Debug.Print "【完整性检查结果】" + Debug.Print "总物料数: " & allMaterials.count + Debug.Print "是否完整: " & IIf(isComplete, "是", "否") + For Each key In categoryCheckResults.Keys + Debug.Print " " & key & ": " & IIf(categoryCheckResults(key), "完整", "不完整") + Next key + Debug.Print String(60, "=") + + ' 返回结果 + result.Add allMaterials, "Materials" + result.Add isComplete, "IsComplete" + Set GetValidMaterialsByModel = result +End Function + +' ======================================== +' CheckCategoryCompleteness 方法 (私有) +' 功能: 检查单个类别的完整性(递归处理子类别) +' 参数: +' cat - 类别对象 +' matcher - 条件匹配器 +' conditions - 提取的条件字典 +' 返回: Dictionary对象 +' "Materials" - Collection,包含该类别匹配的物料 +' "IsComplete" - Boolean,该类别是否完整 +' +' 完整性判断逻辑: +' 1. 如果类别没有子类别(叶子类别): +' - 必须有且仅有1个物料匹配 → 完整 +' - 0个或多于1个物料 → 不完整 +' +' 2. 如果类别有子类别: +' a) 先尝试在父类别查找物料 +' b) 如果父类别有且仅有1个匹配物料 → 使用父类别,完整 +' c) 如果父类别没有匹配物料 → 降级到所有子类别 +' - 每个子类别都必须有且仅有1个匹配物料 → 完整 +' - 任一子类别不满足 → 不完整 +' ======================================== +Private Function CheckCategoryCompleteness(cat As clsCategory, _ + matcher As clsConditionMatcher, _ + conditions As Object) As Object + Dim result As Object + Set result = CreateObject("Scripting.Dictionary") + + Dim materials As New collection + Dim isComplete As Boolean + + ' 首先在当前类别查找匹配的物料 + Dim mat As clsMaterialItem + Dim matchCount As Long + matchCount = 0 + + Dim i As Long + For i = 1 To cat.materials.count + Set mat = cat.materials(i) + If matcher.IsMatch(mat.Condition, conditions) Then + materials.Add mat + matchCount = matchCount + 1 + End If + Next i + + ' 判断完整性 + If Not cat.HasSubCategories Then + ' ======================================== + ' 情况1: 叶子类别(无子类别) + ' 必须有且仅有1个物料 + ' ======================================== + If matchCount = 1 Then + isComplete = True + Debug.Print "【完整】叶子类别 """ & cat.categoryName & """ 有1个匹配物料" + Else + isComplete = False + If matchCount = 0 Then + Debug.Print "【不完整】叶子类别 """ & cat.categoryName & """ 无匹配物料" + Else + Debug.Print "【不完整】叶子类别 """ & cat.categoryName & """ 有" & matchCount & "个匹配物料(应为1个)" + End If + End If + Else + ' ======================================== + ' 情况2: 有子类别 + ' 先检查父类别,如果父类别满足则使用父类别 + ' 否则降级到子类别,每个子类别都必须满足 + ' ======================================== + If matchCount = 1 Then + ' 父类别有且仅有1个物料,使用父类别 + isComplete = True + Debug.Print "【完整】父类别 """ & cat.categoryName & """ 有1个匹配物料,使用父类别" + ElseIf matchCount = 0 Then + ' 父类别无匹配物料,降级到子类别 + Debug.Print "【降级】父类别 """ & cat.categoryName & """ 无匹配物料,检查子类别..." + + ' 清空物料集合,准备收集子类别物料 + Set materials = New collection + isComplete = True ' 假设完整,如果任一子类别不完整则设为False + + Dim subCat As clsCategory + Dim j As Long + For j = 1 To cat.SubCategories.count + Set subCat = cat.SubCategories(j) + + ' 递归检查子类别 + Dim subResult As Object + Set subResult = CheckCategoryCompleteness(subCat, matcher, conditions) + + ' 合并子类别物料 + Dim subMaterials As collection + Set subMaterials = subResult("Materials") + Dim k As Long + For k = 1 To subMaterials.count + materials.Add subMaterials(k) + Next k + + ' 检查子类别是否完整 + If Not subResult("IsComplete") Then + isComplete = False + End If + Next j + + If isComplete Then + Debug.Print "【完整】类别 """ & cat.categoryName & """ 所有子类别都完整" + Else + Debug.Print "【不完整】类别 """ & cat.categoryName & """ 存在不完整的子类别" + End If + Else + ' 父类别有多个匹配物料,不完整 + isComplete = False + Debug.Print "【不完整】父类别 """ & cat.categoryName & """ 有" & matchCount & "个匹配物料(应为0或1个)" + End If + End If + + ' 返回结果 + Set result("Materials") = materials + result("IsComplete") = isComplete + Set CheckCategoryCompleteness = result +End Function +``` + +## ClassModules\clsCategory.cls + +``` +' ======================================== +' 类模块: clsCategory +' 用途: 表示物料类别及其层级关系 +' ======================================== +Option Explicit + +Public categoryName As String +Public ParentCategoryName As String +Public materials As collection ' 存储 clsMaterialItem 对象 +Public SubCategories As collection ' 存储子类别 clsCategory 对象 +Public IsLeafCategory As Boolean ' 是否叶子类别(无子类别) + +Private Sub Class_Initialize() + Set materials = New collection + Set SubCategories = New collection + IsLeafCategory = True +End Sub + +' 添加物料 +Public Sub AddMaterial(mat As clsMaterialItem) + materials.Add mat, mat.code +End Sub + +' 添加子类别 +Public Sub AddSubCategory(cat As clsCategory) + SubCategories.Add cat, cat.categoryName + IsLeafCategory = False +End Sub + +' 获取物料(按代号) +Public Function GetMaterial(code As String) As clsMaterialItem + On Error Resume Next + Set GetMaterial = materials(code) + On Error GoTo 0 +End Function + +' 检查是否有子类别 +Public Function HasSubCategories() As Boolean + HasSubCategories = (SubCategories.Count > 0) +End Function +``` + +## ClassModules\clsConditionExtractor.cls + +``` +' ======================================== +' 类模块: clsConditionExtractor +' 用途: 从型号解析器中提取物料选择条件 +' ======================================== +Option Explicit + +' ======================================== +' 私有成员变量 +' ======================================== +Private m_Conditions As Object ' Dictionary: 变量名 -> 条件值 +Private m_ExtractionRules As Object ' Dictionary: 提取规则配置 + +' ======================================== +' 类初始化 +' ======================================== +Private Sub Class_Initialize() + Set m_Conditions = CreateObject("Scripting.Dictionary") + Set m_ExtractionRules = CreateObject("Scripting.Dictionary") + + ' 初始化提取规则 + InitializeRules +End Sub + +' ======================================== +' InitializeRules 方法 (私有) +' 功能: 初始化条件提取规则 +' 说明: 这里配置所有需要提取的条件及其提取方法 +' ======================================== +Private Sub InitializeRules() + ' 规则格式: Dictionary(变量名) = Array(源字段, 提取方法) + + ' 规则1: 过程连接 (gclj) + ' 从 ConnectionCode 中提取，去掉最后一位数字 + m_ExtractionRules("gclj") = Array("ConnectionCode", "RemoveLastDigit") + + ' 规则2: 接液材质 (jycz) + ' 从 ConnectionCode 中提取，取最后一位数字 + m_ExtractionRules("jycz") = Array("ConnectionCode", "GetLastDigit") + + ' 规则3: 量程范围 (lcfw) + ' 从 RangeCode 中直接提取 + m_ExtractionRules("lcfw") = Array("RangeCode", "Direct") + + ' 未来可以在这里添加更多提取规则... + ' 例如: + ' m_ExtractionRules("bplx") = Array("DialCode", "Direct") ' 表盘类型 +End Sub + +' ======================================== +' ExtractConditions 方法 +' 功能: 从型号解析器中提取所有条件 +' 参数: parser - clsModelParser对象 +' 返回: Dictionary对象，包含所有提取的条件 +' ======================================== +Public Function ExtractConditions(parser As clsModelParser) As Object + ' 清空现有条件 + Set m_Conditions = CreateObject("Scripting.Dictionary") + + ' 验证解析器有效性 + If Not parser.IsValid Then + Set ExtractConditions = m_Conditions + Exit Function + End If + + ' 遍历所有提取规则 + Dim varName As Variant + For Each varName In m_ExtractionRules.Keys + Dim ruleInfo As Variant + ruleInfo = m_ExtractionRules(varName) + + Dim sourceField As String + Dim extractMethod As String + sourceField = ruleInfo(0) + extractMethod = ruleInfo(1) + + ' 提取条件值 + Dim conditionValue As String + conditionValue = ExtractValue(parser, sourceField, extractMethod) + + ' 添加到条件字典 + If conditionValue <> "" Then + m_Conditions(CStr(varName)) = conditionValue + End If + Next varName + + Set ExtractConditions = m_Conditions +End Function + +' ======================================== +' ExtractValue 方法 (私有) +' 功能: 根据规则从解析器中提取单个值 +' 参数: +' parser - clsModelParser对象 +' sourceField - 源字段名称 +' extractMethod - 提取方法名称 +' 返回: 提取的条件值 +' ======================================== +Private Function ExtractValue(parser As clsModelParser, _ + sourceField As String, _ + extractMethod As String) As String + Dim sourceValue As String + + ' 获取源字段值 + Select Case sourceField + Case "ConnectionCode" + sourceValue = parser.ConnectionCode + Case "RangeCode" + sourceValue = parser.RangeCode + Case "ModelType" + sourceValue = parser.ModelType + Case "Diameter" + sourceValue = parser.Diameter + Case "InstallForm" + sourceValue = parser.InstallForm + Case "ShellForm" + sourceValue = parser.ShellForm + Case "Characteristics" + sourceValue = parser.Characteristics + Case Else + sourceValue = "" + End Select + + ' 应用提取方法 + Select Case extractMethod + Case "Direct" + ' 直接使用 + ExtractValue = sourceValue + + Case "RemoveLastDigit" + ' 去掉最后一位字符 + If Len(sourceValue) > 1 Then + ExtractValue = Left(sourceValue, Len(sourceValue) - 1) + Else + ExtractValue = sourceValue + End If + + Case "GetLastDigit" + ' 取最后一位字符 + If Len(sourceValue) > 0 Then + ExtractValue = Right(sourceValue, 1) + Else + ExtractValue = "" + End If + + Case "GetFirstChar" + ' 取第一个字符 + If Len(sourceValue) > 0 Then + ExtractValue = Left(sourceValue, 1) + Else + ExtractValue = "" + End If + + Case Else + ' 未知方法，返回空 + ExtractValue = "" + End Select +End Function + +' ======================================== +' GetConditionValue 方法 +' 功能: 获取单个条件值 +' 参数: varName - 变量名 +' 返回: 条件值，如果不存在返回空字符串 +' ======================================== +Public Function GetConditionValue(varName As String) As String + If m_Conditions.Exists(varName) Then + GetConditionValue = m_Conditions(varName) + Else + GetConditionValue = "" + End If +End Function + +' ======================================== +' AddCondition 方法 +' 功能: 手动添加条件 (用于特殊情况) +' 参数: +' varName - 变量名 +' value - 条件值 +' ======================================== +Public Sub AddCondition(varName As String, value As String) + m_Conditions(varName) = value +End Sub + +' ======================================== +' GetConditions 属性 +' 功能: 获取所有条件的Dictionary对象 +' ======================================== +Public Property Get conditions() As Object + Set conditions = m_Conditions +End Property + +' ======================================== +' ToString 方法 +' 功能: 返回条件的字符串表示 (用于调试) +' ======================================== +Public Function ToString() As String + Dim result As String + result = "【提取的条件】" & vbCrLf + + If m_Conditions.Count = 0 Then + result = result & " (无条件)" & vbCrLf + Else + Dim key As Variant + For Each key In m_Conditions.Keys + result = result & " " & key & " = " & m_Conditions(key) & vbCrLf + Next key + End If + + ToString = result +End Function + +' ======================================== +' AddExtractionRule 方法 +' 功能: 动态添加新的提取规则 (用于扩展) +' 参数: +' varName - 变量名 +' sourceField - 源字段名称 +' extractMethod - 提取方法名称 +' 示例: extractor.AddExtractionRule "bplx", "DialCode", "Direct" +' ======================================== +Public Sub AddExtractionRule(varName As String, _ + sourceField As String, _ + extractMethod As String) + m_ExtractionRules(varName) = Array(sourceField, extractMethod) +End Sub + +' ======================================== +' GetExtractionRules 方法 +' 功能: 获取当前所有提取规则 (用于调试) +' 返回: Dictionary对象 +' ======================================== +Public Function GetExtractionRules() As Object + Set GetExtractionRules = m_ExtractionRules +End Function +``` + +## ClassModules\clsConditionMatcher.cls + +``` +' ======================================== +' 类模块: clsConditionMatcher +' 用途: 解析物料的选择条件表达式，并判断是否匹配 +' 支持: AND, OR, NOT(!=), 括号优先级 +' ======================================== +Option Explicit + +' ======================================== +' IsMatch 方法 +' 功能: 判断条件表达式是否匹配 +' 参数: +' conditionExpr - 条件表达式字符串 +' conditions - Dictionary对象，包含变量名->值的映射 +' 返回: Boolean - 是否匹配 +' 示例: +' IsMatch("lcfw=M16 AND gclj=M20", conditions) -> True/False +' ======================================== +Public Function IsMatch(conditionExpr As String, conditions As Object) As Boolean + On Error GoTo ErrorHandler + + ' 空条件表示无条件，始终匹配 + If Trim(conditionExpr) = "" Then + IsMatch = True + Exit Function + End If + + ' 解析并计算表达式 + IsMatch = EvaluateExpression(Trim(conditionExpr), conditions) + Exit Function + +ErrorHandler: + ' 出错时返回False（保守处理） + Debug.Print "条件匹配出错: " & conditionExpr & " - " & Err.description + IsMatch = False +End Function + +' ======================================== +' EvaluateExpression 方法 (私有) +' 功能: 递归计算逻辑表达式 +' 优先级: 括号 > NOT(!=) > AND > OR +' ======================================== +Private Function EvaluateExpression(expr As String, conditions As Object) As Boolean + expr = Trim(expr) + + ' 处理括号 (最高优先级) + If InStr(expr, "(") > 0 Then + EvaluateExpression = EvaluateWithParentheses(expr, conditions) + Exit Function + End If + + ' 处理 OR (最低优先级) + If InStr(expr, " OR ") > 0 Then + EvaluateExpression = EvaluateOR(expr, conditions) + Exit Function + End If + + ' 处理 AND (中等优先级) + If InStr(expr, " AND ") > 0 Then + EvaluateExpression = EvaluateAND(expr, conditions) + Exit Function + End If + + ' 处理单个条件 (最高优先级) + EvaluateExpression = EvaluateSimpleCondition(expr, conditions) +End Function + +' ======================================== +' EvaluateWithParentheses 方法 (私有) +' 功能: 处理包含括号的表达式 +' 策略: 找到最内层括号，递归计算，然后替换为结果 +' ======================================== +Private Function EvaluateWithParentheses(expr As String, conditions As Object) As Boolean + Dim pos As Long, level As Long, startPos As Long + Dim i As Long + Dim innerExpr As String + Dim innerResult As Boolean + Dim newExpr As String + + ' 查找最内层的括号对 + startPos = 0 + level = 0 + + For i = 1 To Len(expr) + If Mid(expr, i, 1) = "(" Then + If level = 0 Then startPos = i + level = level + 1 + ElseIf Mid(expr, i, 1) = ")" Then + level = level - 1 + If level = 0 And startPos > 0 Then + ' 找到一对括号 + innerExpr = Mid(expr, startPos + 1, i - startPos - 1) + innerResult = EvaluateExpression(innerExpr, conditions) + + ' 替换括号部分为结果 + newExpr = Left(expr, startPos - 1) & _ + IIf(innerResult, "TRUE", "FALSE") & _ + Mid(expr, i + 1) + + ' 递归处理剩余部分 + EvaluateWithParentheses = EvaluateExpression(newExpr, conditions) + Exit Function + End If + End If + Next i + + ' 如果没有找到有效括号，直接计算 + EvaluateWithParentheses = EvaluateExpression(expr, conditions) +End Function + +' ======================================== +' EvaluateOR 方法 (私有) +' 功能: 处理 OR 逻辑运算 +' 规则: 任一为真则为真 +' ======================================== +Private Function EvaluateOR(expr As String, conditions As Object) As Boolean + Dim parts() As String + Dim part As Variant + + ' 按 OR 分割 + parts = Split(expr, " OR ") + + ' 任一部分为真则返回真 + For Each part In parts + If EvaluateExpression(Trim(CStr(part)), conditions) Then + EvaluateOR = True + Exit Function + End If + Next part + + EvaluateOR = False +End Function + +' ======================================== +' EvaluateAND 方法 (私有) +' 功能: 处理 AND 逻辑运算 +' 规则: 全部为真才为真 +' ======================================== +Private Function EvaluateAND(expr As String, conditions As Object) As Boolean + Dim parts() As String + Dim part As Variant + + ' 按 AND 分割 + parts = Split(expr, " AND ") + + ' 全部部分为真才返回真 + For Each part In parts + If Not EvaluateExpression(Trim(CStr(part)), conditions) Then + EvaluateAND = False + Exit Function + End If + Next part + + EvaluateAND = True +End Function + +' ======================================== +' EvaluateSimpleCondition 方法 (私有) +' 功能: 计算单个条件表达式 +' 支持: = (等于), != (不等于) +' 格式: varName=value 或 varName!=value +' ======================================== +Private Function EvaluateSimpleCondition(cond As String, conditions As Object) As Boolean + cond = Trim(cond) + + ' 处理特殊值 TRUE/FALSE (括号计算的结果) + If UCase(cond) = "TRUE" Then + EvaluateSimpleCondition = True + Exit Function + ElseIf UCase(cond) = "FALSE" Then + EvaluateSimpleCondition = False + Exit Function + End If + + Dim varName As String + Dim expectedValue As String + Dim actualValue As String + Dim isNotEqual As Boolean + + ' 判断是 != 还是 = + If InStr(cond, "!=") > 0 Then + isNotEqual = True + Dim parts1() As String + parts1 = Split(cond, "!=") + If UBound(parts1) < 1 Then + EvaluateSimpleCondition = False + Exit Function + End If + varName = Trim(parts1(0)) + expectedValue = Trim(parts1(1)) + ElseIf InStr(cond, "=") > 0 Then + isNotEqual = False + Dim parts2() As String + parts2 = Split(cond, "=") + If UBound(parts2) < 1 Then + EvaluateSimpleCondition = False + Exit Function + End If + varName = Trim(parts2(0)) + expectedValue = Trim(parts2(1)) + Else + ' 无效的条件格式 + EvaluateSimpleCondition = False + Exit Function + End If + + ' 获取实际值 + If conditions.Exists(varName) Then + actualValue = Trim(CStr(conditions(varName))) + Else + actualValue = "" + End If + + ' 比较值 (不区分大小写) + Dim isEqual As Boolean + isEqual = (UCase(actualValue) = UCase(expectedValue)) + + ' 返回结果 + If isNotEqual Then + EvaluateSimpleCondition = Not isEqual + Else + EvaluateSimpleCondition = isEqual + End If +End Function + +' ======================================== +' TestExpression 方法 +' 功能: 测试表达式是否有效 (用于调试) +' 参数: expr - 表达式字符串 +' 返回: String - "有效" 或 错误信息 +' ======================================== +Public Function TestExpression(expr As String) As String + On Error GoTo ErrorHandler + + ' 创建测试条件 + Dim testConditions As Object + Set testConditions = CreateObject("Scripting.Dictionary") + testConditions("gclj") = "M20" + testConditions("jycz") = "3" + testConditions("lcfw") = "M16" + + ' 尝试计算 + Dim result As Boolean + result = IsMatch(expr, testConditions) + + TestExpression = "有效 (结果: " & IIf(result, "True", "False") & ")" + Exit Function + +ErrorHandler: + TestExpression = "无效: " & Err.description +End Function +``` + +## ClassModules\clsMaterialItem.cls + +``` +' ======================================== +' 类模块: clsMaterialItem +' 用途: 表示单个物料项 +' ======================================== +Option Explicit + +Public code As String ' 代号 +Public Name As String ' 名称 +Public Quantity As Double ' 数量 +Public Condition As String ' 选择条件 +Public Category As String ' 类别 +Public ParentCategory As String ' 上层类别 +``` + +## ClassModules\clsModelParser.cls + +``` +' ======================================== +' 类模块: clsModelParser +' 用途: 解析产品型号，提取各部分代码 +' 示例: YTHN-100.A0.532.M203.M16.Y3|BP-095.2312.M16.PA3 +' ======================================== +Option Explicit + +' ======================================== +' 公共属性 +' ======================================== +Public RawModel As String ' 原始完整型号 +Public HeaderModel As String ' 表头型号部分 +Public DialModel As String ' 表盘型号部分 +Public AccessoryModel As String ' 附件型号部分 +Public FlangeModel As String ' 法兰隔膜型号部分 + +' 表头各部分 +Public ModelType As String ' 型号 (如 YTHN) +Public Diameter As String ' 公称外径 (如 100) +Public InstallForm As String ' 安装形式 (如 A0) +Public ShellForm As String ' 壳体形式 (如 532) +Public ConnectionCode As String ' 过程连接&材质代码 (如 M203) +Public RangeCode As String ' 量程范围代码 (如 M16) +Public Characteristics As String ' 仪表特性 (如 Y3) + +' ======================================== +' 私有变量 +' ======================================== +Private m_IsValid As Boolean ' 解析是否成功 +Private m_ErrorMessage As String ' 错误信息 + +' ======================================== +' ParseModel 方法 +' 功能: 解析产品型号字符串 +' 参数: modelStr - 完整的产品型号字符串 +' 返回: Boolean - 解析是否成功 +' 示例: parser.ParseModel("YTHN-100.A0.532.M203.M16.Y3|BP-095.2312.M16.PA3") +' ======================================== +Public Function ParseModel(modelStr As String) As Boolean + On Error GoTo ErrorHandler + + ' 初始化 + m_IsValid = False + m_ErrorMessage = "" + RawModel = Trim(modelStr) + + ' 验证输入 + If RawModel = "" Then + m_ErrorMessage = "型号字符串为空" + ParseModel = False + Exit Function + End If + + ' 第一步: 按 | 分割各部分 + Dim parts() As String + parts = Split(RawModel, "|") + + If UBound(parts) >= 0 Then HeaderModel = Trim(parts(0)) + If UBound(parts) >= 1 Then DialModel = Trim(parts(1)) + If UBound(parts) >= 2 Then AccessoryModel = Trim(parts(2)) + If UBound(parts) >= 3 Then FlangeModel = Trim(parts(3)) + + ' 第二步: 解析表头部分 (必须存在) + If HeaderModel = "" Then + m_ErrorMessage = "表头型号为空" + ParseModel = False + Exit Function + End If + + ' 解析表头 + If Not ParseHeader(HeaderModel) Then + ParseModel = False + Exit Function + End If + + m_IsValid = True + ParseModel = True + Exit Function + +ErrorHandler: + m_ErrorMessage = "解析出错: " & Err.description + m_IsValid = False + ParseModel = False +End Function + +' ======================================== +' ParseHeader 方法 (私有) +' 功能: 解析表头型号部分 +' 格式: [型号]-[公称外径].[安装形式].[壳体形式].[过程连接&材质].[量程范围].[仪表特性] +' 示例: YTHN-100.A0.532.M203.M16.Y3 +' ======================================== +Private Function ParseHeader(headerStr As String) As Boolean + On Error GoTo ErrorHandler + + ' 按 - 分割型号和参数部分 + Dim mainParts() As String + mainParts = Split(headerStr, "-") + + If UBound(mainParts) < 1 Then + m_ErrorMessage = "表头格式错误: 缺少 - 分隔符" + ParseHeader = False + Exit Function + End If + + ' 提取型号 + ModelType = Trim(mainParts(0)) + + ' 按 . 分割参数部分 + Dim params() As String + params = Split(mainParts(1), ".") + + ' 验证参数数量 (至少应该有5个部分) + If UBound(params) < 4 Then + m_ErrorMessage = "表头参数不足: 需要至少5个参数段" + ParseHeader = False + Exit Function + End If + + ' 提取各参数 + Diameter = Trim(params(0)) ' 公称外径 + InstallForm = Trim(params(1)) ' 安装形式 + ShellForm = Trim(params(2)) ' 壳体形式 + ConnectionCode = Trim(params(3)) ' 过程连接&材质 + RangeCode = Trim(params(4)) ' 量程范围 + + ' 仪表特性 (可选) + If UBound(params) >= 5 Then + Characteristics = Trim(params(5)) + Else + Characteristics = "" + End If + + ParseHeader = True + Exit Function + +ErrorHandler: + m_ErrorMessage = "解析表头出错: " & Err.description + ParseHeader = False +End Function + +' ======================================== +' GetThreadCode 方法 +' 功能: 从过程连接代码中提取螺纹代码 +' 规则: 去掉最后一位数字 +' 示例: M203 -> M20 +' ======================================== +Public Function GetThreadCode() As String + If ConnectionCode = "" Then + GetThreadCode = "" + Exit Function + End If + + ' 去掉最后一位字符 (假设最后一位是材质代码) + If Len(ConnectionCode) > 1 Then + GetThreadCode = Left(ConnectionCode, Len(ConnectionCode) - 1) + Else + GetThreadCode = ConnectionCode + End If +End Function + +' ======================================== +' GetMaterialCode 方法 +' 功能: 从过程连接代码中提取材质代码 +' 规则: 取最后一位数字 +' 示例: M203 -> 3 +' ======================================== +Public Function GetMaterialCode() As String + If ConnectionCode = "" Then + GetMaterialCode = "" + Exit Function + End If + + ' 取最后一位字符 + GetMaterialCode = Right(ConnectionCode, 1) +End Function + +' ======================================== +' GetRangeCode 方法 +' 功能: 获取量程代码 +' 规则: 直接返回 +' 示例: M16 -> M16 +' ======================================== +Public Function GetRangeCode() As String + GetRangeCode = RangeCode +End Function + +' ======================================== +' IsValid 属性 +' 功能: 返回解析是否成功 +' ======================================== +Public Property Get IsValid() As Boolean + IsValid = m_IsValid +End Property + +' ======================================== +' ErrorMessage 属性 +' 功能: 返回错误信息 +' ======================================== +Public Property Get ErrorMessage() As String + ErrorMessage = m_ErrorMessage +End Property + +' ======================================== +' ToString 方法 +' 功能: 返回解析结果的字符串表示 (用于调试) +' ======================================== +Public Function ToString() As String + Dim result As String + result = "【型号解析结果】" & vbCrLf + result = result & "原始型号: " & RawModel & vbCrLf + result = result & "表头型号: " & HeaderModel & vbCrLf + result = result & "表盘型号: " & DialModel & vbCrLf + result = result & vbCrLf + result = result & "【表头各部分】" & vbCrLf + result = result & " 型号: " & ModelType & vbCrLf + result = result & " 公称外径: " & Diameter & vbCrLf + result = result & " 安装形式: " & InstallForm & vbCrLf + result = result & " 壳体形式: " & ShellForm & vbCrLf + result = result & " 过程连接&材质: " & ConnectionCode & vbCrLf + result = result & " 量程范围: " & RangeCode & vbCrLf + result = result & " 仪表特性: " & Characteristics & vbCrLf + result = result & vbCrLf + result = result & "【提取代码】" & vbCrLf + result = result & " 螺纹代码: " & GetThreadCode() & vbCrLf + result = result & " 材质代码: " & GetMaterialCode() & vbCrLf + result = result & " 量程代码: " & GetRangeCode() & vbCrLf + + ToString = result +End Function +``` + +## Modules\modBOMProcessor.bas + +``` +' ======================================== +' 模块: modBOMTest +' 用途: 测试和使用BOM数据结构 +' ======================================== +Option Explicit + +Sub TestBOMStructure() + ' 初始化BOM管理器 + Dim bomMgr As New clsBOMManager + + ' 加载数据(假设工作表名称) + Dim wsConfig As Worksheet + Dim wsPlatform As Worksheet + + Set wsConfig = ThisWorkbook.Worksheets("领料配置") + Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单") + + ' 加载数据 + bomMgr.LoadData wsConfig, wsPlatform + + ' 打印类别树结构到新工作表 + Dim wsOutput As Worksheet + On Error Resume Next + Application.DisplayAlerts = False + ThisWorkbook.Worksheets("BOM结构").Delete + Application.DisplayAlerts = True + On Error GoTo 0 + + Set wsOutput = ThisWorkbook.Worksheets.Add + wsOutput.Name = "BOM结构" + + 'bomMgr.PrintCategoryTree wsOutput + + Dim cats As collection + Dim i As Integer + Set cats = bomMgr.GetRootCategories() + For i = 1 To cats.Count + Debug.Print cats(i).categoryName + Next i + + + + MsgBox "BOM数据结构加载完成!" & vbCrLf & _ + "请查看 'BOM结构' 工作表", vbInformation +End Sub + +' 示例: 获取特定类别的物料 +Sub GetCategoryMaterials() + Dim bomMgr As New clsBOMManager + Dim wsConfig As Worksheet, wsPlatform As Worksheet + + Set wsConfig = ThisWorkbook.Worksheets("领料配置") + Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单") + + bomMgr.LoadData wsConfig, wsPlatform + + ' 获取"部件"类别的物料(使用父类别) + Dim materials As collection + Set materials = bomMgr.GetMaterialsForPicking("部件", True) + + Debug.Print "部件类别物料数量(父类别): " & materials.Count + + ' 获取"部件"类别的物料(使用子类别) + Set materials = bomMgr.GetMaterialsForPicking("部件", False) + + Debug.Print "部件类别物料数量(子类别展开): " & materials.Count + + ' 遍历物料 + Dim mat As clsMaterialItem + For Each mat In materials + Debug.Print mat.code & " - " & mat.Name & _ + " | 数量:" & mat.Quantity & _ + " | 条件:" & mat.Condition + Next mat +End Sub + +' 示例: 根据产品型号生成领料清单 +Sub GeneratePickingList() + Dim bomMgr As New clsBOMManager + Dim wsConfig As Worksheet, wsPlatform As Worksheet + + Set wsConfig = ThisWorkbook.Worksheets("领料配置") + Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单") + + bomMgr.LoadData wsConfig, wsPlatform + + ' 创建领料清单工作表 + Dim wsPickList As Worksheet + On Error Resume Next + Application.DisplayAlerts = False + ThisWorkbook.Worksheets("领料清单").Delete + Application.DisplayAlerts = True + On Error GoTo 0 + + Set wsPickList = ThisWorkbook.Worksheets.Add + wsPickList.Name = "领料清单" + + ' 写入表头 + Dim row As Long + row = 1 + wsPickList.Cells(row, 1).value = "代号" + wsPickList.Cells(row, 2).value = "名称" + wsPickList.Cells(row, 3).value = "类别" + wsPickList.Cells(row, 4).value = "数量" + wsPickList.Cells(row, 5).value = "选择条件" + wsPickList.Cells(row, 6).value = "领料方式" + row = row + 1 + + ' 遍历所有根类别 + Dim rootCats As collection + Set rootCats = bomMgr.GetRootCategories + + Dim cat As clsCategory + Dim materials As collection + Dim mat As clsMaterialItem + Dim i As Long, j As Long + + For i = 1 To rootCats.Count + Set cat = rootCats(i) + ' 默认使用父类别物料 + Set materials = bomMgr.GetMaterialsForPicking(cat.categoryName, True) + + For j = 1 To materials.Count + Set mat = materials(j) + wsPickList.Cells(row, 1).value = mat.code + wsPickList.Cells(row, 2).value = mat.Name + wsPickList.Cells(row, 3).value = mat.Category + wsPickList.Cells(row, 4).value = mat.Quantity + wsPickList.Cells(row, 5).value = mat.Condition + wsPickList.Cells(row, 6).value = "父类别" + row = row + 1 + Next j + Next i + + ' 格式化表格 + wsPickList.Range("A1:F1").Font.Bold = True + wsPickList.Columns("A:F").AutoFit + + MsgBox "领料清单生成完成!", vbInformation +End Sub + +' 示例: 查询特定物料信息 +Sub QueryMaterialInfo() + Dim bomMgr As New clsBOMManager + Dim wsConfig As Worksheet, wsPlatform As Worksheet + + Set wsConfig = ThisWorkbook.Worksheets("领料配置") + Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单") + + bomMgr.LoadData wsConfig, wsPlatform + + ' 查询特定类别 + Dim cat As clsCategory + Set cat = bomMgr.GetCategory("部件") + + If Not cat Is Nothing Then + Debug.Print "类别: " & cat.categoryName + Debug.Print "父类别: " & cat.ParentCategoryName + Debug.Print "物料数: " & cat.materials.Count + Debug.Print "子类别数: " & cat.SubCategories.Count + Debug.Print "是否叶子类别: " & cat.IsLeafCategory + + ' 列出所有物料 + Dim mat As clsMaterialItem + Dim i As Long + For i = 1 To cat.materials.Count + Set mat = cat.materials(i) + Debug.Print " - " & mat.code & ": " & mat.Name + Next i + + ' 列出所有子类别 + Dim subCat As clsCategory + Dim j As Long + For j = 1 To cat.SubCategories.Count + Set subCat = cat.SubCategories(j) + Debug.Print " 子类别: " & subCat.categoryName & _ + " (物料数:" & subCat.materials.Count & ")" + Next j + End If +End Sub +``` + +## Modules\modModelParserExamples.bas + +``` +' ======================================== +' 模块: modModelParserExamples +' 用途: 型号解析与物料匹配的实际应用示例 +' ======================================== +Option Explicit + +' ======================================== +' 示例1: 根据型号生成完整的领料清单 +' ======================================== +Sub Example1_GeneratePickingListByModel() + Dim bomMgr As New clsBOMManager + Dim wsConfig As Worksheet + Dim wsPlatform As Worksheet + + ' 加载配置 + Set wsConfig = ThisWorkbook.Worksheets("领料配置") + Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单") + bomMgr.LoadData wsConfig, wsPlatform + + ' 产品型号 + Dim modelStr As String + modelStr = "YTHN-100.A0.532.M203.M16.Y3|BP-095.2312.M16.PA3" + + ' 创建领料清单工作表 + Dim wsPickList As Worksheet + On Error Resume Next + Application.DisplayAlerts = False + ThisWorkbook.Worksheets("型号领料清单").Delete + Application.DisplayAlerts = True + On Error GoTo 0 + + Set wsPickList = ThisWorkbook.Worksheets.Add + wsPickList.Name = "型号领料清单" + + ' 写入表头 + Dim row As Long + row = 1 + wsPickList.Cells(row, 1).value = "产品型号" + wsPickList.Cells(row, 2).value = modelStr + row = row + 1 + + ' 提取条件并显示 + Dim conditions As Object + Set conditions = bomMgr.ParseModelAndExtractConditions(modelStr) + wsPickList.Cells(row, 1).value = "提取条件" + Dim condStr As String + Dim key As Variant + For Each key In conditions.Keys + condStr = condStr & key & "=" & conditions(key) & "; " + Next key + wsPickList.Cells(row, 2).value = condStr + row = row + 2 + + ' 表头 + wsPickList.Cells(row, 1).value = "类别" + wsPickList.Cells(row, 2).value = "代号" + wsPickList.Cells(row, 3).value = "名称" + wsPickList.Cells(row, 4).value = "数量" + wsPickList.Cells(row, 5).value = "选择条件" + wsPickList.Cells(row, 6).value = "匹配状态" + wsPickList.Range("A" & row & ":F" & row).Font.Bold = True + row = row + 1 + + ' 遍历所有根类别 + Dim rootCats As collection + Set rootCats = bomMgr.GetRootCategories + + Dim cat As clsCategory + Dim materials As collection + Dim mat As clsMaterialItem + Dim i As Long + + For i = 1 To rootCats.Count + Set cat = rootCats(i) + + ' 获取该类别符合条件的物料 + Set materials = bomMgr.GetMaterialsByModel(modelStr, cat.categoryName) + + ' 写入物料 + Dim j As Long + For j = 1 To materials.Count + Set mat = materials(j) + ' 使用物料自己的Category属性，而不是外层循环的类别名称 + ' 这样当GetMaterialsByModel降级到子类别查找时，能正确显示子类别名称 + wsPickList.Cells(row, 1).value = mat.Category + wsPickList.Cells(row, 2).value = mat.code + wsPickList.Cells(row, 3).value = mat.Name + wsPickList.Cells(row, 4).value = mat.Quantity + wsPickList.Cells(row, 5).value = IIf(mat.Condition = "", "(无条件)", mat.Condition) + wsPickList.Cells(row, 6).value = "✓" + row = row + 1 + Next j + Next i + + ' 格式化 + wsPickList.Columns("A:F").AutoFit + + MsgBox "领料清单生成完成！" & vbCrLf & _ + "请查看工作表: 型号领料清单", vbInformation +End Sub + +' ======================================== +' 示例2: 批量处理多个型号 +' ======================================== +Sub Example2_BatchProcessModels() + Dim bomMgr As New clsBOMManager + Dim wsConfig As Worksheet + Dim wsPlatform As Worksheet + + ' 加载配置 + Set wsConfig = ThisWorkbook.Worksheets("领料配置") + Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单") + bomMgr.LoadData wsConfig, wsPlatform + + ' 型号列表 + Dim models() As String + models = Split("YTHN-100.A0.532.M203.M16.Y3|BP-095.2312.M16.PA3," & _ + "YTHN-100.A0.532.M203.M02.Y3|BP-095.2312.M02.PA3," & _ + "YTHN-100.A0.532.M203.M12.Y3|BP-095.2312.M12.PA3", ",") + + ' 创建汇总表 + Dim wsReport As Worksheet + On Error Resume Next + Application.DisplayAlerts = False + ThisWorkbook.Worksheets("批量型号汇总").Delete + Application.DisplayAlerts = True + On Error GoTo 0 + + Set wsReport = ThisWorkbook.Worksheets.Add + wsReport.Name = "批量型号汇总" + + ' 表头 + Dim row As Long + row = 1 + wsReport.Cells(row, 1).value = "型号" + wsReport.Cells(row, 2).value = "提取条件" + wsReport.Cells(row, 3).value = "匹配物料数" + wsReport.Cells(row, 4).value = "部件物料" + wsReport.Range("A1:D1").Font.Bold = True + row = row + 1 + + ' 处理每个型号 + Dim modelStr As String + Dim i As Long + + For i = LBound(models) To UBound(models) + modelStr = Trim(models(i)) + If modelStr <> "" Then + ' 提取条件 + Dim conditions As Object + Set conditions = bomMgr.ParseModelAndExtractConditions(modelStr) + + Dim condStr As String + condStr = "" + Dim key As Variant + For Each key In conditions.Keys + condStr = condStr & key & "=" & conditions(key) & "; " + Next key + + ' 获取物料 + Dim materials As collection + Set materials = bomMgr.GetMaterialsByModel(modelStr, "部件") + + ' 写入结果 + wsReport.Cells(row, 1).value = modelStr + wsReport.Cells(row, 2).value = condStr + wsReport.Cells(row, 3).value = materials.Count + + ' 列出部件物料 + Dim matList As String + matList = "" + Dim mat As clsMaterialItem + For Each mat In materials + matList = matList & mat.code & "(" & mat.Name & "); " + Next mat + wsReport.Cells(row, 4).value = matList + + row = row + 1 + End If + Next i + + ' 格式化 + wsReport.Columns("A:D").AutoFit + + MsgBox "批量处理完成！", vbInformation +End Sub + +' ======================================== +' 示例3: 查询并显示某个型号的详细信息 +' ======================================== +Sub Example3_ShowModelDetails() + ' 弹出输入框 + Dim modelStr As String + modelStr = InputBox("请输入产品型号:", "型号查询", _ + "YTHN-100.A0.532.M203.M16.Y3") + + If modelStr = "" Then Exit Sub + + ' 解析型号 + Dim parser As New clsModelParser + If Not parser.ParseModel(modelStr) Then + MsgBox "型号解析失败: " & parser.ErrorMessage, vbCritical + Exit Sub + End If + + ' 提取条件 + Dim extractor As New clsConditionExtractor + Dim conditions As Object + Set conditions = extractor.ExtractConditions(parser) + + ' 显示详细信息 + Dim msg As String + msg = "【型号解析结果】" & vbCrLf & vbCrLf + msg = msg & "原始型号: " & parser.RawModel & vbCrLf + msg = msg & "表头型号: " & parser.HeaderModel & vbCrLf + msg = msg & "表盘型号: " & parser.DialModel & vbCrLf & vbCrLf + + msg = msg & "【表头各部分】" & vbCrLf + msg = msg & "型号: " & parser.ModelType & vbCrLf + msg = msg & "公称外径: " & parser.Diameter & vbCrLf + msg = msg & "安装形式: " & parser.InstallForm & vbCrLf + msg = msg & "壳体形式: " & parser.ShellForm & vbCrLf + msg = msg & "过程连接&材质: " & parser.ConnectionCode & vbCrLf + msg = msg & "量程范围: " & parser.RangeCode & vbCrLf + msg = msg & "仪表特性: " & parser.Characteristics & vbCrLf & vbCrLf + + msg = msg & "【提取的物料选择条件】" & vbCrLf + Dim key As Variant + For Each key In conditions.Keys + msg = msg & key & " = " & conditions(key) & vbCrLf + Next key + + MsgBox msg, vbInformation, "型号详细信息" +End Sub + +' ======================================== +' 示例4: 对比两个型号的差异 +' ======================================== +Sub Example4_CompareModels() + Dim model1 As String, model2 As String + + model1 = InputBox("请输入第一个型号:", "型号对比", _ + "YTHN-100.A0.532.M203.M16.Y3") + If model1 = "" Then Exit Sub + + model2 = InputBox("请输入第二个型号:", "型号对比", _ + "YTHN-100.A0.532.M203.M02.Y3") + If model2 = "" Then Exit Sub + + ' 解析两个型号 + Dim parser1 As New clsModelParser + Dim parser2 As New clsModelParser + Dim extractor As New clsConditionExtractor + + parser1.ParseModel model1 + parser2.ParseModel model2 + + Dim cond1 As Object, cond2 As Object + Set cond1 = extractor.ExtractConditions(parser1) + + Set extractor = New clsConditionExtractor + Set cond2 = extractor.ExtractConditions(parser2) + + ' 对比 + Dim msg As String + msg = "【型号对比】" & vbCrLf & vbCrLf + msg = msg & "型号1: " & model1 & vbCrLf + msg = msg & "型号2: " & model2 & vbCrLf & vbCrLf + + msg = msg & "【条件差异】" & vbCrLf + Dim key As Variant + Dim allKeys As Object + Set allKeys = CreateObject("Scripting.Dictionary") + + For Each key In cond1.Keys + allKeys(key) = True + Next key + For Each key In cond2.Keys + allKeys(key) = True + Next key + + For Each key In allKeys.Keys + Dim val1 As String, val2 As String + val1 = "" + val2 = "" + + If cond1.Exists(key) Then val1 = cond1(key) + If cond2.Exists(key) Then val2 = cond2(key) + + If val1 <> val2 Then + msg = msg & key & ": " & val1 & " → " & val2 & " ?" & vbCrLf + Else + msg = msg & key & ": " & val1 & " ?" & vbCrLf + End If + Next key + + MsgBox msg, vbInformation, "型号对比结果" +End Sub + +' ======================================== +' 示例5: 验证物料选择条件的有效性 +' ======================================== +Sub Example5_ValidateMaterialConditions() + Dim bomMgr As New clsBOMManager + Dim wsConfig As Worksheet + Dim wsPlatform As Worksheet + + ' 加载配置 + Set wsConfig = ThisWorkbook.Worksheets("领料配置") + Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单") + bomMgr.LoadData wsConfig, wsPlatform + + ' 创建验证结果表 + Dim wsValidation As Worksheet + On Error Resume Next + Application.DisplayAlerts = False + ThisWorkbook.Worksheets("条件验证结果").Delete + Application.DisplayAlerts = True + On Error GoTo 0 + + Set wsValidation = ThisWorkbook.Worksheets.Add + wsValidation.Name = "条件验证结果" + + ' 表头 + Dim row As Long + row = 1 + wsValidation.Cells(row, 1).value = "代号" + wsValidation.Cells(row, 2).value = "名称" + wsValidation.Cells(row, 3).value = "选择条件" + wsValidation.Cells(row, 4).value = "验证结果" + wsValidation.Range("A1:D1").Font.Bold = True + row = row + 1 + + ' 获取所有根类别 + Dim rootCats As collection + Set rootCats = bomMgr.GetRootCategories + + Dim cat As clsCategory + Dim materials As collection + Dim mat As clsMaterialItem + Dim matcher As New clsConditionMatcher + Dim i As Long + + ' 遍历所有物料 + For i = 1 To rootCats.Count + Set cat = rootCats(i) + Set materials = New collection + + ' 收集该类别的所有物料 + Dim j As Long + For j = 1 To cat.materials.Count + materials.Add cat.materials(j) + Next j + + ' 验证每个物料的条件 + For Each mat In materials + wsValidation.Cells(row, 1).value = mat.code + wsValidation.Cells(row, 2).value = mat.Name + wsValidation.Cells(row, 3).value = IIf(mat.Condition = "", "(无)", mat.Condition) + + If mat.Condition = "" Then + wsValidation.Cells(row, 4).value = "? 无条件" + Else + Dim validResult As String + validResult = matcher.TestExpression(mat.Condition) + wsValidation.Cells(row, 4).value = validResult + End If + + row = row + 1 + Next mat + Next i + + ' 格式化 + wsValidation.Columns("A:D").AutoFit + + MsgBox "条件验证完成！", vbInformation +End Sub + +' ======================================== +' 示例6: 对比启用/禁用自动降级的效果 +' ======================================== +Sub Example6_CompareAutoFallback() + Dim bomMgr As New clsBOMManager + Dim wsConfig As Worksheet + Dim wsPlatform As Worksheet + + ' 加载配置 + Set wsConfig = ThisWorkbook.Worksheets("领料配置") + Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单") + bomMgr.LoadData wsConfig, wsPlatform + + ' 产品型号（使用可能导致类别缺失的型号） + Dim modelStr As String + modelStr = "YTHN-100.A0.532.M203.M17.Y3|BP-095.2312.M16.PA3" + + ' 创建对比结果表 + Dim wsCompare As Worksheet + On Error Resume Next + Application.DisplayAlerts = False + ThisWorkbook.Worksheets("降级模式对比").Delete + Application.DisplayAlerts = True + On Error GoTo 0 + + Set wsCompare = ThisWorkbook.Worksheets.Add + wsCompare.Name = "降级模式对比" + + ' 表头 + Dim row As Long + row = 1 + wsCompare.Cells(row, 1).value = "型号" + wsCompare.Cells(row, 2).value = modelStr + row = row + 2 + + ' 测试1: 启用自动降级 + wsCompare.Cells(row, 1).value = "模式1: 启用自动降级 (autoFallback=True)" + wsCompare.Cells(row, 1).Font.Bold = True + row = row + 1 + + wsCompare.Cells(row, 1).value = "类别" + wsCompare.Cells(row, 2).value = "代号" + wsCompare.Cells(row, 3).value = "名称" + wsCompare.Cells(row, 4).value = "数量" + wsCompare.Cells(row, 5).value = "选择条件" + wsCompare.Range("A" & row & ":E" & row).Font.Bold = True + row = row + 1 + + Dim materials As collection + Dim mat As clsMaterialItem + Dim i As Long + + ' 获取启用自动降级的物料 + Set materials = bomMgr.GetMaterialsByModel(modelStr, "部件", True) + + If materials.Count = 0 Then + wsCompare.Cells(row, 1).value = "(无物料)" + row = row + 1 + Else + For i = 1 To materials.Count + Set mat = materials(i) + wsCompare.Cells(row, 1).value = mat.Category + wsCompare.Cells(row, 2).value = mat.code + wsCompare.Cells(row, 3).value = mat.Name + wsCompare.Cells(row, 4).value = mat.Quantity + wsCompare.Cells(row, 5).value = IIf(mat.Condition = "", "(无)", mat.Condition) + row = row + 1 + Next i + End If + + row = row + 1 + + ' 测试2: 禁用自动降级 + wsCompare.Cells(row, 1).value = "模式2: 禁用自动降级 (autoFallback=False)" + wsCompare.Cells(row, 1).Font.Bold = True + row = row + 1 + + wsCompare.Cells(row, 1).value = "类别" + wsCompare.Cells(row, 2).value = "代号" + wsCompare.Cells(row, 3).value = "名称" + wsCompare.Cells(row, 4).value = "数量" + wsCompare.Cells(row, 5).value = "选择条件" + wsCompare.Range("A" & row & ":E" & row).Font.Bold = True + row = row + 1 + + ' 获取禁用自动降级的物料 + Set materials = bomMgr.GetMaterialsByModel(modelStr, "部件", False) + + If materials.Count = 0 Then + wsCompare.Cells(row, 1).value = "(无物料 - 因为禁用降级)" + wsCompare.Cells(row, 2).value = "说明" + wsCompare.Cells(row, 3).value = "当父类别无匹配物料时,不会降级到子类别查找" + row = row + 1 + Else + For i = 1 To materials.Count + Set mat = materials(i) + wsCompare.Cells(row, 1).value = mat.Category + wsCompare.Cells(row, 2).value = mat.code + wsCompare.Cells(row, 3).value = mat.Name + wsCompare.Cells(row, 4).value = mat.Quantity + wsCompare.Cells(row, 5).value = IIf(mat.Condition = "", "(无)", mat.Condition) + row = row + 1 + Next i + End If + + ' 添加说明 + row = row + 1 + wsCompare.Cells(row, 1).value = "说明:" + wsCompare.Cells(row, 1).Font.Bold = True + row = row + 1 + wsCompare.Cells(row, 1).value = "• autoFallback=True (默认): 当""部件""类别无匹配物料时,自动降级到子类别""接头""、""弹性元件""等查找" + row = row + 1 + wsCompare.Cells(row, 1).value = "• autoFallback=False: 仅在""部件""类别查找,即使有子类别也不降级,可能返回空集合" + + ' 格式化 + wsCompare.Columns("A:E").AutoFit + wsCompare.Range("A1").Font.Bold = True + + MsgBox "降级模式对比完成！" & vbCrLf & _ + "请查看工作表: 降级模式对比" & vbCrLf & vbCrLf & _ + "启用降级: " & bomMgr.GetMaterialsByModel(modelStr, "部件", True).Count & " 个物料" & vbCrLf & _ + "禁用降级: " & bomMgr.GetMaterialsByModel(modelStr, "部件", False).Count & " 个物料", _ + vbInformation +End Sub + +' ======================================== +' 示例7: 测试GetValidMaterialsByModel方法 +' ======================================== +Sub Example7_TestGetValidMaterialsByModel() + Dim bomMgr As New clsBOMManager + Dim wsConfig As Worksheet + Dim wsPlatform As Worksheet + + ' 加载配置 + Set wsConfig = ThisWorkbook.Worksheets("领料配置") + Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单") + bomMgr.LoadData wsConfig, wsPlatform + + ' 创建测试结果工作表 + Dim wsTest As Worksheet + On Error Resume Next + Application.DisplayAlerts = False + ThisWorkbook.Worksheets("物料完整性测试").Delete + Application.DisplayAlerts = True + On Error GoTo 0 + + Set wsTest = ThisWorkbook.Worksheets.Add + wsTest.Name = "物料完整性测试" + + ' 写入标题 + Dim row As Long + row = 1 + wsTest.Cells(row, 1).value = "物料完整性测试报告" + wsTest.Cells(row, 1).Font.Bold = True + wsTest.Cells(row, 1).Font.Size = 14 + row = row + 2 + + ' 测试多个型号 + Dim testModels() As Variant + testModels = Array( _ + Array("YTHN-100.A0.532.M203.M16.Y3|BP-095.2312.M16.PA3", "完整型号测试1"), _ + Array("YTHN-100.A0.532.M203.M02.Y3|BP-095.2312.M02.PA3", "完整型号测试2"), _ + Array("YTHN-100.A0.532.M203.M12.Y3|BP-095.2312.M12.PA3", "完整型号测试3"), _ + Array("YTHN-100.A0.532.M203.M17.Y3", "可能不完整的型号") _ + ) + + Dim i As Long + For i = LBound(testModels) To UBound(testModels) + Dim modelStr As String + Dim testName As String + modelStr = testModels(i)(0) + testName = testModels(i)(1) + + ' 调用GetValidMaterialsByModel + Dim result As collection + Set result = bomMgr.GetValidMaterialsByModel(modelStr) + + Dim materials As collection + Dim isComplete As Boolean + Set materials = result("Materials") + isComplete = result("IsComplete") + + ' 写入测试名称和型号 + wsTest.Cells(row, 1).value = "测试 " & (i + 1) & ": " & testName + wsTest.Cells(row, 1).Font.Bold = True + row = row + 1 + + wsTest.Cells(row, 1).value = "型号:" + wsTest.Cells(row, 2).value = modelStr + row = row + 1 + + wsTest.Cells(row, 1).value = "完整性:" + wsTest.Cells(row, 2).value = IIf(isComplete, "?? 完整", "?? 不完整") + If isComplete Then + wsTest.Cells(row, 2).Font.Color = RGB(0, 128, 0) ' 绿色 + Else + wsTest.Cells(row, 2).Font.Color = RGB(255, 0, 0) ' 红色 + End If + wsTest.Cells(row, 2).Font.Bold = True + row = row + 1 + + wsTest.Cells(row, 1).value = "物料数量:" + wsTest.Cells(row, 2).value = materials.count + row = row + 1 + + ' 写入物料明细表头 + wsTest.Cells(row, 1).value = "类别" + wsTest.Cells(row, 2).value = "代号" + wsTest.Cells(row, 3).value = "名称" + wsTest.Cells(row, 4).value = "数量" + wsTest.Cells(row, 5).value = "选择条件" + wsTest.Range(wsTest.Cells(row, 1), wsTest.Cells(row, 5)).Font.Bold = True + wsTest.Range(wsTest.Cells(row, 1), wsTest.Cells(row, 5)).Interior.Color = RGB(200, 200, 200) + row = row + 1 + + ' 写入每个物料 + Dim mat As clsMaterialItem + Dim j As Long + For j = 1 To materials.count + Set mat = materials(j) + wsTest.Cells(row, 1).value = mat.Category + wsTest.Cells(row, 2).value = mat.code + wsTest.Cells(row, 3).value = mat.Name + wsTest.Cells(row, 4).value = mat.Quantity + wsTest.Cells(row, 5).value = IIf(mat.Condition = "", "(无条件)", mat.Condition) + row = row + 1 + Next j + + ' 添加分隔行 + row = row + 1 + wsTest.Cells(row, 1).value = String(80, "-") + row = row + 2 + Next i + + ' 添加统计汇总 + wsTest.Cells(row, 1).value = "测试汇总" + wsTest.Cells(row, 1).Font.Bold = True + wsTest.Cells(row, 1).Font.Size = 12 + row = row + 1 + + Dim completeCount As Long + Dim incompleteCount As Long + completeCount = 0 + incompleteCount = 0 + + For i = LBound(testModels) To UBound(testModels) + modelStr = testModels(i)(0) + Set result = bomMgr.GetValidMaterialsByModel(modelStr) + If result("IsComplete") Then + completeCount = completeCount + 1 + Else + incompleteCount = incompleteCount + 1 + End If + Next i + + wsTest.Cells(row, 1).value = "总测试数:" + wsTest.Cells(row, 2).value = UBound(testModels) - LBound(testModels) + 1 + row = row + 1 + + wsTest.Cells(row, 1).value = "完整:" + wsTest.Cells(row, 2).value = completeCount + wsTest.Cells(row, 2).Font.Color = RGB(0, 128, 0) + row = row + 1 + + wsTest.Cells(row, 1).value = "不完整:" + wsTest.Cells(row, 2).value = incompleteCount + wsTest.Cells(row, 2).Font.Color = RGB(255, 0, 0) + + ' 格式化 + wsTest.Columns("A:E").AutoFit + + MsgBox "物料完整性测试完成！" & vbCrLf & _ + "完整: " & completeCount & " 个" & vbCrLf & _ + "不完整: " & incompleteCount & " 个" & vbCrLf & vbCrLf & _ + "请查看工作表: 物料完整性测试", vbInformation +End Sub +``` + +## Modules\modModelParserTest.bas + +``` +' ======================================== +' 模块: modModelParserTest +' 用途: 测试型号解析和物料匹配功能 +' ======================================== +Option Explicit + +' ======================================== +' 测试1: 型号解析器基础功能 +' ======================================== +Sub Test1_ModelParser() + Debug.Print String(80, "=") + Debug.Print "测试1: 型号解析器基础功能" + Debug.Print String(80, "=") + + Dim parser As New clsModelParser + Dim modelStr As String + + ' 测试用例1: 完整型号 + modelStr = "YTHN-100.A0.532.M203.M16.Y3|BP-095.2312.M16.PA3" + Debug.Print "【测试用例1】完整型号" + Debug.Print "输入: " & modelStr + + If parser.ParseModel(modelStr) Then + Debug.Print parser.ToString() + Debug.Print "? 解析成功" + Else + Debug.Print "? 解析失败: " & parser.ErrorMessage + End If + + Debug.Print "" + + ' 测试用例2: 仅表头 + modelStr = "YTHN-100.A0.532.M203.M16.Y3" + Debug.Print "【测试用例2】仅表头" + Debug.Print "输入: " & modelStr + + If parser.ParseModel(modelStr) Then + Debug.Print " 螺纹代码: " & parser.GetThreadCode() + Debug.Print " 材质代码: " & parser.GetMaterialCode() + Debug.Print " 量程代码: " & parser.GetRangeCode() + Debug.Print "? 解析成功" + Else + Debug.Print "? 解析失败: " & parser.ErrorMessage + End If + + Debug.Print String(80, "=") + Debug.Print "" +End Sub + +' ======================================== +' 测试2: 条件提取器 +' ======================================== +Sub Test2_ConditionExtractor() + Debug.Print String(80, "=") + Debug.Print "测试2: 条件提取器" + Debug.Print String(80, "=") + + Dim parser As New clsModelParser + Dim extractor As New clsConditionExtractor + Dim modelStr As String + + modelStr = "YTHN-100.A0.532.M203.M16.Y3" + Debug.Print "输入型号: " & modelStr + + If parser.ParseModel(modelStr) Then + Dim conditions As Object + Set conditions = extractor.ExtractConditions(parser) + + Debug.Print extractor.ToString() + + ' 验证提取结果 + Debug.Print "【验证】" + Debug.Print " gclj = " & extractor.GetConditionValue("gclj") & _ + IIf(extractor.GetConditionValue("gclj") = "M20", " ?", " ?") + Debug.Print " jycz = " & extractor.GetConditionValue("jycz") & _ + IIf(extractor.GetConditionValue("jycz") = "3", " ?", " ?") + Debug.Print " lcfw = " & extractor.GetConditionValue("lcfw") & _ + IIf(extractor.GetConditionValue("lcfw") = "M16", " ?", " ?") + Else + Debug.Print "? 型号解析失败" + End If + + Debug.Print String(80, "=") + Debug.Print "" +End Sub + +' ======================================== +' 测试3: 条件匹配器 +' ======================================== +Sub Test3_ConditionMatcher() + Debug.Print String(80, "=") + Debug.Print "测试3: 条件匹配器" + Debug.Print String(80, "=") + + Dim matcher As New clsConditionMatcher + Dim conditions As Object + Set conditions = CreateObject("Scripting.Dictionary") + conditions("gclj") = "M20" + conditions("jycz") = "3" + conditions("lcfw") = "M16" + + Debug.Print "【测试条件】" + Debug.Print " gclj = M20" + Debug.Print " jycz = 3" + Debug.Print " lcfw = M16" + Debug.Print "" + + ' 测试用例 + Dim testCases As Variant + testCases = Array( _ + Array("", True, "空条件"), _ + Array("lcfw=M16", True, "简单等于"), _ + Array("lcfw=M17", False, "简单不匹配"), _ + Array("lcfw=M16 AND gclj=M20", True, "AND 全真"), _ + Array("lcfw=M16 AND gclj=M10", False, "AND 一假"), _ + Array("lcfw=M16 OR lcfw=M17", True, "OR 一真"), _ + Array("lcfw=M15 OR lcfw=M17", False, "OR 全假"), _ + Array("gclj!=M10", True, "不等于 真"), _ + Array("gclj!=M20", False, "不等于 假"), _ + Array("lcfw=M02 AND gclj!=M20", False, "复合条件1"), _ + Array("lcfw=M16 AND gclj!=M10", True, "复合条件2"), _ + Array("gclj=M20 AND (lcfw=M16 OR lcfw=M17)", True, "括号优先级1"), _ + Array("gclj=M20 AND (lcfw=M15 OR lcfw=M17)", False, "括号优先级2") _ + ) + + Dim i As Long + Dim testCase As Variant + Dim expr As String + Dim expected As Boolean + Dim actual As Boolean + Dim description As String + Dim passCount As Long + Dim failCount As Long + + passCount = 0 + failCount = 0 + + Debug.Print "【测试用例】" + For i = LBound(testCases) To UBound(testCases) + testCase = testCases(i) + expr = testCase(0) + expected = testCase(1) + description = testCase(2) + + actual = matcher.IsMatch(expr, conditions) + + If actual = expected Then + Debug.Print " ? " & description & ": " & IIf(expr = "", "(空)", expr) + passCount = passCount + 1 + Else + Debug.Print " ? " & description & ": " & expr + Debug.Print " 预期: " & expected & ", 实际: " & actual + failCount = failCount + 1 + End If + Next i + + Debug.Print "" + Debug.Print "【统计】" + Debug.Print " 通过: " & passCount + Debug.Print " 失败: " & failCount + + Debug.Print String(80, "=") + Debug.Print "" +End Sub + +' ======================================== +' 测试4: 完整流程 - 根据型号获取物料 +' ======================================== +Sub Test4_GetMaterialsByModel() + Debug.Print String(80, "=") + Debug.Print "测试4: 根据型号获取物料（完整流程）" + Debug.Print String(80, "=") + + ' 加载BOM数据 + Dim bomMgr As New clsBOMManager + Dim wsConfig As Worksheet + Dim wsPlatform As Worksheet + + On Error Resume Next + Set wsConfig = ThisWorkbook.Worksheets("领料配置") + Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单") + On Error GoTo 0 + + If wsConfig Is Nothing Or wsPlatform Is Nothing Then + Debug.Print "? 错误: 找不到必需的工作表" + Exit Sub + End If + + bomMgr.LoadData wsConfig, wsPlatform + Debug.Print "? BOM数据加载完成" + Debug.Print "" + + ' 测试型号 + Dim modelStr As String + modelStr = "YTHN-100.A0.532.M203.M16.Y3|BP-095.2312.M16.PA3" + + ' 获取"部件"类别的符合条件的物料 + Dim materials As collection + Set materials = bomMgr.GetMaterialsByModel(modelStr, "部件") + + Debug.Print "" + Debug.Print "【结果验证】" + If materials.Count = 1 Then + Dim mat As clsMaterialItem + Set mat = materials(1) + If mat.code = "01011019018" And mat.Name = "高压接头部件" Then + Debug.Print "? 测试通过！成功匹配到正确的物料" + Debug.Print " 代号: " & mat.code + Debug.Print " 名称: " & mat.Name + Debug.Print " 条件: " & mat.Condition + Else + Debug.Print "? 匹配到的物料不正确" + End If + Else + Debug.Print "? 匹配数量不正确，预期1个，实际" & materials.Count & "个" + End If + + Debug.Print String(80, "=") + Debug.Print "" +End Sub + +' ======================================== +' 测试5: 获取所有类别的符合条件的物料 +' ======================================== +Sub Test5_GetAllMaterialsByModel() + Debug.Print String(80, "=") + Debug.Print "测试5: 获取所有类别的符合条件的物料" + Debug.Print String(80, "=") + + ' 加载BOM数据 + Dim bomMgr As New clsBOMManager + Dim wsConfig As Worksheet + Dim wsPlatform As Worksheet + + On Error Resume Next + Set wsConfig = ThisWorkbook.Worksheets("领料配置") + Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单") + On Error GoTo 0 + + If wsConfig Is Nothing Or wsPlatform Is Nothing Then + Debug.Print "? 错误: 找不到必需的工作表" + Exit Sub + End If + + bomMgr.LoadData wsConfig, wsPlatform + + ' 测试型号 + Dim modelStr As String + modelStr = "YTHN-100.A0.532.M203.M16.Y3" + + ' 获取所有类别的符合条件的物料 + Dim materials As collection + Set materials = bomMgr.GetMaterialsByModel(modelStr) + + Debug.Print "" + Debug.Print "【匹配结果汇总】" + Debug.Print " 共匹配 " & materials.Count & " 个物料" + + Debug.Print String(80, "=") + Debug.Print "" +End Sub + +' ======================================== +' 运行所有测试 +' ======================================== +Sub RunAllTests() + Debug.Print vbCrLf & vbCrLf + Debug.Print "╔" & String(78, "═") & "╗" + Debug.Print "║" & Space(20) & "型号解析与物料匹配 - 完整测试套件" & Space(20) & "║" + Debug.Print "╚" & String(78, "═") & "╝" + Debug.Print "" + + Test1_ModelParser + Test2_ConditionExtractor + Test3_ConditionMatcher + Test4_GetMaterialsByModel + Test5_GetAllMaterialsByModel + + Debug.Print "╔" & String(78, "═") & "╗" + Debug.Print "║" & Space(30) & "所有测试完成" & Space(30) & "║" + Debug.Print "╚" & String(78, "═") & "╝" +End Sub + +' ======================================== +' 测试6: 条件提取规则展示 +' ======================================== +Sub Test6_ShowExtractionRules() + Debug.Print String(80, "=") + Debug.Print "测试6: 当前配置的条件提取规则" + Debug.Print String(80, "=") + + Dim extractor As New clsConditionExtractor + Dim rules As Object + Set rules = extractor.GetExtractionRules() + + Debug.Print "【提取规则配置】" + Dim key As Variant + For Each key In rules.Keys + Dim ruleInfo As Variant + ruleInfo = rules(key) + Debug.Print " 变量名: " & key + Debug.Print " 源字段: " & ruleInfo(0) + Debug.Print " 提取方法: " & ruleInfo(1) + Debug.Print "" + Next key + + Debug.Print String(80, "=") + Debug.Print "" +End Sub +```