试试下面的代码：
Option Explicit
Sub Test()
Dim sData As String
Dim oData As Object
' Read data from file
sData = ReadTextFile(CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\sample.txt", -1)
' Parse text data to structured nested dictionaries
Set oData = ParseData(sData)
' Test
Debug.Print oData("PRODUCT")(0)("label")
Debug.Print oData("equipment")(0)("size")
Debug.Print oData("equipment")(0)("wt")
Debug.Print oData("equipment")(0)("quality")
Debug.Print oData("rent")(0)("dist")
Debug.Print oData("rent")(0)("index")
Debug.Print oData("rent")(0)("tp")
Debug.Print oData("rent")(1)("dist")
Debug.Print oData("rent")(1)("index")
Debug.Print oData("rent")(1)("tp")
Debug.Print oData("rent")(2)("dist")
Debug.Print oData("rent")(2)("index")
Debug.Print oData("rent")(2)("tp")
End Sub
Function ParseData(sContent As String) As Object
Dim spN As String
Dim spQ As String
Dim sDelim As String
Dim aSections
Dim oSections As Object
Dim aSection
Dim aParams
Dim oSection As Object
Dim i As Long
Dim sParam
Dim aValues
Dim v
spN = "[+-]?(?:\d+\.\d*|\.\d+|\d+)(?:e[+-]?\d+)?" ' pattern for number
spQ = "'[^']*'|""(?:\\""|[^""])*""" ' pattern for quoted string
sDelim = Mid(1 / 2, 2, 1) ' regional decimal delimiter
' Extract each section
ParseResponse "^([\w ]*?)((?: \w* ?\= ?(?:" & spN & "|" & spQ & "))+)$", sContent, aSections, False
' aSections - sections array
' Create dictionary for sections
Set oSections = CreateObject("Scripting.Dictionary")
' Process each section
For Each aSection In aSections
' aSection - section array
' aSection(0) - section name
' aSection(1) - section content
' Extract each parameter
ParseResponse "(\w* ?\= ?(?:" & spN & "|" & spQ & "))", aSection(1), aParams, False
' aParams - parameters array
' Create dictionary for current section entries if not exists
If Not oSections.Exists(aSection(0)) Then Set oSections(aSection(0)) = CreateObject("Scripting.Dictionary")
' Current section entries
Set oSection = oSections(aSection(0))
' Current section entry index
i = oSection.Count
' Create new section entry and dictionary for parameters
Set oSection(i) = CreateObject("Scripting.Dictionary")
' Process each parameter
For Each sParam In aParams
' sParam - parameter string
' Extract values
ParseResponse "(\w*) ?\= ?(?:(" & spN & ")|(" & spQ & "))", sParam, aValues, False, False
' aValues - name and value array
' aValues(0) - parameter name
' aValues(1) - parameter numeric value
' aValues(2) - parameter string value
' Evaluating value as number or string
If IsEmpty(aValues(2)) Then ' Number
v = CDbl(Replace(aValues(1), ".", sDelim))
Else ' Quoted string
v = Mid(aValues(2), 2, Len(aValues(2)) - 2)
End If
' Assign value to section entry parameter name
oSection(i)(aValues(0)) = v
Next
Next
Set ParseData = oSections
End Function
Sub ParseResponse(sPattern, sResponse, aData, Optional bAppend As Boolean = True, Optional bNestSubMatches = True, Optional bGlobal = True, Optional bMultiLine = True, Optional bIgnoreCase = True)
Dim oMatch
Dim aTmp0()
Dim sSubMatch
If Not (IsArray(aData) And bAppend) Then aData = Array()
With CreateObject("VBScript.RegExp")
.Global = bGlobal
.MultiLine = bMultiLine
.IgnoreCase = bIgnoreCase
.Pattern = sPattern
For Each oMatch In .Execute(sResponse)
If oMatch.SubMatches.Count = 1 Then
PushItem aData, oMatch.SubMatches(0)
Else
If bNestSubMatches Then
aTmp0 = Array()
For Each sSubMatch In oMatch.SubMatches
PushItem aTmp0, sSubMatch
Next
PushItem aData, aTmp0
Else
For Each sSubMatch In oMatch.SubMatches
PushItem aData, sSubMatch
Next
End If
End If
Next
End With
End Sub
Sub PushItem(aData, vItem, Optional bAppend As Boolean = True)
If Not (IsArray(aData) And bAppend) Then aData = Array()
ReDim Preserve aData(UBound(aData) + 1)
aData(UBound(aData)) = vItem
End Sub
Function ReadTextFile(sPath As String, lFormat As Long) As String
' lFormat -2 - System default, -1 - Unicode, 0 - ASCII
With CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath, 1, False, lFormat)
ReadTextFile = ""
If Not .AtEndOfStream Then ReadTextFile = .ReadAll
.Close
End With
End Function
为了测试，我将文件 sample.txt 保存为桌面上的 Unicode 内容：
PRODUCT label = 'Equipment XS'
equipment size = 9.75 wt = 0.5 quality = 0.001969
rent dist = 0 index = 40.774278 tp = 48
rent dist = 50 index = 0 tp = 48
rent dist = 130 index = 0 tp = 60
我的输出如下：