XenoEngineer at 00:30, 24 July 2023

2023-07-24T00:30:03Z

@@ Line 2: / Line 2: @@
 {{headerQATcode| &mdash;Warehouse Class Code}}
 [[Category:QAT.clsWhse]]
 Option Explicit ' Forces variable declaration in the compile.
@@ Line 258: / Line 259: @@
 End Function
 Public Function TrimTrailingCharacters(ByRef Source As String, ByVal Characters As String) As String
@@ Line 793: / Line 711: @@
-</div>
+</pre>

XenoEngineer: Created page with "{{headerQuasiAI|subcat=QAT.code}} {{headerQATcode| —Warehouse Class Code}} Category:QAT.clsWhse
Option Explicit ' Forces variable declaration in the compile. ' Publicly visible 'Events' raised to callback-functions from within this class. Public Event CommandResponse(ByVal Message As String) ' In-class functions communicate functional-process outcome to..."

2023-07-14T11:43:48Z

Created page with "{{headerQuasiAI|subcat=QAT.code}} {{headerQATcode| —Warehouse Class Code}} Category:QAT.clsWhse <div style="background:azure; border:1px outset azure; margin:1em 2em; padding:0 1em; width:888px;"> Option Explicit ' Forces variable declaration in the compile. ' Publicly visible 'Events' raised to callback-functions from within this class. Public Event CommandResponse(ByVal Message As String) ' In-class functions communicate functional-process outcome to..."

New page

{{headerQuasiAI|subcat=QAT.code}}
{{headerQATcode| —Warehouse Class Code}}
[[Category:QAT.clsWhse]]

<div style="background:azure; border:1px outset azure; margin:1em 2em; padding:0 1em; width:888px;">
Option Explicit ' Forces variable declaration in the compile.

' Publicly visible 'Events' raised to callback-functions from within this class.
Public Event CommandResponse(ByVal Message As String) ' In-class functions communicate functional-process outcome to interface-code for interface-updates.
Public Event DataLoaded(ByRef oFile As clsFile) ' This class instance will call the 'DataLoaded' form module 'event code'.
Public Event ConjectureChanged(ByVal ConjColumnAtom As Long, ByVal ConjColumnLink As Long)

Public Event AtomsExtracted()
Public Event MartPulled()
Public Event PairsExported()
Public Event WarehouseUnloaded()

Public Event Progress(ByRef msg As String)

' Properties
Private mstrDataFile As String
Private mlngDataRowCount As Long
Private mlngDataHeaderRowIndex As Long ' An index pointing within a zero-based array to a data row with column-header captions.
Private mstrDataRowDelimiter As String
Private mstrDataColumnDelimiter As String

Private mlngConjAtomColumn As Long
Private mlngConjLinkColumn As Long

Private mbooCancel As Boolean ' Checked in long iterations: Combinatoric generation per Atom-Link conjecture match.

' Class state (code in this class that toggles these state variables also raise an 'event').
Private mbooDataLoaded As Boolean
Private mbooConjValid As Boolean
Private mbooMartPulled As Boolean
Private mbooAtomsExtracted As Boolean
Private mbooLinksExtracted As Boolean
Private mbooPairsExported As Boolean

' Class data arrays
Private mstrDataArray() As String ' array of data rows
Private mstrDataHeaderRow() As String ' array of data header-row fields (1st row from file)
Private mstrMartArray() As String ' array column data selected by Conjecture options

' Processed data arrays
Private mstrPairsArray() As String ' Atom pairs of ColA sharing Links
Private mstrLinksArray() As String ' Links of ColB per Atom

Private mcolAtoms() As String ' Hash array of VB String values as a Microsoft VB 6 keyed-collection object.

Private Sub Class_Initialize()
On Error Resume Next
End Sub

Private Sub Class_Terminate()
On Error Resume Next
End Sub

Public Function Combinatorics(ByVal TabularString As String) As String()

