admin/AutoBOM
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

clear

Browse Source
This commit is contained in:
Misaka_Company
2026-01-29 17:05:28 +08:00
parent c9cf84ed4d
commit 2b9ba2de9c
19 changed files with 0 additions and 9531 deletions
Download Patch File Download Diff File Expand all files Collapse all files

178
VBA/Modules/modBOMProcessor.bas
View File

@@ -1,178 +0,0 @@
' ========================================
' 模块: modBOMProcessor
' 用途: BOM处理和操作示例
' ⭐ v2.0 更新：所有过程使用新的 LoadData(wsPlatform) 接口
' ========================================
Option Explicit
Sub TestBOMStructure()
' 初始化BOM管理器
Dim bomMgr As New clsBOMManager
' 加载数据
Dim wsPlatform As Worksheet
Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单")
' ⭐ 使用新接口
bomMgr.LoadData 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 wsPlatform As Worksheet
Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单")
' ⭐ 使用新接口
bomMgr.LoadData 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 wsPlatform As Worksheet
Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单")
' ⭐ 使用新接口
bomMgr.LoadData 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 wsPlatform As Worksheet
Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单")
' ⭐ 使用新接口
bomMgr.LoadData 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

986
VBA/Modules/modModelParserExamples.bas
View File

@@ -1,986 +0,0 @@
' ========================================
' 模块: modModelParserExamples
' 用途: 型号解析与物料匹配的实际应用示例
' ========================================
Option Explicit
' ========================================
' 示例1: 根据型号生成完整的领料清单
' ⭐ v2.0 更新：使用新的 LoadData(wsPlatform) 接口
' ========================================
Sub Example1_GeneratePickingListByModel()
Dim bomMgr As New clsBOMManager
Dim wsPlatform As Worksheet
' 加载配置
Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单")
bomMgr.LoadData 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: 批量处理多个型号
' ⭐ v2.0 更新：使用新的 LoadData(wsPlatform) 接口
' ========================================
Sub Example2_BatchProcessModels()
Dim bomMgr As New clsBOMManager
Dim wsPlatform As Worksheet
' 加载配置
Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单")
bomMgr.LoadData 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: 验证物料选择条件的有效性
' ⭐ v2.0 更新：使用新的 LoadData(wsPlatform) 接口
' ========================================
Sub Example5_ValidateMaterialConditions()
Dim bomMgr As New clsBOMManager
Dim wsPlatform As Worksheet
' 加载配置
Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单")
bomMgr.LoadData 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: 对比启用/禁用自动降级的效果
' ⭐ v2.0 更新：使用新的 LoadData(wsPlatform) 接口
' ========================================
Sub Example6_CompareAutoFallback()
Dim bomMgr As New clsBOMManager
Dim wsPlatform As Worksheet
' 加载配置
Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单")
bomMgr.LoadData 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方法 (使用内置的缺失列表)
' ⭐ v2.0 更新：使用新的 LoadData(wsPlatform) 接口
' 完整性检查使用"类别选用条件"动态判断需要的类别
' ========================================
Sub Example7_TestGetValidMaterialsByModel()
Dim bomMgr As New clsBOMManager
Dim wsPlatform As Worksheet
' 加载配置
Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单")
bomMgr.LoadData 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.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)
' 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 = "型号:"
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
' 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.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
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
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
wsTest.Cells(row, 1).value = String(80, "-")
row = row + 2
Next i
wsTest.Columns("A:D").AutoFit
MsgBox "测试完成！", vbInformation
End Sub
' ========================================
' 示例8: 批量处理产品订单，生成物料清单
' ⭐ v2.0 更新：使用新的 LoadData(wsPlatform) 接口
' ========================================
Sub Example8_BatchProcessOrders()
Dim bomMgr As New clsBOMManager
Dim wsPlatform As Worksheet
Dim wsOrders As Worksheet
Dim wsOutput As Worksheet
' 加载配置
On Error Resume Next
Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单")
Set wsOrders = ThisWorkbook.Worksheets("产品订单")
If wsPlatform Is Nothing Then
MsgBox "找不到工作表: 平台配置清单", vbCritical
Exit Sub
End If
If wsOrders Is Nothing Then
MsgBox "找不到工作表: 产品订单", vbCritical
Exit Sub
End If
On Error GoTo 0
bomMgr.LoadData wsPlatform
' 读取订单数据
Dim lastRow As Long
lastRow = wsOrders.Cells(wsOrders.Rows.Count, "A").End(xlUp).row
If lastRow < 2 Then
MsgBox "产品订单工作表没有数据！" & vbCrLf & _
"请确保第一行是表头，从第二行开始是数据。", vbExclamation
Exit Sub
End If
' 使用 Collection 收集所有输出行
Dim outputData As collection
Set outputData = New collection
' 添加表头
outputData.Add Array("来源单号", "产品型号", "物料代码", "物料名称", "数量", "选择条件", "类别")
' 遍历每个订单，收集数据
Dim i As Long
Dim orderNo As String
Dim modelStr As String
Dim materials As collection
Dim mat As clsMaterialItem
Dim processedCount As Long
Dim materialCount As Long
processedCount = 0
materialCount = 0
For i = 2 To lastRow
orderNo = Trim(wsOrders.Cells(i, 1).value)
modelStr = Trim(wsOrders.Cells(i, 2).value)
' 跳过空行
If orderNo = "" And modelStr = "" Then
GoTo ContinueLoop
End If
' 验证必填字段
If orderNo = "" Then
orderNo = "(未填写)"
End If
If modelStr = "" Then
outputData.Add Array(orderNo, "(空白型号)", "错误", "产品型号为空", "", "", "")
GoTo ContinueLoop
End If
' 获取物料
On Error Resume Next
Set materials = bomMgr.GetMaterialsByModel(modelStr, "", True)
On Error GoTo 0
If materials Is Nothing Then
outputData.Add Array(orderNo, modelStr, "错误", "无法解析型号或获取物料", "", "", "")
GoTo ContinueLoop
End If
' 收集物料明细
If materials.Count > 0 Then
For Each mat In materials
outputData.Add Array( _
orderNo, _
modelStr, _
mat.code, _
mat.Name, _
mat.Quantity, _
IIf(mat.Condition = "", "(无条件)", mat.Condition), _
mat.Category _
)
materialCount = materialCount + 1
Next mat
Else
outputData.Add Array(orderNo, modelStr, "(无)", "未找到任何匹配物料", "", "", "")
End If
processedCount = processedCount + 1
ContinueLoop:
Next i
' 创建输出工作表
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("产品订单物料清单").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set wsOutput = ThisWorkbook.Worksheets.Add
wsOutput.Name = "产品订单物料清单"
' 批量写入数据到工作表
If outputData.Count > 0 Then
Dim dataArray() As Variant
ReDim dataArray(1 To outputData.Count, 1 To 7)
Dim j As Long
Dim rowArr As Variant
For j = 1 To outputData.Count
rowArr = outputData(j)
dataArray(j, 1) = rowArr(0)
dataArray(j, 2) = rowArr(1)
dataArray(j, 3) = rowArr(2) ' 这里是物料代码
dataArray(j, 4) = rowArr(3)
dataArray(j, 5) = rowArr(4)
dataArray(j, 6) = rowArr(5)
dataArray(j, 7) = rowArr(6)
Next j
' --- 关键修改：在写入数据前，将 C 列设置为文本格式 ---
' 使用 NumberFormat = "@" 强制指定为文本格式
wsOutput.Columns("C").NumberFormat = "@"
' 一次性写入
wsOutput.Range("A1").Resize(outputData.Count, 7).value = dataArray
' 格式化表头
With wsOutput.Range("A1:G1")
.Font.Bold = True
.Interior.Color = RGB(200, 200, 200)
' 表头所在的 C1 单元格通常可以改回常规格式，或者保持文本格式也不影响
.NumberFormat = "General"
End With
End If
' 格式化
wsOutput.Columns("A:G").AutoFit
' 显示统计信息
Dim msg As String
msg = "批量处理完成！" & vbCrLf & vbCrLf
msg = msg & "处理订单数: " & processedCount & vbCrLf
msg = msg & "生成物料记录: " & materialCount & " 条" & vbCrLf & vbCrLf
msg = msg & "请查看工作表: 产品订单物料清单"
MsgBox msg, vbInformation
End Sub
' ========================================
' 示例9: 批量处理订单 - 带完整性检查与模块数量校验
' 功能：
' 1. 提取型号条件
' 2. 校验模块数量（如果是3个模块则报错）
' 3. 校验类别完整性（如果缺失类别则报错，使用类别选用条件判断）
' 4. 生成BOM清单
'
' ⭐ v2.0 更新：
' - 移除 [领料配置] 表依赖
' - 使用新的 LoadData(wsPlatform) 接口（单参数）
' - 完整性检查使用"类别选用条件"动态判断需要的类别
' ========================================
Sub Example9_BatchProcessOrders_WithCheck()
Dim bomMgr As New clsBOMManager
Dim wsPlatform As Worksheet, wsOrders As Worksheet, wsOutput As Worksheet
Dim parser As clsModelParser
Dim extractor As clsConditionExtractor
' 1. 初始化与加载数据
On Error Resume Next
Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单")
Set wsOrders = ThisWorkbook.Worksheets("产品订单")
On Error GoTo 0
If wsPlatform Is Nothing Or wsOrders Is Nothing Then
MsgBox "错误：缺少必要的工作表 (平台配置清单/产品订单)", vbCritical
Exit Sub
End If
' ⭐ 使用新接口：只需要一个参数
bomMgr.LoadData wsPlatform
' 2. 准备输出容器
Dim outputData As collection
Set outputData = New collection
' 添加表头
outputData.Add Array("来源单号", "产品型号", "物料代码", "物料名称", "数量", "选择条件", "提取的物料选择条件", "类别", "备注")
' 3. 遍历订单
Dim lastRow As Long
lastRow = wsOrders.Cells(wsOrders.Rows.Count, "A").End(xlUp).row
Dim i As Long
Dim orderNo As String, modelStr As String
Dim extractedCondStr As String
Dim parts() As String
Dim moduleCount As Integer
Dim result As collection, materials As collection, missingCats As collection
Dim isComplete As Boolean
Dim mat As clsMaterialItem
' 辅助变量
Dim key As Variant
Dim missingStr As String
Dim catItem As Variant
For i = 2 To lastRow
orderNo = Trim(wsOrders.Cells(i, 1).value)
modelStr = Trim(wsOrders.Cells(i, 2).value)
If orderNo = "" And modelStr = "" Then GoTo NextOrder
If orderNo = "" Then orderNo = "(未填写)"
' -------------------------------------------------
' 步骤 A: 解析型号并提取条件字符串 (用于输出列)
' -------------------------------------------------
extractedCondStr = ""
Set parser = New clsModelParser
Set extractor = New clsConditionExtractor
If parser.ParseModel(modelStr) Then
Dim conditions As Object
Set conditions = extractor.ExtractConditions(parser)
For Each key In conditions.Keys
extractedCondStr = extractedCondStr & key & "=" & conditions(key) & "; "
Next key
If Len(extractedCondStr) > 2 Then extractedCondStr = Left(extractedCondStr, Len(extractedCondStr) - 2)
Else
' 解析失败直接输出错误
outputData.Add Array(orderNo, modelStr, "", "", "", "", "", "", "解析失败: " & parser.ErrorMessage)
GoTo NextOrder
End If
' -------------------------------------------------
' 步骤 B: 校验模块数量 (表头 | 表盘 | 附件 | 法兰)
' -------------------------------------------------
' Split返回0-based数组。0=1个模块, 1=2个模块, 2=3个模块
parts = Split(modelStr, "|")
moduleCount = UBound(parts) + 1
' 规则：如果出现三个模块，不输出物料，备注填入原因
If moduleCount = 3 Then
outputData.Add Array(orderNo, modelStr, "", "", "", "", extractedCondStr, "", "包含其它模块")
GoTo NextOrder
End If
' -------------------------------------------------
' 步骤 C: 获取物料并校验类别完整性
' -------------------------------------------------
Set result = bomMgr.GetValidMaterialsByModel(modelStr)
isComplete = result("IsComplete")
Set materials = result("Materials")
Set missingCats = result("MissingCategories")
' 规则：如果类别缺失，不输出物料，备注填入缺失的类别
If Not isComplete Then
missingStr = ""
For Each catItem In missingCats
missingStr = missingStr & catItem & ", "
Next catItem
If Len(missingStr) > 2 Then missingStr = Left(missingStr, Len(missingStr) - 2)
If missingStr = "" Then missingStr = "完整性校验未通过(未知原因)" ' 防御性编程
outputData.Add Array(orderNo, modelStr, "", "", "", "", extractedCondStr, "", "类别缺失: " & missingStr)
GoTo NextOrder
End If
' -------------------------------------------------
' 步骤 D: 正常输出物料
' -------------------------------------------------
If materials.Count > 0 Then
For Each mat In materials
outputData.Add Array( _
orderNo, _
modelStr, _
mat.code, _
mat.Name, _
mat.Quantity, _
IIf(mat.Condition = "", "(无条件)", mat.Condition), _
extractedCondStr, _
mat.Category, _
"" _
)
Next mat
Else
outputData.Add Array(orderNo, modelStr, "", "", "", "", extractedCondStr, "", "无匹配物料")
End If
NextOrder:
Next i
' 4. 写入结果到新工作表
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_校验版"
If outputData.Count > 0 Then
' 转换为二维数组以提高写入速度
Dim dataArr() As Variant
ReDim dataArr(1 To outputData.Count, 1 To 9)
Dim r As Long, c As Long
Dim rowItem As Variant
For r = 1 To outputData.Count
rowItem = outputData(r)
For c = 0 To 8
dataArr(r, c + 1) = rowItem(c)
Next c
Next r
' 设置物料代码列(C列)为文本格式
wsOutput.Columns("C:C").NumberFormat = "@"
' 写入数据
wsOutput.Range("A1").Resize(outputData.Count, 9).value = dataArr
' 格式化美化
With wsOutput.Range("A1:I1")
.Font.Bold = True
.Interior.Color = RGB(220, 230, 241)
.HorizontalAlignment = xlCenter
End With
wsOutput.Columns("A:I").AutoFit
' 备注列标红显示
wsOutput.Columns("I:I").Font.Color = RGB(255, 0, 0)
wsOutput.Cells(1, 9).Font.Color = RGB(0, 0, 0) ' 表头改回黑色
End If
MsgBox "处理完成！请查看工作表 '订单BOM_校验版'。", vbInformation
End Sub

307
VBA/Modules/modModelParserTest.bas
View File

@@ -1,307 +0,0 @@
' ========================================
' 模块: 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 wsPlatform As Worksheet
On Error Resume Next
Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单")
On Error GoTo 0
If wsPlatform Is Nothing Then
Debug.Print "? 错误: 找不到必需的工作表 [平台配置清单]"
Exit Sub
End If
' ⭐ 使用新接口
bomMgr.LoadData 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 wsPlatform As Worksheet
On Error Resume Next
Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单")
On Error GoTo 0
If wsPlatform Is Nothing Then
Debug.Print "? 错误: 找不到必需的工作表 [平台配置清单]"
Exit Sub
End If
' ⭐ 使用新接口
bomMgr.LoadData 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