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

feat: add core VBA source code modules

Browse Source 
Add VBA directory with essential project code including:
- ClassModules: BomExtractor, BomItem, ConditionEvaluator, ProductModelParser
- Modules: MainModule, TestModule
- Forms and DocumentModules
- vba_metadata.json for module metadata

Co-Authored-By: Claude Sonnet 4.5 <noreply@anthropic.com>
This commit is contained in:
Misaka
2026-02-01 16:18:17 +08:00
parent 80d9734b91
commit 79dc7cbf72
7 changed files with 1726 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

444
VBA/ClassModules/BomExtractor.cls Normal file
View File

@@ -0,0 +1,444 @@
'=====================================================================
' 类名: BomExtractor
' 功能: BOM提取器,从平台配置清单中提取匹配的物料
' 作者: Auto-generated
' 日期: 2025-01-29
'=====================================================================
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
'=====================================================================
' 方法: 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
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
'=====================================================================
' 方法: 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
'pErrorMessages.Clear
' 第一步:确定需要的类别
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 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
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

88
VBA/ClassModules/BomItem.cls Normal file
View File

@@ -0,0 +1,88 @@
'=====================================================================
' 类名: BomItem
' 功能: BOM物料项数据模型
' 作者: Auto-generated
' 日期: 2025-01-29
'=====================================================================
Option Explicit
' 物料属性
Public RowNumber As Long ' 行号
Public Module As String ' 模块
Public code As String ' 代号
Public Name As String ' 名称
Public Quantity As Double ' 数量
Public SelectCondition As String ' 选择条件
Public Remark As String ' 备注
Public category As String ' 类别
Public ParentCategory As String ' 上层类别
Public CategoryCondition As String ' 类别选用条件
Public Code66 As String ' 66代码
' 匹配状态
Public IsMatched As Boolean ' 是否匹配
Public MatchError As String ' 匹配错误信息
'=====================================================================
' 方法: Class_Initialize
' 功能: 初始化类
'=====================================================================
Private Sub Class_Initialize()
IsMatched = False
MatchError = ""
End Sub
'=====================================================================
' 方法: LoadFromRow
' 功能: 从工作表行加载数据
' 参数: ws - 工作表对象
' row - 行号
'=====================================================================
Public Sub LoadFromRow(ws As Worksheet, row As Long)
On Error Resume Next
Me.RowNumber = CLng(ws.Cells(row, 1).value) ' A列: 行号
Me.Module = CStr(ws.Cells(row, 2).value) ' B列: 模块
Me.code = CStr(ws.Cells(row, 3).value) ' C列: 代号
Me.Name = CStr(ws.Cells(row, 4).value) ' D列: 名称
Me.Quantity = CDbl(ws.Cells(row, 5).value) ' E列: 数量
Me.SelectCondition = CStr(ws.Cells(row, 6).value) ' F列: 选择条件
Me.Remark = CStr(ws.Cells(row, 7).value) ' G列: 备注
Me.category = CStr(ws.Cells(row, 8).value) ' H列: 类别
Me.ParentCategory = CStr(ws.Cells(row, 9).value) ' I列: 上层类别
Me.CategoryCondition = CStr(ws.Cells(row, 10).value) ' J列: 类别选用条件
Me.Code66 = CStr(ws.Cells(row, 11).value) ' K列: 66代码
On Error GoTo 0
End Sub
'=====================================================================
' 方法: IsValidItem
' 功能: 判断是否为有效物料(类别字段不为空)
' 返回: Boolean
'=====================================================================
Public Function IsValidItem() As Boolean
IsValidItem = (Trim(Me.category) <> "")
End Function
'=====================================================================
' 方法: HasParentCategory
' 功能: 判断是否有父类别
' 返回: Boolean
'=====================================================================
Public Function HasParentCategory() As Boolean
HasParentCategory = (Trim(Me.ParentCategory) <> "")
End Function
'=====================================================================
' 方法: ToString
' 功能: 转换为字符串描述
' 返回: String
'=====================================================================
Public Function ToString() As String
ToString = "行号:" & Me.RowNumber & _
" | 类别:" & Me.category & _
" | 代号:" & Me.code & _
" | 名称:" & Me.Name
End Function

210
VBA/ClassModules/ConditionEvaluator.cls Normal file
View File

