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

docs: expand AutoBOM architecture and implementation details

Browse Source 
Refine project overview to include specific business context (Blaidy Company) and the main workbook file. Restructure the architecture section into a layered object-oriented design (Data, Processing, Application layers) and define the responsibilities of core VBA classes.

Add new technical documentation sections covering:
- Model number format parsing structure
- Condition expression language syntax
- Category hierarchy logic and picking strategies
- Material matching pipeline flow

Include VBA code examples for key methods such as CollectAllMaterials and GetMaterialsByCategoryAndModel to illustrate recursive traversal and material retrieval logic. Clarify the structure of key Excel configuration sheets.
This commit is contained in:
Misaka_Company
2026-01-20 13:42:03 +08:00
parent bc5ea92c52
commit a1347017e3
13 changed files with 2682 additions and 828 deletions
Download Patch File Download Diff File Expand all files Collapse all files

231
VBA/ClassModules/clsBOMManager.cls
View File

@@ -16,7 +16,7 @@ Private dictCategories As Object ' Dictionary对象: 类别名称 -> clsCateg
' 作用: 快速查找任意类别
Private dictAllMaterials As Object ' Dictionary对象: 物料代号 -> clsMaterialItem对象
' 作用: 快速查找任意物料
Private rootCategories As Collection ' Collection: 存储所有顶层类别(无父类别的类别)
Private rootCategories As collection ' Collection: 存储所有顶层类别(无父类别的类别)
' 作用: 遍历完整的类别树结构
' ========================================
@@ -26,7 +26,7 @@ Private rootCategories As Collection ' Collection: 存储所有顶层类别(无
Private Sub Class_Initialize()
Set dictCategories = CreateObject("Scripting.Dictionary")
Set dictAllMaterials = CreateObject("Scripting.Dictionary")
Set rootCategories = New Collection
Set rootCategories = New collection
End Sub
' ========================================
@@ -59,12 +59,12 @@ Public Sub LoadData(wsConfig As Worksheet, wsPlatform As Worksheet)
lastRow = wsPlatform.Cells(wsPlatform.Rows.Count, "C").End(xlUp).row
For i = 4 To lastRow ' 从第4行开始(跳过标题)
Set mat = New clsMaterialItem
mat.code = Trim(wsPlatform.Cells(i, "C").Value & "") ' 物料代号
mat.Name = Trim(wsPlatform.Cells(i, "D").Value & "") ' 物料名称
mat.code = Trim(wsPlatform.Cells(i, "C").value & "") ' 物料代号
mat.Name = Trim(wsPlatform.Cells(i, "D").value & "") ' 物料名称
On Error Resume Next
mat.Quantity = CDbl(wsPlatform.Cells(i, "E").Value) ' 物料数量
mat.Quantity = CDbl(wsPlatform.Cells(i, "E").value) ' 物料数量
On Error GoTo 0
mat.Condition = Trim(wsPlatform.Cells(i, "F").Value & "") ' 选择条件
mat.Condition = Trim(wsPlatform.Cells(i, "F").value & "") ' 选择条件
' 只保存代号非空的物料
If mat.code <> "" Then
@@ -86,9 +86,9 @@ Public Sub LoadData(wsConfig As Worksheet, wsPlatform As Worksheet)
lastRow = wsConfig.Cells(wsConfig.Rows.Count, "A").End(xlUp).row
For i = 2 To lastRow ' 从第2行开始
Dim code As String, catName As String, parentCatName As String
code = Trim(wsConfig.Cells(i, "A").Value & "") ' 物料代号
catName = Trim(wsConfig.Cells(i, "C").Value & "") ' 类别名称
parentCatName = Trim(wsConfig.Cells(i, "D").Value & "") ' 上层类别名称
code = Trim(wsConfig.Cells(i, "A").value & "") ' 物料代号
catName = Trim(wsConfig.Cells(i, "C").value & "") ' 类别名称
parentCatName = Trim(wsConfig.Cells(i, "D").value & "") ' 上层类别名称
' 跳过空行
If code = "" Then GoTo NextRow
@@ -155,7 +155,7 @@ End Sub
' Debug.Print cats(i).CategoryName
' Next i
' ========================================
Public Function GetRootCategories() As Collection
Public Function GetRootCategories() As collection
Set GetRootCategories = rootCategories
End Function
@@ -208,9 +208,9 @@ End Function
' ' 返回: 径向低压接头、弹簧管、螺旋管等零件
' ========================================
Public Function GetMaterialsForPicking(categoryName As String, _
Optional useParent As Boolean = True) As Collection
Dim result As Collection
Set result = New Collection
Optional useParent As Boolean = True) As collection
Dim result As collection
Set result = New collection
' 查找指定类别
Dim cat As clsCategory
@@ -232,8 +232,8 @@ Public Function GetMaterialsForPicking(categoryName As String, _
' - 这是正常情况下的领料方式(领取组装好的部件)
' ========================================
Dim m As clsMaterialItem
For i = 1 To cat.Materials.Count
Set m = cat.Materials(i)
For i = 1 To cat.materials.Count
Set m = cat.materials(i)
result.Add m
Next i
Else
@@ -253,7 +253,7 @@ Public Function GetMaterialsForPicking(categoryName As String, _
Dim j As Long
For j = 1 To cat.SubCategories.Count
Set subCat = cat.SubCategories(j)
Dim subMats As Collection
Dim subMats As collection
' 递归调用,继续展开子类别
Set subMats = GetMaterialsForPicking(subCat.categoryName, False)
Dim k As Long
@@ -263,8 +263,8 @@ Public Function GetMaterialsForPicking(categoryName As String, _
Next j
Else
' 叶子类别,返回本类别物料
For i = 1 To cat.Materials.Count
Set m = cat.Materials(i)
For i = 1 To cat.materials.Count
Set m = cat.materials(i)
result.Add m
Next i
End If
@@ -297,7 +297,7 @@ End Function
Public Sub PrintCategoryTree(ws As Worksheet)
Dim row As Long
row = 1
ws.Cells(row, 1).Value = "类别层级结构"
ws.Cells(row, 1).value = "类别层级结构"
row = row + 1
' 遍历所有根类别,递归打印整个树
@@ -329,19 +329,19 @@ Private Sub PrintCategory(ws As Worksheet, cat As clsCategory, _
indent = String(level * 2, " ")
' 打印类别名称和物料数量统计
ws.Cells(row, 1).Value = indent & cat.categoryName & _
" (物料数:" & cat.Materials.Count & ")"
ws.Cells(row, 1).value = indent & cat.categoryName & _
" (物料数:" & cat.materials.Count & ")"
row = row + 1
' 打印该类别下的所有物料
Dim mat As clsMaterialItem
Dim i As Long
For i = 1 To cat.Materials.Count
Set mat = cat.Materials(i)
For i = 1 To cat.materials.Count
Set mat = cat.materials(i)
' 物料行额外缩进2个空格,并加上"- "前缀
ws.Cells(row, 1).Value = indent & " - " & mat.code & " " & mat.Name
ws.Cells(row, 2).Value = "数量:" & mat.Quantity
ws.Cells(row, 3).Value = "条件:" & mat.Condition
ws.Cells(row, 1).value = indent & " - " & mat.code & " " & mat.Name
ws.Cells(row, 2).value = "数量:" & mat.Quantity
ws.Cells(row, 3).value = "条件:" & mat.Condition
row = row + 1
Next i
@@ -353,4 +353,181 @@ Private Sub PrintCategory(ws As Worksheet, cat As clsCategory, _
' 递归调用,层级加1
Call PrintCategory(ws, subCat, row, level + 1)
Next j
End Sub
End Sub
' ========================================
' GetMaterialsByModel 方法
' 功能: 根据产品型号获取符合条件的物料清单
' 参数:
' modelStr - 产品型号字符串
' categoryName - 可选，指定类别名称。为空则返回所有类别的物料
' 返回: Collection对象，包含符合条件的clsMaterialItem对象
' 示例:
' Set materials = bomMgr.GetMaterialsByModel("YTHN-100.A0.532.M203.M16.Y3")
' Set materials = bomMgr.GetMaterialsByModel("YTHN-100.A0.532.M203.M16.Y3", "部件")
' ========================================
Public Function GetMaterialsByModel(modelStr As String, _
Optional categoryName As String = "") As collection
Dim result As collection
Set result = New collection
' 1. 解析型号
Dim parser As New clsModelParser
If Not parser.ParseModel(modelStr) Then
Debug.Print "型号解析失败: " & parser.ErrorMessage
Set GetMaterialsByModel = result
Exit Function
End If
' 2. 提取条件
Dim extractor As New clsConditionExtractor
Dim conditions As Object
Set conditions = extractor.ExtractConditions(parser)
' 调试输出
Debug.Print "【型号】: " & modelStr
Debug.Print "【提取的条件】:"
Dim key As Variant
For Each key In conditions.Keys
Debug.Print " " & key & " = " & conditions(key)
Next key
Debug.Print ""
' 3. 创建条件匹配器
Dim matcher As New clsConditionMatcher
' 4. 获取要筛选的物料范围
Dim materialsToFilter As collection
Set materialsToFilter = New collection
If categoryName <> "" Then
' 指定类别：获取该类别的所有物料
Dim cat As clsCategory
Set cat = GetCategory(categoryName)
If Not cat Is Nothing Then
Dim i As Long
For i = 1 To cat.materials.Count
materialsToFilter.Add cat.materials(i)
Next i
End If
Else
' 未指定类别：获取所有根类别的物料
Dim rootCat As clsCategory
Dim j As Long
For j = 1 To rootCategories.Count
Set rootCat = rootCategories(j)
' 递归获取所有物料
Call CollectAllMaterials(rootCat, materialsToFilter)
Next j
End If
' 5. 筛选符合条件的物料
Dim mat As clsMaterialItem
Dim matchCount As Long
matchCount = 0
For Each mat In materialsToFilter
' 使用条件匹配器判断
If matcher.IsMatch(mat.Condition, conditions) Then
result.Add mat
matchCount = matchCount + 1
' 调试输出
Debug.Print "【匹配】 " & mat.code & " - " & mat.Name & _
" | 条件: " & IIf(mat.Condition = "", "(无)", mat.Condition)
End If
Next mat
Debug.Print "共匹配 " & matchCount & " 个物料"
Debug.Print String(60, "=")
Set GetMaterialsByModel = result
End Function
' ========================================
' CollectAllMaterials 方法 (私有)
' 功能: 递归收集类别及其所有子类别的物料
' 参数:
' cat - 类别对象
' collection - 用于存储物料的Collection
' ========================================
Private Sub CollectAllMaterials(cat As clsCategory, collection As collection)
Dim i As Long
' 添加当前类别的所有物料
For i = 1 To cat.materials.Count
collection.Add cat.materials(i)
Next i
' 递归处理子类别
Dim subCat As clsCategory
Dim j As Long
For j = 1 To cat.SubCategories.Count
Set subCat = cat.SubCategories(j)
Call CollectAllMaterials(subCat, collection)
Next j
End Sub
' ========================================
' GetMaterialsByCategoryAndModel 方法
' 功能: 根据类别和型号获取物料（使用父类别或子类别逻辑）
' 参数:
' modelStr - 产品型号字符串
' categoryName - 类别名称
' useParent - True=使用父类别物料，False=使用子类别物料
' 返回: Collection对象，包含符合条件的clsMaterialItem对象
' 说明: 这是 GetMaterialsForPicking 和 GetMaterialsByModel 的结合
' ========================================
Public Function GetMaterialsByCategoryAndModel(modelStr As String, _
categoryName As String, _
Optional useParent As Boolean = True) As collection
Dim result As collection
Set result = New collection
' 1. 解析型号并提取条件
Dim parser As New clsModelParser
If Not parser.ParseModel(modelStr) Then
Set GetMaterialsByCategoryAndModel = result
Exit Function
End If
Dim extractor As New clsConditionExtractor
Dim conditions As Object
Set conditions = extractor.ExtractConditions(parser)
' 2. 获取类别的物料（根据 useParent 参数）
Dim materialsToFilter As collection
Set materialsToFilter = GetMaterialsForPicking(categoryName, useParent)
' 3. 筛选符合条件的物料
Dim matcher As New clsConditionMatcher
Dim mat As clsMaterialItem
For Each mat In materialsToFilter
If matcher.IsMatch(mat.Condition, conditions) Then
result.Add mat
End If
Next mat
Set GetMaterialsByCategoryAndModel = result
End Function
' ========================================
' ParseModelAndExtractConditions 方法
' 功能: 解析型号并返回条件字典（工具方法）
' 参数: modelStr - 产品型号字符串
' 返回: Dictionary对象，包含提取的条件
' 用途: 供外部调用，用于查看提取的条件
' ========================================
Public Function ParseModelAndExtractConditions(modelStr As String) As Object
Dim parser As New clsModelParser
Dim extractor As New clsConditionExtractor
Dim conditions As Object
If parser.ParseModel(modelStr) Then
Set conditions = extractor.ExtractConditions(parser)
Else
Set conditions = CreateObject("Scripting.Dictionary")
End If
Set ParseModelAndExtractConditions = conditions
End Function

12
VBA/ClassModules/clsCategory.cls
View File

@@ -6,19 +6,19 @@ Option Explicit
Public categoryName As String
Public ParentCategoryName As String
Public Materials As Collection ' 存储 clsMaterialItem 对象
Public SubCategories As Collection ' 存储子类别 clsCategory 对象
Public materials As collection ' 存储 clsMaterialItem 对象
Public SubCategories As collection ' 存储子类别 clsCategory 对象
Public IsLeafCategory As Boolean ' 是否叶子类别(无子类别)
Private Sub Class_Initialize()
Set Materials = New Collection
Set SubCategories = New Collection
Set materials = New collection
Set SubCategories = New collection
IsLeafCategory = True
End Sub
' 添加物料
Public Sub AddMaterial(mat As clsMaterialItem)
Materials.Add mat, mat.code
materials.Add mat, mat.code
End Sub
' 添加子类别
@@ -30,7 +30,7 @@ End Sub
' 获取物料(按代号)
Public Function GetMaterial(code As String) As clsMaterialItem
On Error Resume Next
Set GetMaterial = Materials(code)
Set GetMaterial = materials(code)
On Error GoTo 0
End Function

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

@@ -0,0 +1,234 @@
' ========================================
' 类模块: clsConditionExtractor
' 用途: 从型号解析器中提取物料选择条件
' ========================================
Option Explicit
' ========================================
' 私有成员变量
' ========================================
Private m_Conditions As Object ' Dictionary: 变量名 -> 条件值
Private m_ExtractionRules As Object ' Dictionary: 提取规则配置
' ========================================
' 类初始化
' ========================================
Private Sub Class_Initialize()
Set m_Conditions = CreateObject("Scripting.Dictionary")
Set m_ExtractionRules = CreateObject("Scripting.Dictionary")
' 初始化提取规则
InitializeRules
End Sub
' ========================================
' InitializeRules 方法 (私有)
' 功能: 初始化条件提取规则
' 说明: 这里配置所有需要提取的条件及其提取方法
' ========================================
Private Sub InitializeRules()
' 规则格式: Dictionary(变量名) = Array(源字段, 提取方法)
' 规则1: 过程连接 (gclj)
' 从 ConnectionCode 中提取，去掉最后一位数字
m_ExtractionRules("gclj") = Array("ConnectionCode", "RemoveLastDigit")
' 规则2: 接液材质 (jycz)
' 从 ConnectionCode 中提取，取最后一位数字
m_ExtractionRules("jycz") = Array("ConnectionCode", "GetLastDigit")
' 规则3: 量程范围 (lcfw)
' 从 RangeCode 中直接提取
m_ExtractionRules("lcfw") = Array("RangeCode", "Direct")
' 未来可以在这里添加更多提取规则...
' 例如:
' m_ExtractionRules("bplx") = Array("DialCode", "Direct") ' 表盘类型
End Sub
' ========================================
' ExtractConditions 方法
' 功能: 从型号解析器中提取所有条件
' 参数: parser - clsModelParser对象
' 返回: Dictionary对象，包含所有提取的条件
' ========================================
Public Function ExtractConditions(parser As clsModelParser) As Object
' 清空现有条件
Set m_Conditions = CreateObject("Scripting.Dictionary")
' 验证解析器有效性
If Not parser.IsValid Then
Set ExtractConditions = m_Conditions
Exit Function
End If
' 遍历所有提取规则
Dim varName As Variant
For Each varName In m_ExtractionRules.Keys
Dim ruleInfo As Variant
ruleInfo = m_ExtractionRules(varName)
Dim sourceField As String
Dim extractMethod As String
sourceField = ruleInfo(0)
extractMethod = ruleInfo(1)
' 提取条件值
Dim conditionValue As String
conditionValue = ExtractValue(parser, sourceField, extractMethod)
' 添加到条件字典
If conditionValue <> "" Then
m_Conditions(CStr(varName)) = conditionValue
End If
Next varName
Set ExtractConditions = m_Conditions
End Function
' ========================================
' ExtractValue 方法 (私有)
' 功能: 根据规则从解析器中提取单个值
' 参数:
' parser - clsModelParser对象
' sourceField - 源字段名称
' extractMethod - 提取方法名称
' 返回: 提取的条件值
' ========================================
Private Function ExtractValue(parser As clsModelParser, _
sourceField As String, _
extractMethod As String) As String
Dim sourceValue As String
' 获取源字段值
Select Case sourceField
Case "ConnectionCode"
sourceValue = parser.ConnectionCode
Case "RangeCode"
sourceValue = parser.RangeCode
Case "ModelType"
sourceValue = parser.ModelType
Case "Diameter"
sourceValue = parser.Diameter
Case "InstallForm"
sourceValue = parser.InstallForm
Case "ShellForm"
sourceValue = parser.ShellForm
Case "Characteristics"
sourceValue = parser.Characteristics
Case Else
sourceValue = ""
End Select
' 应用提取方法
Select Case extractMethod
Case "Direct"
' 直接使用
ExtractValue = sourceValue
Case "RemoveLastDigit"
' 去掉最后一位字符
If Len(sourceValue) > 1 Then
ExtractValue = Left(sourceValue, Len(sourceValue) - 1)
Else
ExtractValue = sourceValue
End If
Case "GetLastDigit"
' 取最后一位字符
If Len(sourceValue) > 0 Then
ExtractValue = Right(sourceValue, 1)
Else
ExtractValue = ""
End If
Case "GetFirstChar"
' 取第一个字符
If Len(sourceValue) > 0 Then
ExtractValue = Left(sourceValue, 1)
Else
ExtractValue = ""
End If
Case Else
' 未知方法，返回空
ExtractValue = ""
End Select
End Function
' ========================================
' GetConditionValue 方法
' 功能: 获取单个条件值
' 参数: varName - 变量名
' 返回: 条件值，如果不存在返回空字符串
' ========================================
Public Function GetConditionValue(varName As String) As String
If m_Conditions.Exists(varName) Then
GetConditionValue = m_Conditions(varName)
Else
GetConditionValue = ""
End If
End Function
' ========================================
' AddCondition 方法
' 功能: 手动添加条件 (用于特殊情况)
' 参数:
' varName - 变量名
' value - 条件值
' ========================================
Public Sub AddCondition(varName As String, value As String)
m_Conditions(varName) = value
End Sub
' ========================================
' GetConditions 属性
' 功能: 获取所有条件的Dictionary对象
' ========================================
Public Property Get conditions() As Object
Set conditions = m_Conditions
End Property
' ========================================
' ToString 方法
' 功能: 返回条件的字符串表示 (用于调试)
' ========================================
Public Function ToString() As String
Dim result As String
result = "【提取的条件】" & vbCrLf
If m_Conditions.Count = 0 Then
result = result & " (无条件)" & vbCrLf
Else
Dim key As Variant
For Each key In m_Conditions.Keys
result = result & " " & key & " = " & m_Conditions(key) & vbCrLf
Next key
End If
ToString = result
End Function
' ========================================
' AddExtractionRule 方法
' 功能: 动态添加新的提取规则 (用于扩展)
' 参数:
' varName - 变量名
' sourceField - 源字段名称
' extractMethod - 提取方法名称
' 示例: extractor.AddExtractionRule "bplx", "DialCode", "Direct"
' ========================================
Public Sub AddExtractionRule(varName As String, _
sourceField As String, _
extractMethod As String)
m_ExtractionRules(varName) = Array(sourceField, extractMethod)
End Sub
' ========================================
' GetExtractionRules 方法
' 功能: 获取当前所有提取规则 (用于调试)
' 返回: Dictionary对象
' ========================================
Public Function GetExtractionRules() As Object
Set GetExtractionRules = m_ExtractionRules
End Function

250
VBA/ClassModules/clsConditionMatcher.cls Normal file
View File

@@ -0,0 +1,250 @@
' ========================================
' 类模块: clsConditionMatcher
' 用途: 解析物料的选择条件表达式，并判断是否匹配
' 支持: AND, OR, NOT(!=), 括号优先级
' ========================================
Option Explicit
' ========================================
' IsMatch 方法
' 功能: 判断条件表达式是否匹配
' 参数:
' conditionExpr - 条件表达式字符串
' conditions - Dictionary对象，包含变量名->值的映射
' 返回: Boolean - 是否匹配
' 示例:
' IsMatch("lcfw=M16 AND gclj=M20", conditions) -> True/False
' ========================================
Public Function IsMatch(conditionExpr As String, conditions As Object) As Boolean
On Error GoTo ErrorHandler
' 空条件表示无条件，始终匹配
If Trim(conditionExpr) = "" Then
IsMatch = True
Exit Function
End If
' 解析并计算表达式
IsMatch = EvaluateExpression(Trim(conditionExpr), conditions)
Exit Function
ErrorHandler:
' 出错时返回False（保守处理）
Debug.Print "条件匹配出错: " & conditionExpr & " - " & Err.description
IsMatch = False
End Function
' ========================================
' EvaluateExpression 方法 (私有)
' 功能: 递归计算逻辑表达式
' 优先级: 括号 > NOT(!=) > AND > OR
' ========================================
Private Function EvaluateExpression(expr As String, conditions As Object) As Boolean
expr = Trim(expr)
' 处理括号 (最高优先级)
If InStr(expr, "(") > 0 Then
EvaluateExpression = EvaluateWithParentheses(expr, conditions)
Exit Function
End If
' 处理 OR (最低优先级)
If InStr(expr, " OR ") > 0 Then
EvaluateExpression = EvaluateOR(expr, conditions)
Exit Function
End If
' 处理 AND (中等优先级)
If InStr(expr, " AND ") > 0 Then
EvaluateExpression = EvaluateAND(expr, conditions)
Exit Function
End If
' 处理单个条件 (最高优先级)
EvaluateExpression = EvaluateSimpleCondition(expr, conditions)
End Function
' ========================================
' EvaluateWithParentheses 方法 (私有)
' 功能: 处理包含括号的表达式
' 策略: 找到最内层括号，递归计算，然后替换为结果
' ========================================
Private Function EvaluateWithParentheses(expr As String, conditions As Object) As Boolean
Dim pos As Long, level As Long, startPos As Long
Dim i As Long
Dim innerExpr As String
Dim innerResult As Boolean
Dim newExpr As String
' 查找最内层的括号对
startPos = 0
level = 0
For i = 1 To Len(expr)
If Mid(expr, i, 1) = "(" Then
If level = 0 Then startPos = i
level = level + 1
ElseIf Mid(expr, i, 1) = ")" Then
level = level - 1
If level = 0 And startPos > 0 Then
' 找到一对括号
innerExpr = Mid(expr, startPos + 1, i - startPos - 1)
innerResult = EvaluateExpression(innerExpr, conditions)
' 替换括号部分为结果
newExpr = Left(expr, startPos - 1) & _
IIf(innerResult, "TRUE", "FALSE") & _
Mid(expr, i + 1)
' 递归处理剩余部分
EvaluateWithParentheses = EvaluateExpression(newExpr, conditions)
Exit Function
End If
End If
Next i
' 如果没有找到有效括号，直接计算
EvaluateWithParentheses = EvaluateExpression(expr, conditions)
End Function
' ========================================
' EvaluateOR 方法 (私有)
' 功能: 处理 OR 逻辑运算
' 规则: 任一为真则为真
' ========================================
Private Function EvaluateOR(expr As String, conditions As Object) As Boolean
Dim parts() As String
Dim part As Variant
' 按 OR 分割
parts = Split(expr, " OR ")
' 任一部分为真则返回真
For Each part In parts
If EvaluateExpression(Trim(CStr(part)), conditions) Then
EvaluateOR = True
Exit Function
End If
Next part
EvaluateOR = False
End Function
' ========================================
' EvaluateAND 方法 (私有)
' 功能: 处理 AND 逻辑运算
' 规则: 全部为真才为真
' ========================================
Private Function EvaluateAND(expr As String, conditions As Object) As Boolean
Dim parts() As String
Dim part As Variant
' 按 AND 分割
parts = Split(expr, " AND ")
' 全部部分为真才返回真
For Each part In parts
If Not EvaluateExpression(Trim(CStr(part)), conditions) Then
EvaluateAND = False
Exit Function
End If
Next part
EvaluateAND = True
End Function
' ========================================
' EvaluateSimpleCondition 方法 (私有)
' 功能: 计算单个条件表达式
' 支持: = (等于), != (不等于)
' 格式: varName=value 或 varName!=value
' ========================================
Private Function EvaluateSimpleCondition(cond As String, conditions As Object) As Boolean
cond = Trim(cond)
' 处理特殊值 TRUE/FALSE (括号计算的结果)
If UCase(cond) = "TRUE" Then
EvaluateSimpleCondition = True
Exit Function
ElseIf UCase(cond) = "FALSE" Then
EvaluateSimpleCondition = False
Exit Function
End If
Dim varName As String
Dim expectedValue As String
Dim actualValue As String
Dim isNotEqual As Boolean
' 判断是 != 还是 =
If InStr(cond, "!=") > 0 Then
isNotEqual = True
Dim parts1() As String
parts1 = Split(cond, "!=")
If UBound(parts1) < 1 Then
EvaluateSimpleCondition = False
Exit Function
End If
varName = Trim(parts1(0))
expectedValue = Trim(parts1(1))
ElseIf InStr(cond, "=") > 0 Then
isNotEqual = False
Dim parts2() As String
parts2 = Split(cond, "=")
If UBound(parts2) < 1 Then
EvaluateSimpleCondition = False
Exit Function
End If
varName = Trim(parts2(0))
expectedValue = Trim(parts2(1))
Else
' 无效的条件格式
EvaluateSimpleCondition = False
Exit Function
End If
' 获取实际值
If conditions.Exists(varName) Then
actualValue = Trim(CStr(conditions(varName)))
Else
actualValue = ""
End If
' 比较值 (不区分大小写)
Dim isEqual As Boolean
isEqual = (UCase(actualValue) = UCase(expectedValue))
' 返回结果
If isNotEqual Then
EvaluateSimpleCondition = Not isEqual
Else
EvaluateSimpleCondition = isEqual
End If
End Function
' ========================================
' TestExpression 方法
' 功能: 测试表达式是否有效 (用于调试)
' 参数: expr - 表达式字符串
' 返回: String - "有效" 或 错误信息
' ========================================
Public Function TestExpression(expr As String) As String
On Error GoTo ErrorHandler
' 创建测试条件
Dim testConditions As Object
Set testConditions = CreateObject("Scripting.Dictionary")
testConditions("gclj") = "M20"
testConditions("jycz") = "3"
testConditions("lcfw") = "M16"
' 尝试计算
Dim result As Boolean
result = IsMatch(expr, testConditions)
TestExpression = "有效 (结果: " & IIf(result, "True", "False") & ")"
Exit Function
ErrorHandler:
TestExpression = "无效: " & Err.description
End Function

229
VBA/ClassModules/clsModelParser.cls Normal file
View File

@@ -0,0 +1,229 @@
' ========================================
' 类模块: clsModelParser
' 用途: 解析产品型号，提取各部分代码
' 示例: YTHN-100.A0.532.M203.M16.Y3|BP-095.2312.M16.PA3
' ========================================
Option Explicit
' ========================================
' 公共属性
' ========================================
Public RawModel As String ' 原始完整型号
Public HeaderModel As String ' 表头型号部分
Public DialModel As String ' 表盘型号部分
Public AccessoryModel As String ' 附件型号部分
Public FlangeModel As String ' 法兰隔膜型号部分
' 表头各部分
Public ModelType As String ' 型号 (如 YTHN)
Public Diameter As String ' 公称外径 (如 100)
Public InstallForm As String ' 安装形式 (如 A0)
Public ShellForm As String ' 壳体形式 (如 532)
Public ConnectionCode As String ' 过程连接&材质代码 (如 M203)
Public RangeCode As String ' 量程范围代码 (如 M16)
Public Characteristics As String ' 仪表特性 (如 Y3)
' ========================================
' 私有变量
' ========================================
Private m_IsValid As Boolean ' 解析是否成功
Private m_ErrorMessage As String ' 错误信息
' ========================================
' ParseModel 方法
' 功能: 解析产品型号字符串
' 参数: modelStr - 完整的产品型号字符串
' 返回: Boolean - 解析是否成功
' 示例: parser.ParseModel("YTHN-100.A0.532.M203.M16.Y3|BP-095.2312.M16.PA3")
' ========================================
Public Function ParseModel(modelStr As String) As Boolean
On Error GoTo ErrorHandler
' 初始化
m_IsValid = False
m_ErrorMessage = ""
RawModel = Trim(modelStr)
' 验证输入
If RawModel = "" Then
m_ErrorMessage = "型号字符串为空"
ParseModel = False
Exit Function
End If
' 第一步: 按 | 分割各部分
Dim parts() As String
parts = Split(RawModel, "|")
If UBound(parts) >= 0 Then HeaderModel = Trim(parts(0))
If UBound(parts) >= 1 Then DialModel = Trim(parts(1))
If UBound(parts) >= 2 Then AccessoryModel = Trim(parts(2))
If UBound(parts) >= 3 Then FlangeModel = Trim(parts(3))
' 第二步: 解析表头部分 (必须存在)
If HeaderModel = "" Then
m_ErrorMessage = "表头型号为空"
ParseModel = False
Exit Function
End If
' 解析表头
If Not ParseHeader(HeaderModel) Then
ParseModel = False
Exit Function
End If
m_IsValid = True
ParseModel = True
Exit Function
ErrorHandler:
m_ErrorMessage = "解析出错: " & Err.description
m_IsValid = False
ParseModel = False
End Function
' ========================================
' ParseHeader 方法 (私有)
' 功能: 解析表头型号部分
' 格式: [型号]-[公称外径].[安装形式].[壳体形式].[过程连接&材质].[量程范围].[仪表特性]
' 示例: YTHN-100.A0.532.M203.M16.Y3
' ========================================
Private Function ParseHeader(headerStr As String) As Boolean
On Error GoTo ErrorHandler
' 按 - 分割型号和参数部分
Dim mainParts() As String
mainParts = Split(headerStr, "-")
If UBound(mainParts) < 1 Then
m_ErrorMessage = "表头格式错误: 缺少 - 分隔符"
ParseHeader = False
Exit Function
End If
' 提取型号
ModelType = Trim(mainParts(0))
' 按 . 分割参数部分
Dim params() As String
params = Split(mainParts(1), ".")
' 验证参数数量 (至少应该有5个部分)
If UBound(params) < 4 Then
m_ErrorMessage = "表头参数不足: 需要至少5个参数段"
ParseHeader = False
Exit Function
End If
' 提取各参数
Diameter = Trim(params(0)) ' 公称外径
InstallForm = Trim(params(1)) ' 安装形式
ShellForm = Trim(params(2)) ' 壳体形式
ConnectionCode = Trim(params(3)) ' 过程连接&材质
RangeCode = Trim(params(4)) ' 量程范围
' 仪表特性 (可选)
If UBound(params) >= 5 Then
Characteristics = Trim(params(5))
Else
Characteristics = ""
End If
ParseHeader = True
Exit Function
ErrorHandler:
m_ErrorMessage = "解析表头出错: " & Err.description
ParseHeader = False
End Function
' ========================================
' GetThreadCode 方法
' 功能: 从过程连接代码中提取螺纹代码
' 规则: 去掉最后一位数字
' 示例: M203 -> M20
' ========================================
Public Function GetThreadCode() As String
If ConnectionCode = "" Then
GetThreadCode = ""
Exit Function
End If
' 去掉最后一位字符 (假设最后一位是材质代码)
If Len(ConnectionCode) > 1 Then
GetThreadCode = Left(ConnectionCode, Len(ConnectionCode) - 1)
Else
GetThreadCode = ConnectionCode
End If
End Function
' ========================================
' GetMaterialCode 方法
' 功能: 从过程连接代码中提取材质代码
' 规则: 取最后一位数字
' 示例: M203 -> 3
' ========================================
Public Function GetMaterialCode() As String
If ConnectionCode = "" Then
GetMaterialCode = ""
Exit Function
End If
' 取最后一位字符
GetMaterialCode = Right(ConnectionCode, 1)
End Function
' ========================================
' GetRangeCode 方法
' 功能: 获取量程代码
' 规则: 直接返回
' 示例: M16 -> M16
' ========================================
Public Function GetRangeCode() As String
GetRangeCode = RangeCode
End Function
' ========================================
' IsValid 属性
' 功能: 返回解析是否成功
' ========================================
Public Property Get IsValid() As Boolean
IsValid = m_IsValid
End Property
' ========================================
' ErrorMessage 属性
' 功能: 返回错误信息
' ========================================
Public Property Get ErrorMessage() As String
ErrorMessage = m_ErrorMessage
End Property
' ========================================
' ToString 方法
' 功能: 返回解析结果的字符串表示 (用于调试)
' ========================================
Public Function ToString() As String
Dim result As String
result = "【型号解析结果】" & vbCrLf
result = result & "原始型号: " & RawModel & vbCrLf
result = result & "表头型号: " & HeaderModel & vbCrLf
result = result & "表盘型号: " & DialModel & vbCrLf
result = result & vbCrLf
result = result & "【表头各部分】" & vbCrLf
result = result & " 型号: " & ModelType & vbCrLf
result = result & " 公称外径: " & Diameter & vbCrLf
result = result & " 安装形式: " & InstallForm & vbCrLf
result = result & " 壳体形式: " & ShellForm & vbCrLf
result = result & " 过程连接&材质: " & ConnectionCode & vbCrLf
result = result & " 量程范围: " & RangeCode & vbCrLf
result = result & " 仪表特性: " & Characteristics & vbCrLf
result = result & vbCrLf
result = result & "【提取代码】" & vbCrLf
result = result & " 螺纹代码: " & GetThreadCode() & vbCrLf
result = result & " 材质代码: " & GetMaterialCode() & vbCrLf
result = result & " 量程代码: " & GetRangeCode() & vbCrLf
ToString = result
End Function