' Return a string array loaded with all the combinations of SecNames
' in TabularString, ignoring the first tabular string entry, which is an Atom FirstName
Dim maxName As Long
Dim maxNdx As Long
Dim moduloNdx As Long
Dim strCombinations() As String 'array
Dim strNames() As String 'array
Dim ndxCombination As Long
Dim j, k, intLast As Integer

On Error Resume Next

' TabularString format (Paired)
' FirName Tab SecName1 Tab SecName2 Tab SecName3...

With New clsStopWatch
.Reset

TrimTrailingCharacters TabularString, vbTab

strNames = Split(TabularString, vbTab)
'Note: the first array element is a firstName, not to be combined

maxName = UBound(strNames)
maxNdx = maxName

If maxName > 1 Then ' 0,1 and 2 elements -- 0= FirName; 1,2= Secnames

' Redim to something larger than typically expected
' Redim again later to size used after loading array
ReDim strCombinations(maxName * maxName)

'Debug.Print vbCrLf & "Combining FirName: " & strNames(0)

If mbooCancel Then Exit Function

If maxName > 1 Then ' very key factor
' Key factor: if maxName is larger than two (larger than 1 for zero-based array elements)
' then at least a pair of mart rows matching columns A-Names
' are sharing a B-Name
For k = 1 To maxName - 1 ' Start with element 1 of the zero-based strNames() array.
DoEvents

For j = 1 To (maxName - k)
' Check array size and redim if more elements are needed
If ndxCombination > maxNdx Then
maxNdx = maxNdx + 1000
ReDim Preserve strCombinations(maxNdx)
'Debug.Print "maxNdx: " & maxNdx
End If

' Add the combination to the output array
strCombinations(ndxCombination) = strNames(k) & "**" & strNames(k + j)

'Debug.Print "(" & CStr(k) & ")-(" & CStr(k + j) & ") = " & strCombinations(ndxCombination)
ndxCombination = ndxCombination + 1
If moduloNdx Mod 5 = 0 Then
RaiseEvent Progress("Expanding combinatorics: " & CStr(moduloNdx))
DoEvents
If mbooCancel Then Exit Function
End If
Next
moduloNdx = moduloNdx + 1
Next

' Redim the combinations array to the size used
ReDim Preserve strCombinations(ndxCombination - 1)

' Return the array
Combinatorics = strCombinations

End If 'maxName
Else
'Debug.Print vbCrLf & "Skipping"
End If
End With 'New clsStopWatch

End Function

Public Function EnumeratedColumnNames(HeaderArray As Variant) As String
Dim ndx, maxNdx As Integer
Dim duplicateArray() As String 'array
'todo: work this out better
If Not IsArray(HeaderArray) Then Exit Function
maxNdx = UBound(HeaderArray)

ReDim duplicateArray(maxNdx)

For ndx = 0 To maxNdx
duplicateArray(ndx) = CStr(ndx) & vbTab & HeaderArray(ndx)
Next
' Return a string transform of array
' elements delimited by CRLF
EnumeratedColumnNames = Join(duplicateArray, vbCrLf)

End Function

Public Sub QuickSortVariants( _
vArray As Variant, _
inLow As Long, _
inHi As Long, _
ByRef ndx As Long, _
ByRef maxNdx As Long)

Dim pivot As Variant
Dim tmpSwap As Variant
Dim tmpLow As Long
Dim tmpHi As Long

tmpLow = inLow
tmpHi = inHi

' Increment completion counter
ndx = ndx + 1

pivot = vArray((inLow + inHi) \ 2)

Me.Cancel = False

While (tmpLow <= tmpHi) And Not Me.Cancel

While (vArray(tmpLow) < pivot And tmpLow < inHi)
tmpLow = tmpLow + 1
Wend

While (pivot < vArray(tmpHi) And tmpHi > inLow)
tmpHi = tmpHi - 1
Wend