@@ -0,0 +1,210 @@
'=====================================================================
' 类名: ConditionEvaluator
' 功能: 解析和评估条件表达式
' 作者: Auto-generated
' 日期: 2025-01-29
'=====================================================================
Option Explicit
'=====================================================================
' 方法: Evaluate
' 功能: 评估条件表达式
' 参数: expression - 条件表达式字符串
' productConditions - 产品条件字典(Dictionary对象)
' 返回: Boolean - True表示条件满足,False表示不满足
' 说明: 支持AND、OR、!=运算符和括号嵌套
' 特殊规则:如果表达式中要求!=某值,而产品条件中不存在该变量,视为满足条件
'=====================================================================
Public Function Evaluate(expression As String, productConditions As Object) As Boolean
On Error GoTo ErrorHandler
' 空条件视为满足
If Trim(expression) = "" Then
Evaluate = True
Exit Function
End If
' 递归解析表达式
Evaluate = EvaluateExpression(Trim(expression), productConditions)
Exit Function
ErrorHandler:
' 解析错误时返回False
Evaluate = False
End Function
'=====================================================================
' 方法: EvaluateExpression
' 功能: 递归评估表达式
' 参数: expr - 表达式
' conditions - 条件字典
' 返回: Boolean
'=====================================================================
Private Function EvaluateExpression(expr As String, Conditions As Object) As Boolean
expr = Trim(expr)
' 处理最外层括号
If Left(expr, 1) = "(" And Right(expr, 1) = ")" Then
If IsMatchedParentheses(expr) Then
expr = Mid(expr, 2, Len(expr) - 2)
expr = Trim(expr)
End If
End If
' 处理OR运算符(优先级最低)
Dim orResult As Variant
orResult = SplitByOperator(expr, " OR ", Conditions)
If Not IsEmpty(orResult) Then
EvaluateExpression = orResult
Exit Function
End If
' 处理AND运算符
Dim andResult As Variant
andResult = SplitByOperator(expr, " AND ", Conditions)
If Not IsEmpty(andResult) Then
EvaluateExpression = andResult
Exit Function
End If
' 处理单个条件
EvaluateExpression = EvaluateSingleCondition(expr, Conditions)
End Function
'=====================================================================
' 方法: SplitByOperator
' 功能: 按指定运算符分割并评估表达式
' 参数: expr - 表达式
' operator - 运算符(" OR " 或 " AND ")
' conditions - 条件字典
' 返回: Variant - 评估结果或Empty
'=====================================================================
Private Function SplitByOperator(expr As String, operator As String, Conditions As Object) As Variant
Dim pos As Long
Dim leftPart As String
Dim rightPart As String
Dim depth As Long
Dim i As Long
Dim char As String
' 寻找不在括号内的运算符
depth = 0
For i = 1 To Len(expr) - Len(operator) + 1
char = Mid(expr, i, 1)
If char = "(" Then
depth = depth + 1
ElseIf char = ")" Then
depth = depth - 1
ElseIf depth = 0 Then
' 检查是否匹配运算符
If Mid(expr, i, Len(operator)) = operator Then
leftPart = Trim(Left(expr, i - 1))
rightPart = Trim(Mid(expr, i + Len(operator)))
' 根据运算符类型评估
If operator = " OR " Then
SplitByOperator = EvaluateExpression(leftPart, Conditions) Or _
EvaluateExpression(rightPart, Conditions)
ElseIf operator = " AND " Then
SplitByOperator = EvaluateExpression(leftPart, Conditions) And _
EvaluateExpression(rightPart, Conditions)
End If
Exit Function
End If
End If
Next i
' 未找到运算符
SplitByOperator = Empty
End Function
'=====================================================================
' 方法: EvaluateSingleCondition
' 功能: 评估单个条件(如 azxs=A0 或 azxs!=AH)
' 参数: condition - 单个条件字符串
' conditions - 条件字典
' 返回: Boolean
'=====================================================================
Private Function EvaluateSingleCondition(condition As String, Conditions As Object) As Boolean
Dim varName As String
Dim operator As String
Dim value As String
Dim actualValue As String
condition = Trim(condition)
' 检查!=运算符
If InStr(condition, "!=") > 0 Then
Dim parts() As String
parts = Split(condition, "!=")
If UBound(parts) >= 1 Then
varName = Trim(parts(0))
value = Trim(parts(1))
' 特殊规则:如果产品条件中不存在该变量,视为满足!=条件
If Not Conditions.Exists(varName) Then
EvaluateSingleCondition = True
Else
actualValue = Conditions(varName)
EvaluateSingleCondition = (actualValue <> value)
End If
Exit Function
End If
End If
' 检查=运算符
If InStr(condition, "=") > 0 Then
Dim eqParts() As String
eqParts = Split(condition, "=")
If UBound(eqParts) >= 1 Then
varName = Trim(eqParts(0))
value = Trim(eqParts(1))
If Not Conditions.Exists(varName) Then
EvaluateSingleCondition = False
Else
actualValue = Conditions(varName)
EvaluateSingleCondition = (actualValue = value)
End If
Exit Function
End If
End If
' 无法解析的条件返回False
EvaluateSingleCondition = False
End Function
'=====================================================================
' 方法: IsMatchedParentheses
' 功能: 检查字符串最外层括号是否匹配
' 参数: str - 字符串
' 返回: Boolean
'=====================================================================
Private Function IsMatchedParentheses(str As String) As Boolean
If Left(str, 1) <> "(" Or Right(str, 1) <> ")" Then
IsMatchedParentheses = False
Exit Function
End If
Dim depth As Long
Dim i As Long
depth = 0
For i = 1 To Len(str)
If Mid(str, i, 1) = "(" Then
depth = depth + 1
ElseIf Mid(str, i, 1) = ")" Then
depth = depth - 1
End If
' 如果在中间某处深度归零,说明最外层括号不匹配
If depth = 0 And i < Len(str) Then
IsMatchedParentheses = False
Exit Function
End If
Next i
IsMatchedParentheses = (depth = 0)
End Function

234
VBA/ClassModules/ProductModelParser.cls Normal file
View File

