a22ee42119
- Remove "作者: Auto-generated" and date fields from module headers - Clean up unnecessary metadata comments Co-Authored-By: Claude Sonnet 4.5 <noreply@anthropic.com>
482 lines
18 KiB
OpenEdge ABL
482 lines
18 KiB
OpenEdge ABL
'=====================================================================
|
||
' 类名: BomExtractor
|
||
' 功能: BOM提取器,从平台配置清单中提取匹配的物料
|
||
'=====================================================================
|
||
|
||
Option Explicit
|
||
|
||
Private pWorksheet As Worksheet
|
||
Private pConditionEvaluator As ConditionEvaluator
|
||
Private pAllItems As collection ' 所有BOM项
|
||
Private pMatchedItems As collection ' 匹配的BOM项
|
||
Private pRequiredCategories As collection ' 需要的类别
|
||
Private pCategoryHierarchy As Object ' 类别层次结构 Dictionary(子类别->父类别)
|
||
Private pErrorMessages As collection
|
||
Private pExcludeCategories As collection ' 需要排除的类别
|
||
|
||
'=====================================================================
|
||
' 方法: Class_Initialize
|
||
' 功能: 初始化类
|
||
'=====================================================================
|
||
Private Sub Class_Initialize()
|
||
Set pConditionEvaluator = New ConditionEvaluator
|
||
Set pAllItems = New collection
|
||
Set pMatchedItems = New collection
|
||
Set pRequiredCategories = New collection
|
||
Set pCategoryHierarchy = CreateObject("Scripting.Dictionary")
|
||
Set pErrorMessages = New collection
|
||
Set pExcludeCategories = New collection
|
||
End Sub
|
||
|
||
'=====================================================================
|
||
' 方法: SetWorksheet
|
||
' 功能: 设置BOM数据源工作表
|
||
' 参数: ws - 工作表对象
|
||
'=====================================================================
|
||
Public Sub SetWorksheet(ws As Worksheet)
|
||
Set pWorksheet = ws
|
||
End Sub
|
||
|
||
'=====================================================================
|
||
' 方法: LoadBomData
|
||
' 功能: 加载BOM数据
|
||
' 返回: Boolean - 成功返回True
|
||
'=====================================================================
|
||
Public Function LoadBomData() As Boolean
|
||
On Error GoTo ErrorHandler
|
||
|
||
If pWorksheet Is Nothing Then
|
||
pErrorMessages.Add "未设置工作表"
|
||
LoadBomData = False
|
||
Exit Function
|
||
End If
|
||
|
||
' 清空现有数据
|
||
Set pAllItems = New collection
|
||
Set pCategoryHierarchy = CreateObject("Scripting.Dictionary")
|
||
|
||
' 从第4行开始读取(第3行是表头)
|
||
Dim lastRow As Long
|
||
lastRow = pWorksheet.Cells(pWorksheet.Rows.Count, 1).End(xlUp).row
|
||
|
||
Dim i As Long
|
||
Dim item As BomItem
|
||
|
||
For i = 4 To lastRow
|
||
' 检查行号是否为空
|
||
If Trim(pWorksheet.Cells(i, 1).value) <> "" Then
|
||
Set item = New BomItem
|
||
item.LoadFromRow pWorksheet, i
|
||
|
||
' 只添加有效物料(类别不为空)
|
||
If item.IsValidItem Then
|
||
pAllItems.Add item
|
||
|
||
' 构建类别层次结构
|
||
If item.HasParentCategory Then
|
||
If Not pCategoryHierarchy.Exists(item.category) Then
|
||
pCategoryHierarchy.Add item.category, item.ParentCategory
|
||
End If
|
||
End If
|
||
Else
|
||
' 非有效物料也添加,但标记为特殊类别
|
||
pAllItems.Add item
|
||
End If
|
||
End If
|
||
Next i
|
||
|
||
LoadBomData = True
|
||
Exit Function
|
||
|
||
ErrorHandler:
|
||
pErrorMessages.Add "加载BOM数据异常: " & Err.description
|
||
LoadBomData = False
|
||
End Function
|
||
|
||
'=====================================================================
|
||
' 方法: SetExcludeCategories
|
||
' 功能: 设置需要排除的类别
|
||
' 参数: categories - 类别集合
|
||
'=====================================================================
|
||
Public Sub SetExcludeCategories(categories As collection)
|
||
Set pExcludeCategories = categories
|
||
End Sub
|
||
|
||
'=====================================================================
|
||
' 方法: ClearExcludeCategories
|
||
' 功能: 清空排除类别列表
|
||
'=====================================================================
|
||
Public Sub ClearExcludeCategories()
|
||
Set pExcludeCategories = New collection
|
||
End Sub
|
||
|
||
'=====================================================================
|
||
' 方法: ClearErrorMessages
|
||
' 功能: 清空错误信息列表
|
||
'=====================================================================
|
||
Public Sub ClearErrorMessages()
|
||
Set pErrorMessages = New collection
|
||
End Sub
|
||
|
||
'=====================================================================
|
||
' 方法: ExtractBom
|
||
' 功能: 根据产品条件提取BOM
|
||
' 参数: productConditions - 产品条件字典
|
||
' 返回: Collection - 匹配的BOM项集合
|
||
'=====================================================================
|
||
Public Function ExtractBom(productConditions As Object) As collection
|
||
On Error GoTo ErrorHandler
|
||
|
||
' 清空结果
|
||
Set pMatchedItems = New collection
|
||
Set pRequiredCategories = New collection
|
||
Set pErrorMessages = New collection
|
||
|
||
' 第一步:确定需要的类别
|
||
DetermineRequiredCategories productConditions
|
||
|
||
' 第二步:匹配物料
|
||
MatchItems productConditions
|
||
|
||
' 第三步:应用总成逻辑(父类别优先)
|
||
ApplyAssemblyLogic
|
||
|
||
' 第四步:验证结果
|
||
ValidateResult
|
||
|
||
Set ExtractBom = pMatchedItems
|
||
Exit Function
|
||
|
||
ErrorHandler:
|
||
pErrorMessages.Add "提取BOM异常: " & Err.description
|
||
Set ExtractBom = pMatchedItems
|
||
End Function
|
||
|
||
'=====================================================================
|
||
' 方法: DetermineRequiredCategories
|
||
' 功能: 确定需要的类别
|
||
' 参数: productConditions - 产品条件字典
|
||
'=====================================================================
|
||
Private Sub DetermineRequiredCategories(productConditions As Object)
|
||
Dim item As BomItem
|
||
Dim uniqueCategories As Object
|
||
Set uniqueCategories = CreateObject("Scripting.Dictionary")
|
||
|
||
' 遍历所有有效物料,获取唯一类别
|
||
For Each item In pAllItems
|
||
If item.IsValidItem Then
|
||
' 检查是否在排除列表中
|
||
Dim isExcluded As Boolean
|
||
isExcluded = False
|
||
Dim excludeCat As Variant
|
||
For Each excludeCat In pExcludeCategories
|
||
If item.category = CStr(excludeCat) Then
|
||
isExcluded = True
|
||
Exit For
|
||
End If
|
||
Next excludeCat
|
||
|
||
' 如果不在排除列表中，继续处理
|
||
If Not isExcluded Then
|
||
' 检查类别选用条件
|
||
Dim categoryRequired As Boolean
|
||
If Trim(item.CategoryCondition) = "" Then
|
||
' 无条件,必需类别
|
||
categoryRequired = True
|
||
Else
|
||
' 有条件,评估条件
|
||
categoryRequired = pConditionEvaluator.Evaluate(item.CategoryCondition, productConditions)
|
||
End If
|
||
|
||
If categoryRequired Then
|
||
If Not uniqueCategories.Exists(item.category) Then
|
||
uniqueCategories.Add item.category, True
|
||
pRequiredCategories.Add item.category
|
||
End If
|
||
End If
|
||
End If
|
||
End If
|
||
Next item
|
||
End Sub
|
||
|
||
'=====================================================================
|
||
' 方法: MatchItems
|
||
' 功能: 匹配物料
|
||
' 修改说明: 当未匹配到物料(Count=0)时不再立即报错，而是留给 ValidateResult
|
||
' 进行综合判断（因为可能存在父子覆盖或散件满足的情况）。
|
||
'=====================================================================
|
||
Private Sub MatchItems(productConditions As Object)
|
||
Dim item As BomItem
|
||
Dim category As Variant
|
||
|
||
' 遍历每个需要的类别
|
||
For Each category In pRequiredCategories
|
||
Dim categoryMatches As collection
|
||
Set categoryMatches = New collection
|
||
|
||
' 查找该类别下所有匹配的物料
|
||
For Each item In pAllItems
|
||
If item.category = category Then
|
||
' 评估选择条件
|
||
Dim matched As Boolean
|
||
If Trim(item.SelectCondition) = "" Then
|
||
' 无选择条件,无条件匹配
|
||
matched = True
|
||
Else
|
||
' 有选择条件,评估
|
||
matched = pConditionEvaluator.Evaluate(item.SelectCondition, productConditions)
|
||
End If
|
||
|
||
If matched Then
|
||
item.IsMatched = True
|
||
categoryMatches.Add item
|
||
End If
|
||
End If
|
||
Next item
|
||
|
||
' 检查匹配结果
|
||
If categoryMatches.Count = 0 Then
|
||
' ---------------------------------------------------------
|
||
' CHANGE: 这里不再立即报错
|
||
' 理由: 未匹配到可能是正常的（例如：父类别缺失但子类别齐全，或者子类别被父类别覆盖）
|
||
' 具体的缺失检查移交到 ValidateResult 方法中统一处理
|
||
' ---------------------------------------------------------
|
||
ElseIf categoryMatches.Count = 1 Then
|
||
' 正常:匹配到1条
|
||
pMatchedItems.Add categoryMatches(1)
|
||
Else
|
||
' 异常:匹配到多条 (这个依然需要报错，因为这是数据源的不确定性错误)
|
||
Dim multiMsg As String
|
||
multiMsg = "类别[" & category & "]匹配到多条物料(" & categoryMatches.Count & "条)"
|
||
pErrorMessages.Add multiMsg
|
||
|
||
' 临时处理:输出所有匹配的
|
||
Dim tempItem As BomItem
|
||
For Each tempItem In categoryMatches
|
||
tempItem.MatchError = multiMsg
|
||
pMatchedItems.Add tempItem
|
||
Next tempItem
|
||
End If
|
||
Next category
|
||
End Sub
|
||
|
||
'=====================================================================
|
||
' 方法: ApplyAssemblyLogic
|
||
' 功能: 应用总成逻辑(父类别优先)
|
||
' 修改说明: 重构了算法，解决了以下问题：
|
||
' 1. 当某类别匹配到多条物料时，能够保留所有匹配项，而不是只输出第一条。
|
||
' 2. 解决了因列表顺序不同导致子类别可能未被正确覆盖的潜在隐患。
|
||
'=====================================================================
|
||
Private Sub ApplyAssemblyLogic()
|
||
' 1. 构建父类别->子类别映射
|
||
Dim parentToChildren As Object
|
||
Set parentToChildren = CreateObject("Scripting.Dictionary")
|
||
Dim parentCat As Variant
|
||
Dim childCat As Variant
|
||
Dim key As Variant
|
||
For Each key In pCategoryHierarchy.Keys
|
||
|
||
|
||
childCat = CStr(key)
|
||
parentCat = pCategoryHierarchy(key)
|
||
|
||
If Not parentToChildren.Exists(parentCat) Then
|
||
Set parentToChildren(parentCat) = CreateObject("Scripting.Dictionary")
|
||
End If
|
||
parentToChildren(parentCat)(childCat) = True
|
||
Next key
|
||
|
||
' 2. 统计每个类别的匹配数量
|
||
Dim categoryCounts As Object
|
||
Set categoryCounts = CreateObject("Scripting.Dictionary")
|
||
|
||
Dim item As BomItem
|
||
For Each item In pMatchedItems
|
||
If Not categoryCounts.Exists(item.category) Then
|
||
categoryCounts(item.category) = 0
|
||
End If
|
||
categoryCounts(item.category) = categoryCounts(item.category) + 1
|
||
Next item
|
||
|
||
' 3. 识别符合"总成优先"条件的父类别
|
||
' 定义：如果父类别有且仅有1条匹配，且其所有子类别都有匹配，则视为满足总成逻辑
|
||
Dim coveredCategories As Object
|
||
Set coveredCategories = CreateObject("Scripting.Dictionary")
|
||
|
||
Dim satisfiedParentItems As collection
|
||
Set satisfiedParentItems = New collection
|
||
|
||
For Each parentCat In parentToChildren.Keys
|
||
' 只有当该父类别确实有匹配物料时才进行检查
|
||
If categoryCounts.Exists(parentCat) Then
|
||
' 条件1: 父类别只匹配到1条 (如果匹配多条，存在歧义，不应用覆盖逻辑，而是全部输出以供排查)
|
||
If categoryCounts(parentCat) = 1 Then
|
||
' 条件2: 所有子类别都匹配到(至少1条)
|
||
Dim childrenMatched As Boolean
|
||
childrenMatched = True
|
||
|
||
For Each childCat In parentToChildren(parentCat).Keys
|
||
If Not categoryCounts.Exists(childCat) Then
|
||
childrenMatched = False
|
||
Exit For
|
||
End If
|
||
Next childCat
|
||
|
||
If childrenMatched Then
|
||
' 满足总成条件: 找到那个父类别项
|
||
Dim pItem As BomItem
|
||
For Each item In pMatchedItems
|
||
If item.category = parentCat Then
|
||
satisfiedParentItems.Add item
|
||
Exit For
|
||
End If
|
||
Next item
|
||
|
||
' 标记覆盖的类别(父类别自己和所有子类别都标记为已处理)
|
||
' 这样做的目的是：在步骤4中，我们会先添加 satisfiedParentItems，
|
||
' 然后跳过 coveredCategories 中的项，从而实现"父类覆盖子类"且"父类不重复添加"
|
||
coveredCategories(parentCat) = True
|
||
For Each childCat In parentToChildren(parentCat).Keys
|
||
coveredCategories(childCat) = True
|
||
Next childCat
|
||
End If
|
||
End If
|
||
End If
|
||
Next parentCat
|
||
|
||
' 4. 构建新的结果集
|
||
Dim newMatchedItems As collection
|
||
Set newMatchedItems = New collection
|
||
|
||
' 4.1 先添加满足条件的父类别项 (总成)
|
||
For Each item In satisfiedParentItems
|
||
newMatchedItems.Add item
|
||
Next item
|
||
|
||
' 4.2 再添加未被覆盖的其他项 (散件 或 有问题的多条匹配项)
|
||
For Each item In pMatchedItems
|
||
' 如果该项所属的类别不在"被覆盖"列表中，则保留
|
||
' 关键点：这里不再去重！如果同一个Category有5条记录，这5条都会因为不在coveredCategories中而被添加
|
||
If Not coveredCategories.Exists(item.category) Then
|
||
newMatchedItems.Add item
|
||
End If
|
||
Next item
|
||
|
||
' 更新结果
|
||
Set pMatchedItems = newMatchedItems
|
||
End Sub
|
||
|
||
'=====================================================================
|
||
' 方法: ValidateResult
|
||
' 功能: 验证提取结果
|
||
' 修改说明: 实现了双向覆盖检查：
|
||
' 1. 子类别缺失，但父类别存在 -> 视为正常 (总成优先)
|
||
' 2. 父类别缺失，但所有必需子类别都存在 -> 视为正常 (散件满足)
|
||
'=====================================================================
|
||
Private Sub ValidateResult()
|
||
' 检查所有需要的类别是否都匹配
|
||
Dim category As Variant
|
||
Dim categoryMatched As Object
|
||
Set categoryMatched = CreateObject("Scripting.Dictionary")
|
||
|
||
' 统计已匹配的类别
|
||
Dim item As BomItem
|
||
For Each item In pMatchedItems
|
||
If Not categoryMatched.Exists(item.category) Then
|
||
categoryMatched(item.category) = 0
|
||
End If
|
||
categoryMatched(item.category) = categoryMatched(item.category) + 1
|
||
Next item
|
||
|
||
' 检查未匹配的类别
|
||
For Each category In pRequiredCategories
|
||
' 如果结果集中不存在该必需类别
|
||
If Not categoryMatched.Exists(category) Then
|
||
|
||
Dim isResolved As Boolean
|
||
isResolved = False
|
||
|
||
' ---------------------------------------------------------
|
||
' 检查 1: 被父类别覆盖 (总成逻辑)
|
||
' 场景: 匹配到了部件(父)，自动隐藏了接头(子)，接头不应报错
|
||
' ---------------------------------------------------------
|
||
If pCategoryHierarchy.Exists(category) Then
|
||
Dim parentCat As String
|
||
parentCat = pCategoryHierarchy(category)
|
||
|
||
If categoryMatched.Exists(parentCat) Then
|
||
isResolved = True
|
||
End If
|
||
End If
|
||
|
||
' ---------------------------------------------------------
|
||
' 检查 2: 被子类别覆盖 (散件逻辑)
|
||
' 场景: 部件(父)没匹配到(或被移除)，但接头(子)和弹性元件(子)都齐了，部件不应报错
|
||
' ---------------------------------------------------------
|
||
If Not isResolved Then
|
||
Dim hasRequiredChildren As Boolean
|
||
Dim allChildrenMatched As Boolean
|
||
|
||
hasRequiredChildren = False
|
||
allChildrenMatched = True
|
||
|
||
' 遍历所有"必需"的类别，寻找当前缺失category的子类别
|
||
Dim reqCat As Variant
|
||
For Each reqCat In pRequiredCategories
|
||
' 如果 reqCat 是当前 category 的子类别
|
||
If pCategoryHierarchy.Exists(reqCat) Then
|
||
If pCategoryHierarchy(reqCat) = category Then
|
||
hasRequiredChildren = True
|
||
|
||
' 检查这个子类别是否在结果集中
|
||
If Not categoryMatched.Exists(reqCat) Then
|
||
allChildrenMatched = False
|
||
Exit For ' 只要缺一个子类别，父类别就无法被视为"满足"
|
||
End If
|
||
End If
|
||
End If
|
||
Next reqCat
|
||
|
||
' 只有当存在必需子类别，且它们全都匹配时，才算通过
|
||
If hasRequiredChildren And allChildrenMatched Then
|
||
isResolved = True
|
||
End If
|
||
End If
|
||
|
||
' ---------------------------------------------------------
|
||
' 最终判断
|
||
' ---------------------------------------------------------
|
||
If Not isResolved Then
|
||
pErrorMessages.Add "必需类别[" & category & "]未匹配"
|
||
End If
|
||
|
||
End If
|
||
Next category
|
||
End Sub
|
||
|
||
'=====================================================================
|
||
' 方法: GetErrorMessages
|
||
' 功能: 获取错误信息集合
|
||
' 返回: Collection
|
||
'=====================================================================
|
||
Public Function GetErrorMessages() As collection
|
||
Set GetErrorMessages = pErrorMessages
|
||
End Function
|
||
|
||
'=====================================================================
|
||
' 方法: GetErrorSummary
|
||
' 功能: 获取错误信息摘要
|
||
' 返回: String
|
||
'=====================================================================
|
||
Public Function GetErrorSummary() As String
|
||
If pErrorMessages.Count = 0 Then
|
||
GetErrorSummary = ""
|
||
Else
|
||
Dim result As String
|
||
Dim msg As Variant
|
||
For Each msg In pErrorMessages
|
||
result = result & CStr(msg) & "; "
|
||
Next msg
|
||
GetErrorSummary = result
|
||
End If
|
||
End Function |