If (tmpLow <= tmpHi) Then
tmpSwap = vArray(tmpLow)
vArray(tmpLow) = vArray(tmpHi)
vArray(tmpHi) = tmpSwap
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
If ndx Mod 100 = 0 Then
RaiseEvent Progress("Sort percentage remaining: " & CStr(CInt((1 - (ndx / maxNdx)) * 10000) / 100))
DoEvents
End If
End If

Wend

If (inLow < tmpHi) Then QuickSortVariants vArray, inLow, tmpHi, ndx, maxNdx
If (tmpLow < inHi) Then QuickSortVariants vArray, tmpLow, inHi, ndx, maxNdx

End Sub

Public Property Get LinkCount() As Long
On Error Resume Next

LinkCount = UBound(mstrLinksArray)
End Property

Public Function ConjectureCreate( _
ByVal AtomColumn As Long, _
ByVal LinkColumn As Long _
) As Boolean

' Return True if columns are in range, and not equal.
' Quietly persist columns set to the INI file.

Dim MaxColumn As Integer
Dim x() As String

On Error Resume Next

If Not Me.DataLoaded Then
RaiseEvent CommandResponse("Conjecture column cannot be set until the Data is loaded.")
Else
MaxColumn = UBound(Split(mstrDataArray(0), vbTab)) ' Zero-based array split on the first row in the whse data.

' Validate input (false case)
Select Case False
Case (AtomColumn >= 0)
Case (AtomColumn <= MaxColumn)
Case (LinkColumn >= 0)
Case (LinkColumn <= MaxColumn)
Case (LinkColumn <> AtomColumn)
Case Else
' Proceed with validated inputs.
' Store the column indexes.
mbooConjValid = True

mlngConjAtomColumn = AtomColumn
mlngConjLinkColumn = LinkColumn

' Save the conjecture columns.
INIWrite "Preferences", "ConjAtomColumnIndex", mlngConjAtomColumn
INIWrite "Preferences", "ConjLinkColumnIndex", mlngConjLinkColumn

End Select
End If 'me.DataLoaded
End Function

'public Function iFnData_ExtractAtoms(Optional ByVal TopicName As String = "A1") As Boolean
' Dim ndx As Long
' Dim lngCount As Long
' Dim strSplitPairs() As String 'array
'
' Dim lngLength As Long
' Dim strAtom As String
' Dim strPairs As String
' Dim intExtractions As Integer
'
' On Error Resume Next
'
' Screen.MousePointer = vbHourglass
'
' RaiseEvent CommandResponse("Extracting unique members from Paired.txt...")
'
'
' ' Flatten the inner and outer delimiters to the same (Replace "**" with CRLF )
' strPairs = Replace(strPairs, "**", vbCrLf)
'
' ' Split the delimited members to an array
' strSplitPairs = Split(strPairs, vbCrLf)
'
' ' Loop through array, checking for new Members from Pairs
' lngCount = UBound(strSplitPairs)
' For ndx = 0 To lngCount
' ' Test that the array element is in the Atoms buffer
'' If InStr(1, mstrAtomsStringBuffer, strSplitPairs(ndx)) = 0 Then 'not there
'' ' Concatenate the new randomized atom to the buffer at the beginning
'' mstrAtomsStringBuffer = strSplitPairs(ndx) & vbTab & CStr(Int(Rnd * 360) + 1) & vbCrLf & mstrAtomsStringBuffer
'' intExtractions = intExtractions + 1
'' End If
' Next
'
' ' Remove the trailing delimiter
' 'mstrAtomsStringBuffer = Left$(mstrAtomsStringBuffer, Len(mstrAtomsStringBuffer) - 1)
'
' ' The reduced set of Pairs is now a unique set of delimited Atoms in mstrAtomsStringBuffer.
'
' ' Write the fresh Members data to file as the Members of the top Topic named
' ' the value in 'TopicName' in a folder named by the value in 'TopicName'
' With New clsFile
'
' ' Create a new top distribution if non-existant,
' ' or query the user for overwrite permission,
' ' else bail, no persistence -- no existence
' Select Case .FileExists(mstrDataPath & "\" & TopicName & "\Members.txt")
'
' Case True
'
' If MsgBox("Overwrite the Members.txt file for Topic " & TopicName & "?", vbYesNo + vbQuestion + vbDefaultButton2, "Random distribution available") = vbYes Then
' If .Save(mstrAtomsStringBuffer, UseAppend:=False) Then
' ' Create (or err past if existing) a folder for the top node, named A1
' iFnData_ExtractAtoms = True
' Else
' RaiseEvent CommandResponse("Unable to save the Atoms extracted from Paired.txt to " & .Filespec)
' MsgBox "Unable to save the Atoms extracted from Paired.txt to: " & .Filespec
' End If
' End If
'
' Case False
'
' ' Create the new Topic Folder
' MkDir Root.DataPath & "\" & TopicName
'
'
' If .Save(mstrAtomsStringBuffer) Then
' RaiseEvent CommandResponse("Extracted Atoms saved to " & .Filespec)
' iFnData_ExtractAtoms = True
' Else
' RaiseEvent CommandResponse("Unable to save the Atoms extracted from Paired.txt to: " & .Filespec)
' MsgBox "Unable to save the Atoms extracted from Paired.txt to: " & .Filespec
' End If
'
' End Select
' End With
'
' RaiseEvent CommandResponse("Extraction of member atoms complete. " & CStr(intExtractions) & " members extracted.")
'
' Screen.MousePointer = vbDefault
'
'End Function