@@ -0,0 +1,234 @@
'=====================================================================
' 类名: ProductModelParser
' 功能: 解析产品型号并提取物料选择条件
' 作者: Auto-generated
' 日期: 2025-01-29
'=====================================================================
Option Explicit
Private pFullModel As String
Private pHeaderModel As String
Private pConditions As Object ' Dictionary
Private pErrorMessage As String
'=====================================================================
' 属性: FullModel - 完整产品型号
'=====================================================================
Public Property Get FullModel() As String
FullModel = pFullModel
End Property
Public Property Let FullModel(value As String)
pFullModel = value
End Property
'=====================================================================
' 属性: HeaderModel - 表头型号
'=====================================================================
Public Property Get HeaderModel() As String
HeaderModel = pHeaderModel
End Property
'=====================================================================
' 属性: Conditions - 提取的条件字典
'=====================================================================
Public Property Get Conditions() As Object
Set Conditions = pConditions
End Property
'=====================================================================
' 属性: ErrorMessage - 错误信息
'=====================================================================
Public Property Get ErrorMessage() As String
ErrorMessage = pErrorMessage
End Property
'=====================================================================
' 方法: Class_Initialize
' 功能: 初始化类
'=====================================================================
Private Sub Class_Initialize()
Set pConditions = CreateObject("Scripting.Dictionary")
pErrorMessage = ""
End Sub
'=====================================================================
' 方法: Parse
' 功能: 解析产品型号
' 参数: modelString - 完整产品型号字符串
' 返回: Boolean - True表示解析成功,False表示失败
'=====================================================================
Public Function Parse(modelString As String) As Boolean
On Error GoTo ErrorHandler
pFullModel = Trim(modelString)
pConditions.RemoveAll
pErrorMessage = ""
' 提取表头部分(|之前的部分)
Dim parts() As String
parts = Split(pFullModel, "|")
If UBound(parts) < 0 Then
pErrorMessage = "型号格式错误:缺少表头部分"
Parse = False
Exit Function
End If
pHeaderModel = Trim(parts(0))
' 解析表头型号
If Not ParseHeader() Then
Parse = False
Exit Function
End If
Parse = True
Exit Function
ErrorHandler:
pErrorMessage = "解析异常: " & Err.description
Parse = False
End Function
'=====================================================================
' 方法: ParseHeader
' 功能: 解析表头型号结构
' 返回: Boolean - True表示解析成功
' 说明: 表头结构 [型号]-[公称外径].[安装形式].[壳体形式].[过程连接&接液材质].[量程范围].[仪表特性]
'=====================================================================
Private Function ParseHeader() As Boolean
On Error GoTo ErrorHandler
' 分离型号和其余部分
Dim dashParts() As String
dashParts = Split(pHeaderModel, "-")
If UBound(dashParts) < 1 Then
pErrorMessage = "表头格式错误:缺少'-'分隔符"
ParseHeader = False
Exit Function
End If
' 分离各个字段(用.分隔)
Dim dotParts() As String
dotParts = Split(dashParts(1), ".")
' 验证结构完整性:至少需要5个部分(公称外径、安装形式、壳体形式、过程连接、量程)
If UBound(dotParts) < 4 Then
pErrorMessage = "表头结构不完整:缺少必要字段"
ParseHeader = False
Exit Function
End If
' 提取各个条件
' 安装形式 - 第2个位置(索引1)
Dim azxs As String
azxs = Trim(dotParts(1))
pConditions.Add "azxs", azxs
' 表壳形式 - 第3个位置(索引2)
Dim bkxs As String
bkxs = Trim(dotParts(2))
pConditions.Add "bkxs", bkxs
' 过程连接和接液材质 - 第4个位置(索引3)
Dim connectionCode As String
connectionCode = Trim(dotParts(3))
Dim gclj As String
Dim jycz As String
If Not ExtractConnectionAndMaterial(connectionCode, gclj, jycz) Then
ParseHeader = False
Exit Function
End If
pConditions.Add "gclj", gclj
pConditions.Add "jycz", jycz
' 量程范围 - 第5个位置(索引4)
Dim lcfw As String
lcfw = Trim(dotParts(4))
pConditions.Add "lcfw", lcfw
ParseHeader = True
Exit Function
ErrorHandler:
pErrorMessage = "解析表头异常: " & Err.description
ParseHeader = False
End Function
'=====================================================================
' 方法: ExtractConnectionAndMaterial
' 功能: 从过程连接代码中提取过程连接和接液材质
' 参数: code - 过程连接代码(如M203)
' outConnection - 输出:过程连接(如M20)
' outMaterial - 输出:接液材质(如3)
' 返回: Boolean - True表示提取成功
' 说明: 材质代码为最后一位数字,其余为螺纹代码
'=====================================================================
Private Function ExtractConnectionAndMaterial(code As String, _
ByRef outConnection As String, _
ByRef outMaterial As String) As Boolean
On Error GoTo ErrorHandler
If Len(code) < 2 Then
pErrorMessage = "过程连接代码格式错误:长度不足"
ExtractConnectionAndMaterial = False
Exit Function
End If
' 材质代码是最后一位数字
Dim lastChar As String
lastChar = Right(code, 1)
' 验证最后一位是否为数字
If Not IsNumeric(lastChar) Then
pErrorMessage = "过程连接代码格式错误:最后一位不是数字"
ExtractConnectionAndMaterial = False
Exit Function
End If
outMaterial = lastChar
outConnection = Left(code, Len(code) - 1)
ExtractConnectionAndMaterial = True
Exit Function
ErrorHandler:
pErrorMessage = "提取过程连接和材质异常: " & Err.description
ExtractConnectionAndMaterial = False
End Function
'=====================================================================
' 方法: GetConditionValue
' 功能: 获取指定条件的值
' 参数: conditionName - 条件名称
' 返回: String - 条件值,如果不存在返回空字符串
'=====================================================================
Public Function GetConditionValue(conditionName As String) As String
If pConditions.Exists(conditionName) Then
GetConditionValue = pConditions(conditionName)
Else
GetConditionValue = ""
End If
End Function
'=====================================================================
' 方法: GetAllConditions
' 功能: 获取所有条件的描述文本
' 返回: String - 条件描述文本
'=====================================================================
Public Function GetAllConditions() As String
Dim result As String
Dim key As Variant
result = ""
For Each key In pConditions.Keys
result = result & key & "=" & pConditions(key) & "; "
Next key
GetAllConditions = result
End Function

