Subject: RE: List of List as Variant… HELP!
Not really sure if it’ll help, but here is container-type class that I wrote in an attempt to mimic some of the functionality available in the Java HashMap. It may be a bit over-kill, but maybe it’ll at least get your wheels going. Sorry my code isn’t nicely formatted & colorized like Rod’s!dgg
‘////////////////////////////////////////////////////////////////////////////////////////////////////////////’// Class name: LSHashMap
'// Description: A HashMap-like container object for LotusScript use.
'// Author: Dallas Gimpel
'// Date: 12/15/2003
'//
'// Public Properties:
'// CLASS_NAME - String constant, name of class
'// CR - String constant, default character(s) to use for a carriage return
'// GetStackTrace - String, a “stack trace” generated in the event of an error
'// Size - Long, the size (base 1) of the underlying array backing the HashMap
'// ContainsKey - Boolean, true if the HashMap contains the key passed, otherwise false
'// KeyPosition - Long, returns the position (base 1) of the key passed OR -1 if key isn’t found
'// Keys - Variant, underlying array that backs the HashMap if set, empty if not
'// IsVoid - Boolean, false if the HashMap contains at least one value, otherwise true
'//
'// Public Methods:
'// New - class constructor
'// Delete - class destructor
'// Clear - Boolean, clears current values (thus freeing memory occupied) and returns true
'// unless an error is encountered
'// RemoveElement - Boolean, clears the value for the key specified if contained in the HashMap
'// and returns true unless an error is encountered, otherwise returns false
'// RemoveNthElement- Boolean, clears the value located at Nth position provided that the position
'// provided falls within the bounds of the array that backs the HashMap
'// PutElement - Boolean, adds the value/object provided to the HashMap
'// PutList - Boolean, adds a “list” to this instance
'// PutLSHashMap - Boolean, adds another instance of the class to this instance
'// GetElement - Variant, returns element referenced by the key provided if the HashMap
'// contains the key, otherwise null
'// GetNthElement - Variant, returns element in the nth position provided that requested position
'// (assumed to be base 1) falls within the bounds of the array backing the HashMap
'// Values - Variant (array), the values currently contained in the HashMap
'// Equals - Boolean, returns true if ALL values in the HashMap passed are equal to those of
'// the current HashMap (raises an error if either HashMap contains an object)
'// ToString - String, returns a string representation of current keys and their values
'//
'// Private Methods:
'// init - initializes/reinitializes the values of “this” instance of the object
'// rebuild -
'// buildStackTrace - a stack trace generated in the event of an error within the class
'////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Class LSHashMap
Private varXref As Variant
Private varLst List As Variant
Private strStackTrc As String
'+++ PUBLIC PROPERTIES +++
Public Property Get CLASS_NAME As String
CLASS_NAME = {"LSHashMap" class}
End Property
Public Property Get CR As String
CR = {
}
End Property
Public Property Get GetStackTrace As String
GetStackTrace = Me.strStackTrc$
End Property
Public Property Get Size As Long
Size& = Ubound(Me.varXref) + 1 '// use base 1
End Property
Public Property Get ContainsKey(pstrKey As String) As Boolean
ContainsKey = Iselement(Me.varLst(pstrKey$))
End Property
Public Property Get KeyPosition(pstrKey As String) As Long
Dim varKeyPos As Variant
KeyPosition& = -1 '// default return value
varKeyPos = Arraygetindex(Me.varXref, pstrKey$)
If Isnumeric(varKeyPos) Then
KeyPosition& = Int(varKeyPos) + 1 '// adjust to base 1
End If
End Property
Public Property Get Keys As Variant
Keys = Me.varXref
End Property
Public Property Get IsVoid As Boolean
If Not(Isarray(Me.varXref)) Then
IsVoid = True
Elseif Ubound(Me.varXref) = 0 Then
If Len(Me.varXref(0)) > 0 Then
IsVoid = False
Else
IsVoid = True
End If
Else
IsVoid = False
End If
End Property
'+++ PUBLIC METHODS +++
Public Sub New()
Call Me.init()
End Sub
Public Sub Delete()
Dim nsess As NotesSession
Erase Me.varXref
Erase Me.varLst
If Not(Err = 0) Then
If Len(Me.strStackTrc$) > 0 Then '// in case the error didn't originate within the class
Set nsess = New NotesSession()
Print Me.CLASS_NAME & " -- Error " & Err & ": " & Error$
If Not(nsess.IsOnServer) Then
Msgbox "Extended error details -- " & Me.CR & "Error " & Err & ": " & Error$ & Me.CR & Me.CR & Me.strStackTrc$, , "Extended error details . . ."
End If
End If
End If
End Sub
Public Function Clear() As Boolean
On Error Goto errorThrower
Const METHOD_NAME = "Clear function"
Erase Me.varXref
Erase Me.varLst
Clear = Me.init()
Exit Function
errorThrower:
Call Me.buildStackTrace(Erl, METHOD_NAME)
Error Err, Error$
End Function
Public Function RemoveElement(pstrKey As String) As Boolean
On Error Goto errorThrower
Const METHOD_NAME = "RemoveElement function"
RemoveElement = False
If Iselement(Me.varLst(pstrKey$)) Then
Erase Me.varLst(pstrKey$)
Me.varXref = Fulltrim(Arrayreplace(Me.varXref, pstrKey$, ""))
RemoveElement = True
End If
Exit Function
errorThrower:
Call Me.buildStackTrace(Erl, METHOD_NAME)
Error Err, Error$
End Function
Public Function RemoveNthElement(Byval plngPosition As Long) As Boolean
On Error Goto errorThrower
Const METHOD_NAME = "RemoveNthElement function"
Const ERR_ARRAYINDEXOUTOFBOUNDS = 7909
Dim strKey As String
RemoveNthElement = False
If Not(Me.IsVoid) Then
plngPosition& = plngPosition& - 1 '// assume a base of 1 and adjust to base 0
Select Case plngPosition&
Case Lbound(Me.varXref) To Ubound(Me.varXref)
strKey$ = Me.varXref(plngPosition&)
RemoveNthElement = Me.RemoveElement(strKey$)
Case Else
Error ERR_ARRAYINDEXOUTOFBOUNDS, "The value of the index passed (" & plngPosition& & ") falls outside of the bounds of the underlying array (" & Lbound(Me.varXref) & " to " & Ubound(Me.varXref) & ")"
End Select
End If
Exit Function
errorThrower:
Call Me.buildStackTrace(Erl, METHOD_NAME)
Error Err, Error$
End Function
Public Function PutElement(pblnReplace As Boolean, pstrKey As String, pvarElement As Variant) As Boolean
On Error Goto errorThrower
Const METHOD_NAME = "PutElement function"
PutElement = False
If Len(Fulltrim(pstrKey$)) > 0 Then '// disallow zero-length keys
If Not(Iselement(Me.varLst(pstrKey$))) Then
Me.varXref = Fulltrim(Arrayappend(Me.varXref, pstrKey$))
If Isobject(pvarElement) Then
Set Me.varLst(pstrKey$) = pvarElement
Else
Me.varLst(pstrKey$) = pvarElement
End If
PutElement = True
Elseif pblnReplace Then
Erase Me.varLst(pstrKey$)
If Isobject(pvarElement) Then
Set Me.varLst(pstrKey$) = pvarElement
Else
Me.varLst(pstrKey$) = pvarElement
End If
PutElement = True
End If
End If
Exit Function
errorThrower:
Call Me.buildStackTrace(Erl, METHOD_NAME)
Error Err, Error$
End Function
Public Function PutList(pblnReplace As Boolean, pvarLst List As Variant) As Boolean
On Error Goto errorThrower
Const METHOD_NAME = "PutList function"
Dim varOrgKeys As Variant
Dim varOrgVals As Variant
Dim blnSuccess As Boolean
PutList = False
blnSuccess = True
varOrgKeys = Me.varXref
varOrgVals = Me.Values()
Forall candidate In pvarLst '// all or none - if operation fails even once, revert to original values
If Not(Me.PutElement(pblnReplace, Cstr(Listtag(candidate)), candidate)) Then
blnSuccess = False
Exit Forall
End If
End Forall
If Not(blnSuccess) Then
Call rebuild(varOrgKeys, varOrgVals)
End If
PutList = blnSuccess
Exit Function
errorThrower:
Call Me.buildStackTrace(Erl, METHOD_NAME)
Error Err, Error$
End Function
Public Function PutLSHashMap(pblnReplace As Boolean, phMap As LSHashMap) As Boolean
On Error Goto errorThrower
Const METHOD_NAME = "PutLSHashMap function"
Dim varOrgKeys As Variant
Dim varOrgVals As Variant
Dim i As Integer
Dim blnSuccess As Boolean
PutLSHashMap = False
blnSuccess = True
varOrgKeys = Me.varXref
varOrgVals = Me.Values()
If Not(phMap.IsVoid) Then
Forall key In phMap.Keys '// all or none - if operation fails even once, revert to original values
If Not(Me.PutElement(pblnReplace, Cstr(key), phMap.GetElement(Cstr(key)))) Then
blnSuccess = False
Exit Forall
End If
End Forall
If Not(blnSuccess) Then '// revert to original values (better way to do this?)
Call rebuild(varOrgKeys, varOrgVals)
End If
End If
PutLSHashMap = blnSuccess
Exit Function
errorThrower:
Call Me.buildStackTrace(Erl, METHOD_NAME)
Error Err, Error$
End Function
Public Function GetElement(pstrKey As String) As Variant
On Error Goto errorThrower
Const METHOD_NAME = "GetElement function"
GetElement = Null
If Iselement(Me.varLst(pstrKey$)) Then
If Isobject(Me.varLst(pstrKey$)) Then
Set GetElement = Me.varLst(pstrKey$)
Else
GetElement = Me.varLst(pstrKey$)
End If
End If
Exit Function
errorThrower:
Call Me.buildStackTrace(Erl, METHOD_NAME)
Error Err, Error$
End Function
Public Function GetNthElement(Byval plngPosition As Long) As Variant
On Error Goto errorThrower
Const METHOD_NAME = "GetNthElement function"
Const ERR_ARRAYINDEXOUTOFBOUNDS = 7909
Dim strKey As String
GetNthElement = Null
If Not(Me.IsVoid) Then
plngPosition& = plngPosition& - 1 '// assume a base of 1 and adjust to base 0
Select Case plngPosition&
Case Lbound(Me.varXref) To Ubound(Me.varXref)
strKey$ = Me.varXref(plngPosition&)
If Isobject(Me.varLst(strKey$)) Then
Set GetNthElement = Me.varLst(strKey$)
Else
GetNthElement = Me.varLst(strKey$)
End If
Case Else
Error ERR_ARRAYINDEXOUTOFBOUNDS, "The value of the index passed (" & plngPosition& & ") falls outside of the bounds of the underlying array (" & Lbound(Me.varXref) & " to " & Ubound(Me.varXref) & ")"
End Select
End If
Exit Function
errorThrower:
Call Me.buildStackTrace(Erl, METHOD_NAME)
Error Err, Error$
End Function
Public Function Values() As Variant
On Error Goto errorThrower
Const METHOD_NAME = "Values function"
Dim x As Long
Dim retArray() As Variant
Values = Null
If Not(Me.IsVoid) Then
Redim retArray(Ubound(Me.varXref)) As Variant
x = -1
Forall key In Me.varXref
x = x + 1
If Isobject(Me.varLst(key)) Then
Set retArray(x) = Me.varLst(key)
Else
retArray(x) = Me.varLst(key)
End If
End Forall
Values = retArray
End If
Exit Function
errorThrower:
Call Me.buildStackTrace(Erl, METHOD_NAME)
Error Err, Error$
End Function
Public Function Equals(phmap As LSHashMap) As Boolean
On Error Goto errorThrower
Const METHOD_NAME = "Equals function"
Const ERR_INVALID_COMPARISON = 7901
Dim varThisVal As Variant
Dim varCompVal As Variant
Equals = False
If phmap.IsVoid Then
If Me.IsVoid Then
Equals = True
End If
Elseif Not(Me.IsVoid) Then
If Me.Size = phmap.Size Then
Forall key In Me.varXref
If Not(phmap.ContainsKey(Cstr(key))) Then
Goto functionExit
End If
varThisVal = Me.varLst(Cstr(key))
varCompVal = phmap.GetElement(Cstr(key))
If Isobject(varThisVal) Then
Error ERR_INVALID_COMPARISON, "Unable to perform comparison on non-scalar values (" & Typename(varThisVal) & ")"
End If
If Isobject(varCompVal) Then
Error ERR_INVALID_COMPARISON, "Unable to perform comparison on non-scalar values (" & Typename(varCompVal) & ")"
End If
If Not(Datatype(varThisVal) = Datatype(varCompVal)) Then
Goto functionExit
End If
If Isarray(varThisVal) Then
If Not(Join(varThisVal, "~|~") = Join(varCompVal, "~|~")) Then
Goto functionExit
End If
Elseif Not(varThisVal = varCompVal) Then
Goto functionExit
End If
End Forall
Equals = True '// if we get this far, return true
End If
End If
functionExit:
Exit Function
errorThrower:
Call Me.buildStackTrace(Erl, METHOD_NAME)
Error Err, Error$
End Function
Public Function ToString(pstrDelimiter As String) As String
On Error Goto errorThrower
Const METHOD_NAME = "ToString function"
Dim strOutput As String
If Len(pstrDelimiter$) < 1 Then
pstrDelimiter$ = Me.CR
End If
If Me.IsVoid Then
ToString$ = "null"
Else
Forall key In Me.varXref
If Isobject(Me.varLst(key)) Then
strOutput$ = strOutput$ & pstrDelimiter$ & key & " = " & Typename(Me.varLst(key))
Elseif Isarray(Me.varLst(key)) Then
strOutput$ = strOutput$ & pstrDelimiter$ & key & " = [" & Join(Me.varLst(key), ", ") & "]"
Else
strOutput$ = strOutput$ & pstrDelimiter$ & key & " = " & Me.varLst(key)
End If
End Forall
ToString$ = Strright(strOutPut$, pstrDelimiter$)
End If
Exit Function
errorThrower:
Call Me.buildStackTrace(Erl, METHOD_NAME)
Error Err, Error$
End Function
'+++ PRIVATE METHODS +++
Private Function init() As Boolean
On Error Goto errorThrower
Const METHOD_NAME = "init function"
init = False
Dim strArray(0) As String
Me.varXref = strArray
Erase Me.varLst
init = True
Exit Function
errorThrower:
Call Me.buildStackTrace(Erl, METHOD_NAME)
Error Err, Error$
End Function
Private Sub rebuild(pvarXref As Variant, pvarVals As Variant)
On Error Goto errorThrower
Const METHOD_NAME = "rebuild sub"
Dim x As Long
Call Me.init()
x = -1
If Isarray(pvarXref) Then
Me.varXref = pvarXref
End If
If Isarray(pvarVals) Then
Forall valu In pvarVals
x = x + 1
Call Me.PutElement(True, Cstr(pvarXref(x)), valu)
End Forall
End If
Exit Sub
errorThrower:
Call Me.buildStackTrace(Erl, METHOD_NAME)
Error Err, Error$
End Sub
Private Sub buildStackTrace(Byval pintLineNo As Integer, Byval pstrCodeElement As String)
Me.strStackTrc$ = Me.strStackTrc$ & Me.CR & pstrCodeElement$ & ": " & pintLineNo%
End Sub
End Class