Public Function TrimTrailingCharacters(ByRef Source As String, ByVal Characters As String) As String

' Remove trailing characters passed by argument
Do While StrComp(Right$(Source, Len(Characters)), Characters) = 0
Source = Left$(Source, Len(Source) - Len(Characters))
Loop

TrimTrailingCharacters = Source
End Function

Public Function DataLoad(ByRef TabularString As String) As Boolean

On Error GoTo Trap

' String passed by reference, avoiding memory copy. The calling function destroys passed String.
' Remove any trailing row-delimiters while looping.
Do While StrComp(Right$(TabularString, 2), vbCrLf) = 0
' Remove trailing row delimiters.
TabularString = Left$(TabularString, Len(TabularString) - 2)
Loop

' Split the input String into the Data row-array at the row delimiters.
mstrDataArray = Split(TabularString, DataRowDelimiter)
mlngDataRowCount = UBound(mstrDataArray) ' Zero-based array index of the last data row read.

mbooDataLoaded = CBool(UBound(mstrDataArray) > 0) ' Loaded only if more than header record exists.

' Return outcome.
DataLoad = mbooDataLoaded

Exit Function
Trap:
Select Case Err.number
Case Else
MsgBox "DataLoad() Failure: " & formatErrorMsg(Err.number, Err.description, Err.Source), vbExclamation + vbOKOnly, "I/O error"
End Select
End Function

Public Property Get ConjAtomColumnIndex() As Long
ConjAtomColumnIndex = mlngConjAtomColumn
End Property
Public Property Let ConjAtomColumnIndex(ByVal Value As Long)
mlngConjAtomColumn = Value
End Property

Public Property Get ConjLinkColumnIndex() As Long
ConjLinkColumnIndex = mlngConjLinkColumn
End Property

Public Property Let ConjLinkColumnIndex(ByVal Value As Long)
mlngConjLinkColumn = Value
End Property

Public Property Get ConjValid() As Boolean
ConjValid = mbooConjValid
End Property

Public Property Get DataRowCount() As Long
On Error Resume Next

If mbooDataLoaded Then DataRowCount = UBound(mstrDataArray) - mlngDataHeaderRowIndex + 1 ' Zero-based data array.
End Property

Public Function FieldValue(ByVal Row As Long, ByVal Column As Long) As String
On Error Resume Next

FieldValue = Split(mstrDataArray(Row), DataColumnDelimiter)(Column)
End Function