371
VBA/Modules/MainModule.bas Normal file
View File

@@ -0,0 +1,371 @@
'=====================================================================
' 模块名: MainModule
' 功能: 主控模块,处理产品型号提取和BOM匹配的上层逻辑
' 作者: Auto-generated
' 日期: 2025-01-29
'=====================================================================
Option Explicit
'=====================================================================
' 常量定义
'=====================================================================
' 提取条件配置(可灵活扩展)
Private Const CONDITION_CONFIG = "azxs,安装形式|bkxs,表壳形式|gclj,过程连接|jycz,接液材质|lcfw,量程范围"
'=====================================================================
' 过程: ProcessProductModels
' 功能: 批量处理产品型号并输出结果
' 说明: 这是主入口程序
'=====================================================================
Public Sub ProcessProductModels()
On Error GoTo ErrorHandler
Dim startTime As Double
startTime = Timer
' 准备输入输出
Dim inputSheet As Worksheet
Dim outputSheet As Worksheet
Dim bomSheet As Worksheet
' 获取工作表
Set inputSheet = GetInputSheet()
If inputSheet Is Nothing Then
MsgBox "未找到输入工作表,请确保工作簿中有包含订单数据的工作表", vbCritical
Exit Sub
End If
' 获取BOM库工作表
Set bomSheet = GetBomSheet()
If bomSheet Is Nothing Then
MsgBox "未找到'平台配置清单'工作表,请确保BOM数据存在", vbCritical
Exit Sub
End If
' 创建或获取输出工作表
Set outputSheet = CreateOutputSheet()
' 初始化BOM提取器
Dim BomExtractor As BomExtractor
Set BomExtractor = New BomExtractor
BomExtractor.SetWorksheet bomSheet
If Not BomExtractor.LoadBomData Then
MsgBox "加载BOM数据失败:" & BomExtractor.GetErrorSummary, vbCritical
Exit Sub
End If
' 处理每个产品型号
Dim lastRow As Long
lastRow = inputSheet.Cells(inputSheet.Rows.Count, 1).End(xlUp).row
Dim outputRow As Long
outputRow = 2 ' 从第2行开始输出(第1行是表头)
' 写入输出表头
WriteOutputHeader outputSheet
Dim i As Long
Dim modelString As String
Dim processedCount As Long
processedCount = 0
' 假设产品型号在第1列,从第2行开始
For i = 2 To lastRow
modelString = Trim(inputSheet.Cells(i, 2).value)
If modelString <> "" Then
' 处理单个型号
outputRow = ProcessSingleModel(modelString, BomExtractor, outputSheet, outputRow)
processedCount = processedCount + 1
End If
Next i
' 格式化输出表
FormatOutputSheet outputSheet
Dim elapsedTime As Double
elapsedTime = Timer - startTime
MsgBox "处理完成!" & vbCrLf & _
"处理型号数: " & processedCount & vbCrLf & _
"用时: " & Format(elapsedTime, "0.00") & "秒", vbInformation
' 激活输出表
outputSheet.Activate
Exit Sub
ErrorHandler:
MsgBox "处理异常: " & Err.description, vbCritical
End Sub
'=====================================================================
' 函数: ProcessSingleModel
' 功能: 处理单个产品型号
' 参数: modelString - 产品型号字符串
' bomExtractor - BOM提取器对象
' outputSheet - 输出工作表
' startRow - 起始行号
' 返回: Long - 下一个可用行号
'=====================================================================
Private Function ProcessSingleModel(modelString As String, _
BomExtractor As BomExtractor, _
outputSheet As Worksheet, _
startRow As Long) As Long
On Error Resume Next
Dim currentRow As Long
currentRow = startRow
' 解析产品型号
Dim parser As ProductModelParser
Set parser = New ProductModelParser
Dim extractNote As String
extractNote = ""
If Not parser.Parse(modelString) Then
' 解析失败
extractNote = "解析失败: " & parser.ErrorMessage
WriteOutputRow outputSheet, currentRow, modelString, "", parser.Conditions, extractNote, Nothing
ProcessSingleModel = currentRow + 1
Exit Function
End If
' 提取BOM
Dim matchedItems As collection
Set matchedItems = BomExtractor.ExtractBom(parser.Conditions)
' 获取错误信息
Dim bomErrors As String
bomErrors = BomExtractor.GetErrorSummary
If bomErrors <> "" Then
extractNote = bomErrors
End If
' 输出结果
If matchedItems.Count = 0 Then
' 没有匹配项
If extractNote = "" Then
extractNote = "未匹配到任何物料"
End If
WriteOutputRow outputSheet, currentRow, modelString, parser.HeaderModel, parser.Conditions, extractNote, Nothing
currentRow = currentRow + 1
Else
' 输出每个匹配的物料
Dim item As BomItem
Dim isFirst As Boolean
isFirst = True
For Each item In matchedItems
Dim itemNote As String
itemNote = extractNote
' 添加物料特定的错误
If item.MatchError <> "" Then
If itemNote <> "" Then itemNote = itemNote & "; "
itemNote = itemNote & item.MatchError
End If
If isFirst Then
WriteOutputRow outputSheet, currentRow, modelString, parser.HeaderModel, parser.Conditions, itemNote, item
isFirst = False
Else
WriteOutputRow outputSheet, currentRow, "", "", parser.Conditions, itemNote, item
End If
currentRow = currentRow + 1
Next item
End If
ProcessSingleModel = currentRow
End Function
'=====================================================================
' 过程: WriteOutputHeader
' 功能: 写入输出表头
' 参数: ws - 工作表对象
'=====================================================================
Private Sub WriteOutputHeader(ws As Worksheet)
Dim col As Long
col = 1
ws.Cells(1, col).value = "产品型号": col = col + 1
ws.Cells(1, col).value = "表头型号": col = col + 1
' 写入条件字段表头
Dim Conditions() As String
Dim labels() As String
GetConditionConfig Conditions, labels
Dim i As Long
For i = LBound(Conditions) To UBound(Conditions)
ws.Cells(1, col).value = labels(i)
col = col + 1
Next i
' BOM字段表头
ws.Cells(1, col).value = "行号": col = col + 1
ws.Cells(1, col).value = "模块": col = col + 1
ws.Cells(1, col).value = "代号": col = col + 1
ws.Cells(1, col).value = "名称": col = col + 1
ws.Cells(1, col).value = "数量": col = col + 1
ws.Cells(1, col).value = "类别": col = col + 1
ws.Cells(1, col).value = "66代码": col = col + 1
ws.Cells(1, col).value = "提取备注": col = col + 1
End Sub
'=====================================================================
' 过程: WriteOutputRow
' 功能: 写入输出行
' 参数: ws - 工作表对象
' row - 行号
' fullModel - 完整型号
' headerModel - 表头型号
' conditions - 条件字典
' note - 备注
' item - BOM项(可为Nothing)
'=====================================================================
Private Sub WriteOutputRow(ws As Worksheet, _
row As Long, _
FullModel As String, _
HeaderModel As String, _
Conditions As Object, _
note As String, _
item As BomItem)
Dim col As Long
col = 1
ws.Cells(row, col).value = FullModel: col = col + 1
ws.Cells(row, col).value = HeaderModel: col = col + 1
' 写入条件值
Dim condNames() As String
Dim labels() As String
GetConditionConfig condNames, labels
Dim i As Long
For i = LBound(condNames) To UBound(condNames)
If Conditions.Exists(condNames(i)) Then
ws.Cells(row, col).value = Conditions(condNames(i))
Else
ws.Cells(row, col).value = ""
End If
col = col + 1
Next i
' 写入BOM数据
If Not item Is Nothing Then
ws.Cells(row, col).value = item.RowNumber: col = col + 1
ws.Cells(row, col).value = item.Module: col = col + 1
ws.Cells(row, col).value = item.code: col = col + 1
ws.Cells(row, col).value = item.Name: col = col + 1
ws.Cells(row, col).value = item.Quantity: col = col + 1
ws.Cells(row, col).value = item.category: col = col + 1
ws.Cells(row, col).value = item.Code66: col = col + 1
Else
col = col + 7 ' 跳过BOM字段
End If
ws.Cells(row, col).value = note
End Sub
'=====================================================================
' 过程: GetConditionConfig
' 功能: 获取条件配置
' 参数: outNames - 输出条件名称数组
' outLabels - 输出条件标签数组
'=====================================================================
Private Sub GetConditionConfig(ByRef outNames() As String, ByRef outLabels() As String)
Dim configs() As String
configs = Split(CONDITION_CONFIG, "|")
ReDim outNames(LBound(configs) To UBound(configs))
ReDim outLabels(LBound(configs) To UBound(configs))
Dim i As Long
Dim parts() As String
For i = LBound(configs) To UBound(configs)
parts = Split(configs(i), ",")
outNames(i) = Trim(parts(0))
outLabels(i) = Trim(parts(1))
Next i
End Sub
'=====================================================================
' 函数: GetInputSheet
' 功能: 获取输入工作表
' 返回: Worksheet - 输入工作表对象
'=====================================================================
Private Function GetInputSheet() As Worksheet
' 这里假设输入数据在当前活动工作表或名为"订单"的工作表
On Error Resume Next
Set GetInputSheet = ThisWorkbook.Worksheets("产品订单")
If GetInputSheet Is Nothing Then
Set GetInputSheet = ActiveSheet
End If
On Error GoTo 0
End Function
'=====================================================================
' 函数: GetBomSheet
' 功能: 获取BOM工作表
' 返回: Worksheet - BOM工作表对象
'=====================================================================
Private Function GetBomSheet() As Worksheet
On Error Resume Next
Set GetBomSheet = ThisWorkbook.Worksheets("平台配置清单")
On Error GoTo 0
End Function
'=====================================================================
' 函数: CreateOutputSheet
' 功能: 创建或获取输出工作表
' 返回: Worksheet - 输出工作表对象
'=====================================================================
Private Function CreateOutputSheet() As Worksheet
Dim wsName As String
wsName = "BOM提取结果"
On Error Resume Next
Set CreateOutputSheet = ThisWorkbook.Worksheets(wsName)
On Error GoTo 0
If CreateOutputSheet Is Nothing Then
Set CreateOutputSheet = ThisWorkbook.Worksheets.Add
CreateOutputSheet.Name = wsName
Else
' 清空现有数据
CreateOutputSheet.Cells.Clear
End If
End Function
'=====================================================================
' 过程: FormatOutputSheet
' 功能: 格式化输出工作表
' 参数: ws - 工作表对象
'=====================================================================
Private Sub FormatOutputSheet(ws As Worksheet)
On Error Resume Next
' 设置表头格式
With ws.Rows(1)
.Font.Bold = True
.Interior.Color = RGB(217, 217, 217)
.HorizontalAlignment = xlCenter
End With
' ' 自动调整列宽
' ws.Columns.AutoFit
'
' ' 冻结首行
' ws.Rows(2).Select
' 'ActiveWindow.FreezePanes = True
' ws.Cells(1, 1).Select
On Error GoTo 0
End Sub

