' ======================================== ' 模块: 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