Public Property Let DataColumnDelimiter(ByVal Value As String)
mstrDataColumnDelimiter = Value
End Property
Public Property Get DataColumnDelimiter() As String
DataColumnDelimiter = mstrDataColumnDelimiter
End Property

Public Property Let DataRowDelimiter(ByVal Value As String)
mstrDataRowDelimiter = Value
End Property
Public Property Get DataRowDelimiter() As String
DataRowDelimiter = mstrDataRowDelimiter
End Property

Public Function LoadWarehouse(Optional ByVal FileName As String) As Long
On Error GoTo Trap
' FileName must be a useable filespec (path and filename).
' Return the Data row count on success.

If Len(FileName) > 0 Then
mstrDataFile = FileName ' Save FileName passed.

With New clsFile
If .FileExists(FileName) Then
If DataLoad(.ReadAll(mstrDataFile)) Then
LoadWarehouse = Me.DataRowCount 'at least 1 more row than header row qualifies as loaded
RaiseEvent DataLoaded(.Self)
Else
RaiseEvent CommandResponse("Unable to load Warehouse data from " & mstrDataFile)
End If
Else
MsgBox "Warehouse Data File Not Found: " & .Filespec, vbInformation
RaiseEvent CommandResponse("File not found: " & .Filespec)
End If
End With

End If

Exit Function
Trap:
Select Case Err.number
Case Else
MsgBox "LoadWarehouse: " & formatErrorMsg(Err.number, Err.description, Err.Source)
Exit Function
Resume ' debugging
End Select
End Function

Public Property Get MaxColumn() As Integer
On Error Resume Next

If mbooDataLoaded Then
MaxColumn = UBound(Split(mstrDataArray(0), vbTab))
End If
End Property

Public Property Let Cancel(ByVal Value As Boolean)
mbooCancel = Value
End Property

Public Property Get Cancel() As Boolean
Cancel = mbooCancel
End Property

Public Function Clear() As Boolean
On Error Resume Next

ReDim mstrDataArray(0)
ReDim mstrDataHeaderRow(0)

ReDim mstrMartArray(0)
ReDim mstrPairsArray(0)
ReDim mstrLinksArray(0)

Clear = CBool(Err.number)
End Function

Public Property Get MartCount() As Long
On Error Resume Next

If mbooMartPulled Then MartCount = UBound(mstrMartArray) + 1
End Property

' Enumerate all Warehouse records, pulling the
' combined conjecture columns into the Mart array.
Public Function MartPull() As Boolean
Dim ndx As Long
Dim maxNdx As Long
Dim strField() As String 'array
Dim msg As String

On Error Resume Next

' Store the max array index for enumeration
maxNdx = UBound(mstrDataArray)

' Size the Mart array to the warehouse size
ReDim mstrMartArray(maxNdx)

' Check for contextual validity
If (mlngConjAtomColumn > -1) And (mlngConjLinkColumn > -1) Then
' Enumerate all Warehouse records, pulling the
' combined conjecture columns into the Mart array.

For ndx = 0 To maxNdx 'including header at 0
' Split the record into strField array at the inner delimiter
strField = Split(mstrDataArray(ndx), DataColumnDelimiter)

' Copy into the Mart array the two fields specified by conjecture
mstrMartArray(ndx) = strField(mlngConjLinkColumn) & _
DataColumnDelimiter & _
strField(mlngConjAtomColumn) ' B <Tab> A
Next ndx

' Sort the new Mart array, now in natural order from Whse
QuickSortVariants mstrMartArray, 1, UBound(mstrMartArray), 0, UBound(mstrMartArray)

' Join all array elements into a string with line delimiters streaming to file
With New clsFile
.Filespec = DataFolder & "\Mart.txt"

' Save the Mart in the data path as a
' Column/Line delimited tabulation of string data.

If .Save(Join(SourceArray:=mstrMartArray, delimiter:=mstrDataRowDelimiter)) Then
mbooMartPulled = True
MartPull = True
RaiseEvent CommandResponse("Mart columns pulled, and saved to file")
RaiseEvent MartPulled
Else
msg = "Unable to save the Mart data to file " & .Filespec
End If
End With