338
VBA/Modules/TestModule.bas Normal file
View File

@@ -0,0 +1,338 @@
'=====================================================================
' 模块名: TestModule
' 功能: 单元测试模块
' 作者: Auto-generated
' 日期: 2025-01-29
'=====================================================================
Option Explicit
'=====================================================================
' 过程: RunAllTests
' 功能: 运行所有测试
'=====================================================================
Public Sub RunAllTests()
Debug.Print "=========================================="
Debug.Print "开始运行所有测试"
Debug.Print "时间: " & Now
Debug.Print "=========================================="
Debug.Print ""
' 运行各个测试
TestProductModelParser
TestConditionEvaluator
TestBomExtractor
Debug.Print ""
Debug.Print "=========================================="
Debug.Print "所有测试完成"
Debug.Print "=========================================="
MsgBox "所有测试完成,请查看立即窗口查看结果", vbInformation
End Sub
'=====================================================================
' 过程: TestProductModelParser
' 功能: 测试产品型号解析器
'=====================================================================
Public Sub TestProductModelParser()
Debug.Print ">>> 测试 ProductModelParser"
Debug.Print ""
Dim parser As ProductModelParser
Set parser = New ProductModelParser
' 测试用例1: 正常型号
Debug.Print "测试用例1: 正常型号"
Dim testModel1 As String
testModel1 = "YTHN-100.A0.531.M203.M06.Y3|BP-088.2312.M06.0A3"
If parser.Parse(testModel1) Then
Debug.Print " 解析成功"
Debug.Print " 表头型号: " & parser.HeaderModel
Debug.Print " 条件:"
Debug.Print " azxs = " & parser.GetConditionValue("azxs")
Debug.Print " bkxs = " & parser.GetConditionValue("bkxs")
Debug.Print " gclj = " & parser.GetConditionValue("gclj")
Debug.Print " jycz = " & parser.GetConditionValue("jycz")
Debug.Print " lcfw = " & parser.GetConditionValue("lcfw")
' 验证结果
AssertEquals "azxs", "A0", parser.GetConditionValue("azxs")
AssertEquals "bkxs", "531", parser.GetConditionValue("bkxs")
AssertEquals "gclj", "M20", parser.GetConditionValue("gclj")
AssertEquals "jycz", "3", parser.GetConditionValue("jycz")
AssertEquals "lcfw", "M06", parser.GetConditionValue("lcfw")
Else
Debug.Print " 解析失败: " & parser.ErrorMessage
End If
Debug.Print ""
' 测试用例2: 不同材质代码
Debug.Print "测试用例2: 不同材质代码"
Dim testModel2 As String
testModel2 = "YTHN-100.BZ.531.M201.M09.Y3|BP-088.2312.M37.0A3"
If parser.Parse(testModel2) Then
Debug.Print " 解析成功"
Debug.Print " gclj = " & parser.GetConditionValue("gclj")
Debug.Print " jycz = " & parser.GetConditionValue("jycz")
AssertEquals "gclj", "M20", parser.GetConditionValue("gclj")
AssertEquals "jycz", "1", parser.GetConditionValue("jycz")
Else
Debug.Print " 解析失败: " & parser.ErrorMessage
End If
Debug.Print ""
' 测试用例3: 带附件的型号
Debug.Print "测试用例3: 带附件的型号"
Dim testModel3 As String
testModel3 = "YTHN-100.A0.531.G123.M04.Y3|BP-088.2312.B09.0A3"
If parser.Parse(testModel3) Then
Debug.Print " 解析成功"
Debug.Print " gclj = " & parser.GetConditionValue("gclj")
Debug.Print " jycz = " & parser.GetConditionValue("jycz")
AssertEquals "gclj", "G12", parser.GetConditionValue("gclj")
AssertEquals "jycz", "3", parser.GetConditionValue("jycz")
Else
Debug.Print " 解析失败: " & parser.ErrorMessage
End If
Debug.Print ""
Debug.Print "<<< ProductModelParser 测试完成"
Debug.Print ""
End Sub
'=====================================================================
' 过程: TestConditionEvaluator
' 功能: 测试条件评估器
'=====================================================================
Public Sub TestConditionEvaluator()
Debug.Print ">>> 测试 ConditionEvaluator"
Debug.Print ""
Dim evaluator As ConditionEvaluator
Set evaluator = New ConditionEvaluator
' 创建测试条件字典
Dim Conditions As Object
Set Conditions = CreateObject("Scripting.Dictionary")
Conditions.Add "azxs", "A0"
Conditions.Add "bkxs", "531"
Conditions.Add "gclj", "M20"
Conditions.Add "jycz", "3"
Conditions.Add "lcfw", "M06"
' 测试用例1: 简单等式
Debug.Print "测试用例1: 简单等式"
Dim expr1 As String
expr1 = "azxs=A0"
Debug.Print " 表达式: " & expr1
Debug.Print " 结果: " & evaluator.Evaluate(expr1, Conditions)
AssertTrue "简单等式", evaluator.Evaluate(expr1, Conditions)
Debug.Print ""
' 测试用例2: AND运算
Debug.Print "测试用例2: AND运算"
Dim expr2 As String
expr2 = "azxs=A0 AND bkxs=531"
Debug.Print " 表达式: " & expr2
Debug.Print " 结果: " & evaluator.Evaluate(expr2, Conditions)
AssertTrue "AND运算", evaluator.Evaluate(expr2, Conditions)
Debug.Print ""
' 测试用例3: OR运算
Debug.Print "测试用例3: OR运算"
Dim expr3 As String
expr3 = "azxs=AT OR azxs=A0"
Debug.Print " 表达式: " & expr3
Debug.Print " 结果: " & evaluator.Evaluate(expr3, Conditions)
AssertTrue "OR运算", evaluator.Evaluate(expr3, Conditions)
Debug.Print ""
' 测试用例4: !=运算
Debug.Print "测试用例4: !=运算"
Dim expr4 As String
expr4 = "azxs!=AH"
Debug.Print " 表达式: " & expr4
Debug.Print " 结果: " & evaluator.Evaluate(expr4, Conditions)
AssertTrue "!=运算", evaluator.Evaluate(expr4, Conditions)
Debug.Print ""
' 测试用例5: 复杂嵌套
Debug.Print "测试用例5: 复杂嵌套"
Dim expr5 As String
expr5 = "(azxs=A0 OR azxs=AT) AND (bkxs=531 OR bkxs=541)"
Debug.Print " 表达式: " & expr5
Debug.Print " 结果: " & evaluator.Evaluate(expr5, Conditions)
AssertTrue "复杂嵌套", evaluator.Evaluate(expr5, Conditions)
Debug.Print ""
' 测试用例6: 不存在的变量(!=情况)
Debug.Print "测试用例6: 不存在的变量(!=情况)"
Dim expr6 As String
expr6 = "tsyq!=SCRJ"
Debug.Print " 表达式: " & expr6
Debug.Print " 结果: " & evaluator.Evaluate(expr6, Conditions)
AssertTrue "不存在的变量!=", evaluator.Evaluate(expr6, Conditions)
Debug.Print ""
' 测试用例7: 实际BOM条件
Debug.Print "测试用例7: 实际BOM条件"
Dim expr7 As String
expr7 = "gclj=M20 AND jycz=1 AND lcfw=M01 AND (azxs=A0 OR azxs=AT OR azxs=AH)"
Debug.Print " 表达式: " & expr7
Debug.Print " 结果: " & evaluator.Evaluate(expr7, Conditions)
' 这个应该是False,因为jycz=3,不是1
AssertFalse "实际BOM条件(应该False)", evaluator.Evaluate(expr7, Conditions)
Debug.Print ""
Debug.Print "<<< ConditionEvaluator 测试完成"
Debug.Print ""
End Sub
'=====================================================================
' 过程: TestBomExtractor
' 功能: 测试BOM提取器(需要实际的工作表数据)
'=====================================================================
Public Sub TestBomExtractor()
Debug.Print ">>> 测试 BomExtractor"
Debug.Print ""
On Error Resume Next
Dim bomSheet As Worksheet
Set bomSheet = ThisWorkbook.Worksheets("平台配置清单")
If bomSheet Is Nothing Then
Debug.Print "警告: 未找到'平台配置清单'工作表,跳过BomExtractor测试"
Debug.Print ""
Exit Sub
End If
On Error GoTo 0
Dim extractor As BomExtractor
Set extractor = New BomExtractor
extractor.SetWorksheet bomSheet
If Not extractor.LoadBomData Then
Debug.Print "加载BOM数据失败: " & extractor.GetErrorSummary
Debug.Print ""
Exit Sub
End If
Debug.Print "BOM数据加载成功"
Debug.Print ""
' 测试用例: 提取BOM
Debug.Print "测试用例: 提取BOM"
Dim testConditions As Object
Set testConditions = CreateObject("Scripting.Dictionary")
testConditions.Add "azxs", "A0"
testConditions.Add "bkxs", "531"
testConditions.Add "gclj", "M20"
testConditions.Add "jycz", "1"
testConditions.Add "lcfw", "M01"
Dim matchedItems As collection
Set matchedItems = extractor.ExtractBom(testConditions)
Debug.Print " 匹配到 " & matchedItems.Count & " 个物料"
If matchedItems.Count > 0 Then
Debug.Print " 匹配的物料:"
Dim item As BomItem
Dim i As Long
i = 1
For Each item In matchedItems
Debug.Print " " & i & ". " & item.ToString
i = i + 1
Next item
End If
Dim errors As String
errors = extractor.GetErrorSummary
If errors <> "" Then
Debug.Print " 错误信息: " & errors
End If
Debug.Print ""
Debug.Print "<<< BomExtractor 测试完成"
Debug.Print ""
End Sub
'=====================================================================
' 辅助测试函数
'=====================================================================
Private Sub AssertEquals(testName As String, expected As String, actual As String)
If expected = actual Then
Debug.Print " PASS: " & testName
Else
Debug.Print " FAIL: " & testName & " (期望:" & expected & ", 实际:" & actual & ")"
End If
End Sub
Private Sub AssertTrue(testName As String, value As Boolean)
If value Then
Debug.Print " PASS: " & testName
Else
Debug.Print " FAIL: " & testName & " (期望:True, 实际:False)"
End If
End Sub
Private Sub AssertFalse(testName As String, value As Boolean)
If Not value Then
Debug.Print " PASS: " & testName
Else
Debug.Print " FAIL: " & testName & " (期望:False, 实际:True)"
End If
End Sub
'=====================================================================
' 过程: TestWithProvidedModels
' 功能: 使用提供的测试型号进行测试
'=====================================================================
Public Sub TestWithProvidedModels()
Debug.Print "=========================================="
Debug.Print "使用提供的测试型号进行测试"
Debug.Print "=========================================="
Debug.Print ""
Dim testModels() As String
testModels = Split( _
"YTHN-100.A0.531.G123.M04.Y3|BP-088.2312.B09.0A3," & _
"YTHN-100.BZ.531.M201.M09.Y3|BP-088.2312.M37.0A3," & _
"YTHN-100.BZ.531.M201.M08.Y3|BP-088.2312.M08.0A3," & _
"YTHN-100.A0.531.M201.M08.Y3|BP-088.2312.M08.0B3," & _
"YTHN-100.A0.531.M203.M06.Y3|BP-088.2312.M06.0A3|LSG-1.14x2.M20F.M20.3^HDJ.M20F.BW.14×2×60.3^TSFJ^WHP.70X20X1.3," & _
"YTHN-100.A0.531.M203.P21.Y3|BP-088.2312.M39.0A3|HDJ.M20F.BW.14×2×60.3^LSG-1.14x2.M20F.M20.3^TSFJ^WHP.70X20X1.3," & _
"YTHN-100.A0.531.M201.M03.N1.Y3|BP-088.2312.M31.0A4," & _
"YTHN-100.A0.531.M201.M04.Y3|BP-088.2312.M32.0A3," & _
"YTHN-100.A0.531.Z121.M07.Y3|BP-088.2312.M07.0A3," & _
"YTHN-100.A0.531.Z121.M08.Y3|BP-088.2312.M08.0A3", _
",")
Dim parser As ProductModelParser
Set parser = New ProductModelParser
Dim i As Long
For i = LBound(testModels) To UBound(testModels)
Debug.Print "型号 " & (i + 1) & ": " & testModels(i)
If parser.Parse(testModels(i)) Then
Debug.Print " 解析成功"
Debug.Print " 表头: " & parser.HeaderModel
Debug.Print " 条件: " & parser.GetAllConditions
Else
Debug.Print " 解析失败: " & parser.ErrorMessage
End If
Debug.Print ""
Next i
Debug.Print "=========================================="
Debug.Print "测试完成"
Debug.Print "=========================================="
End Sub

41
VBA/vba_metadata.json Normal file
View File

@@ -0,0 +1,41 @@
{
"source_file": "C:\\Users\\pengq\\Downloads\\AutoBOM\\AutoBOM\\YTHN-100_-_Claude3.xlsm",
"modules": {
"MainModule.bas": {
"name": "MainModule",
"type": "Modules",
"attributes": {},
"file": "Modules\\MainModule.bas"
},
"TestModule.bas": {
"name": "TestModule",
"type": "Modules",
"attributes": {},
"file": "Modules\\TestModule.bas"
},
"BomExtractor.cls": {
"name": "BomExtractor",
"type": "ClassModules",
"attributes": {},
"file": "ClassModules\\BomExtractor.cls"
},
"BomItem.cls": {
"name": "BomItem",
"type": "ClassModules",
"attributes": {},
"file": "ClassModules\\BomItem.cls"
},
"ConditionEvaluator.cls": {
"name": "ConditionEvaluator",
"type": "ClassModules",
"attributes": {},
"file": "ClassModules\\ConditionEvaluator.cls"
},
"ProductModelParser.cls": {
"name": "ProductModelParser",
"type": "ClassModules",
"attributes": {},
"file": "ClassModules\\ProductModelParser.cls"
}
}
}