Else
RaiseEvent CommandResponse("Mart cannot be Pulled until both conjectures are selected, i.e., A = 4 <CR> B = 5 <CR>")
End If

End Function

Public Property Get MartPulled() As Long
MartPulled = mbooMartPulled
End Property

Public Function DataRowArray(ByVal Index As Long) As String()
On Error Resume Next
DataRowArray = Split(mstrDataArray(Index), DataColumnDelimiter)
End Function

Public Property Get DataColumnHeaders() As String()
On Error Resume Next
If mbooDataLoaded Then DataColumnHeaders = Split(mstrDataArray(0), mstrDataColumnDelimiter)
End Property

Public Property Get PairsCount() As Long
On Error Resume Next
If mbooPairsExported Then PairsCount = UBound(mstrPairsArray) + 1 'element zero contians column headers
End Property

Public Property Get PairsExported() As Long
PairsExported = mbooPairsExported
End Property

Public Function PairsExport() As Boolean
Dim oFile As clsFile
Dim ndx As Long
Dim strField() As String 'array
Dim colAtoms As Collection
Dim colLinks As Collection
Dim strPaired As String
Dim strJoin As String
Dim varX As Variant

' Atom format (Paired)
' FirName Tab SecName1 Tab SecName2 Tab ... SecNameX

On Error GoTo Trap

mbooCancel = False

Set colAtoms = New Collection
Set colLinks = New Collection

With New clsStopWatch
If mbooMartPulled Then
.Reset ' Start timer
RaiseEvent Progress("Pairs Export beginning...")
' Enumerate through all Mart array row elements
' and construct the Atoms.
For ndx = 1 To Me.MartCount - 1
DoEvents 'allowing update of cancellation flag during loop
If Not mbooCancel Then
' Split the outer Mart-array row element into an inner field-array
strField() = Split(mstrMartArray(ndx), vbTab)

' Add a new firName to colAtoms
MergeSecNameByFirName colAtoms, strField(0), strField(1)

If ndx Mod 100 = 0 Then
RaiseEvent Progress("Assembling atoms: record " & CStr(ndx))
End If
Else
Exit Function
End If 'Not mbooCancelPairs
Next

' Enumerate through all Mart array row elements
' and construct the Links.
For ndx = 1 To Me.MartCount - 1
DoEvents 'allowing update of cancellation flag during loop
If Not mbooCancel Then
' Split the outer Mart-array row element into an inner field-array
strField() = Split(mstrMartArray(ndx), vbTab)

' Add a new SecName to colLinks (notice the parameters are switched)
MergeSecNameByFirName colLinks, strField(1), strField(0) ' sort when complete

If ndx Mod 100 = 0 Then RaiseEvent Progress("Assembling links: record " & CStr(ndx) & "+")
Else
Exit Function
End If 'Not mbooCancelPairs
Next

' Output the Links as tabular data
ndx = 0
ReDim mstrLinksArray(colLinks.Count - 1)

' Copy the collection object
' into the module links array
ndx = 0
For Each varX In colLinks
mstrLinksArray(ndx) = varX
ndx = ndx + 1
Next

' Sort the new Links array, purely for human-readability, as order is irrelavant.
QuickSortVariants mstrLinksArray, 0, UBound(mstrLinksArray), 0, UBound(mstrLinksArray)

' Store the array as a CR delimited
' tabular file named Links.txt
With New clsFile
.Save Join(mstrLinksArray, vbCrLf), DataFolder & "\Links.txt"
End With
RaiseEvent CommandResponse(CStr(ndx) & " Link saved as tabular data to file " & DataFolder & "\Links.txt")

' Create the paired combinatorics

' Enumerate atomics, creating a tabulation
' by string-concatenation of any new combinatrics
' joined from the array returned by the
' transform method producing combinatorics.
ndx = 0
For Each varX In colAtoms
strJoin = Join(Combinatorics(varX), vbCrLf)
If Len(strJoin) Then
If Len(strPaired) = 0 Then
strPaired = strJoin
Else
strPaired = strPaired & vbCrLf & strJoin
End If
End If

If ndx Mod 10 = 0 Then RaiseEvent Progress("Combining atom " & CStr(ndx) & "...")
ndx = ndx + 1
Next

' Store the Pairs tabular string data as a string array
mstrPairsArray = Split(strPaired, vbCrLf)

' Sort the new Pairs array
QuickSortVariants mstrPairsArray, 0, UBound(mstrPairsArray), 0, UBound(mstrPairsArray)
RaiseEvent CommandResponse("Pairs sorted")

' Transform the array, now sorted
' to a string for storage to file
strPaired = Join(mstrPairsArray, vbCrLf)

' Save the Pairs array to file
Set oFile = New clsFile
oFile.Filespec = DataFolder & "\Paired.txt"
If oFile.Save(Join(mstrPairsArray, vbCrLf)) Then

mbooPairsExported = True
PairsExport = mbooPairsExported
RaiseEvent CommandResponse("Pairs saved as " & DataFolder & "\Paired.txt")

RaiseEvent CommandResponse("Combinatoric-pairs Export complete (Process time: " & CStr(.Elapsed / 1000) & ")")

End If
Else 'mbooMartPulled
RaiseEvent CommandResponse("Unable to Export combinatoric-pairs because the Mart Columns have not been pulled")
End If 'mbooMartPulled
End With 'New clsStopWatch

Exit Function
ExitPoint:
Set colAtoms = Nothing
Set colLinks = Nothing
Exit Function

Trap:
RaiseEvent CommandResponse("Error in clsWhse.PairsExport: " & Err.description)
Resume ExitPoint
Resume
End Function

Public Sub MergeSecNameByFirName( _
ByVal col As Collection, _
ByVal FirName As String, _
ByVal SecName As String _
)
' Note! July 2023, twenty three years later...
' The first parameter 'ByVal' is ignored and the 'col' collection
' is passed by reference. This never threw an error.
' The line should read:
' "ByRef col As Collection, _"
'
' Build a unique collection of Firname record delimitations
' Append uniquely the secname into the Tab-delimited
' string value referenced by the collection member, keyed by Firname

' The collection members delimited format is follows:
' FirName Tab SecName1 Tab SecName2 Tab SecName3 ...

Dim strElements As String

On Error Resume Next

'Add a new member keyed by FirName...
col.Add FirName & vbTab & SecName, Key:=FirName

'This errors if member already exists -used because VB Collection object has no 'exists' function.

If Err.number = 457 Then
' Exists already, so concatentate SecName to existing SecNames if not already there
strElements = col.Item(CStr(FirName))

' Append uniquely the secname to the secname delimitation
If InStr(1, strElements, SecName) = 0 Then
'secname is not already in strSecNames, so concatenate it
strElements = Join(Array(strElements, SecName), vbTab)

col.Remove FirName
col.Add strElements, FirName

End If
End If

End Sub

Public Property Get AtomsExtracted() As Boolean
AtomsExtracted = mbooAtomsExtracted
End Property

Public Property Get DataFile() As String
DataFile = mstrDataFile
End Property
Public Property Let DataFile(ByVal Value As String)
mstrDataFile = Value
End Property

Public Property Get DataFolder() As String ' r/o
DataFolder = FileFolder(mstrDataFile)
End Property

Public Property Get DataLoaded() As Boolean
DataLoaded = mbooDataLoaded
End Property

Public Property Get DataHeaderRowIndex() As Long
DataHeaderRowIndex = mlngDataHeaderRowIndex
End Property
Public Property Let DataHeaderRowIndex(ByVal Value As Long)
mlngDataHeaderRowIndex = Value
End Property

</div>

QAT Code: Whse Class - Revision history

XenoEngineer at 00:30, 24 July 2023