| |
| Implementation: Adjacency Lists |
Let's see an example of what might be included in a table for a given outline:
SampleTable
| Key | Data | Sup |
Sort |
| 1 | Joe | | | 0 | 1 |
| 2 | | Ellen | | 1 | 2 |
| 3 | | Fred | | 1 | 1 |
| 4 | | Sam | | 1 | 3 |
| 5 | Ethyl | | | 0 | 1 |
| 6 | | Winston | | 5 | 1 |
| 7 | | | Eliot | 6 | 1 |
| 8 | Gertrude | | | 0 | 1 |
| 9 | Annie | | | 0 | 2 |
| 10 | Jack | | | 0 | 3 |
| 11 | | Jill | | 10 | 1 |
| 12 | | | Jason | 11 | 1 |
|
Data is shown in three columns, here, for clarity, but would be just one in the actual table.
So Jason is subordinate to Jill.
The key or index for Jill is 11. The only structural link
for Jason is directly to Jill. A one-way up-link. That's it.
That's the essence of an adjacency list.
The only way to tell that Jason is also subordinate to Jack
is the 'chase' or follow the links up through Jill, to Jack.
If one wanted to move around some categories, maybe
bring Jason under Annie, that would be fine.
Even if one moved Jason up over Jill, and under Jack, still fine.
But if you tried to select Jack and move under Jason as the target, say, that could
be a problem.
One could allow for an automatic and separate operation of relocating
Jill to Jack's superior, in this case top level, 0.
Or one could check for this and simply refuse to allow it, and
kick out an error message, instead.
[By the way, to select everything in the box below, in Internet Explorer,
triple click the mouse (click rapidly three times).]
|
' Just see if the possible MoveID is superior to the target, NextSupID, in an 'adjacency list', strTable.
' The primary key (pk) field must be a single field which uses the same values that are used
' for the one-way-up superior link field.
Public Function fCantMoveUnder(lngMoveID As Long, ByVal lngNextSupID As Long, ysnRtn As Boolean, _
strSupIDField As String, strPKfield As String, strTable As String)
Dim dum
lngNextSupID = fLookUp(strSupIDField, strTable, strPKfield & "=" & lngNextSupID)
If lngNextSupID < 1 Or IsNull(lngNextSupID) Then
ysnRtn = False
ElseIf lngNextSupID = lngMoveID Then
ysnRtn = True
Else
dum = fCantMoveUnder(lngMoveID, lngNextSupID, ysnRtn, strSupIDField, strPKfield, strTable)
End If
fCantMoveUnder = ysnRtn
End Function
' Example call
If fCantMoveUnder(SelectedKey, CLng(TargetKey), False, "Sup", "Key", "SampleTable") then
MsgBox "<explanation here>", vbCritical, "WON'T WORK!"
Exit Sub ' or Function
End if
|
fLookup, by the way, is like the DLookup function, but is a function you'd have to write
for the purpose of using a SQL Select to help standardize things, and maybe speed them up.
|
' Substitute for DLookUp, that tends to be much faster for use of SQL
' Normally returns the single fields result. But multiple fields can be specified in strRtnField,
' to be returned with comma separators.
' Returns empty string if no fields were found, or if even one field was misnamed.
' if a field in strRtnField is enclosed in curly braces, "{ }",
' then it's simply returned without the braces - a constant.
' In fact, empty braces will save a place in the returned string, e.g. "anID,{},lngID" -> 84,,109
Public Function fLookUp(strRtnField As String, strTable As String, Optional strWhere As String) As String
On Error GoTo Err_fLookUp
Dim rst As DAO.Recordset
Dim k As Integer, intNumFields As Integer, i As Integer, intNumConst As Integer
Dim strMarkedFields As String, strT As String, strNext As String
Dim strUseSep As String, strActualSep As String
Dim strFldNameFlg As String, bytLenFlg As Byte, boolHaveRecords As Boolean
strFldNameFlg = "{go}"
bytLenFlg = Len(strFldNameFlg)
If strWhere = "" Then Exit Function
intNumFields = fDCount(strRtnField)
intNumConst = 0
For i = 1 To intNumFields
strNext = Trim(fDfield(strRtnField, i))
If Left(strNext, 1) = "{" And Right(strNext, 1) = "}" Then
strMarkedFields = strMarkedFields & strUseSep & Mid(strNext, 2, Len(strNext) - 2)
Add1 intNumConst
Else
strMarkedFields = strMarkedFields & strUseSep & strFldNameFlg & strNext
' Trim away any constant fields from the SELECT fields used just below.
strT = strT & strActualSep & strNext
' Need separate, here, because even one constant could precede first field.
strActualSep = ","
End If
strUseSep = ","
Next
If Len(strT) > 0 Then
Set rst = CurrentDB.OpenRecordset("Select " & strT & _
" From " & strTable & " Where " & strWhere, dbOpenSnapshot)
If rst.RecordCount > 0 Then
boolHaveRecords = True
rst.MoveFirst
End If
Else
If intNumConst > 0 Then boolHaveRecords = True
End If
If boolHaveRecords Then
strUseSep = ""
For k = 1 To intNumFields
strNext = fDfield(strMarkedFields, k)
If Left(strNext, bytLenFlg) = strFldNameFlg Then
fLookUp = fLookUp & strUseSep & rst(Right(strNext, Len(strNext) - bytLenFlg))
Else
fLookUp = fLookUp & strUseSep & strNext
End If
strUseSep = ","
Next
End If
Exit_fLookUp:
If Not rst Is Nothing Then rst.Close
Exit_fLookUp_noRst:
Exit Function
Err_fLookUp:
Select Case Err.Number
Case 91 ' probably included too many or few brackeT in argumenT, or double commas, etc.
Resume Exit_fLookUp_noRst
End Select
Resume Exit_fLookUp
End Function
' AND THESE FOLLOWING ARE USEFUL IN BREAKING OUT AND COUNTING FIELDS IN COMMA DELIMITED STRINGS
' Return the specific intRecNum field from the strText string,
' where fields are separated by single character delimiter/separator.
' fieldnum is 1-based
' To save typing, seperator is optional, and defaults to a comma.
Public Function fDfield(ByVal strText As String, intRecNum As Integer, Optional septor As String) As String
Dim lngNextSepPos As Long, intSepLen As Integer, cntrRec As Byte
If strText = "" Then Exit Function
If septor = "" Then septor = ","
lngNextSepPos = 1
cntrRec = 0
intSepLen = Len(septor)
Do While cntrRec < intRecNum
Add1 cntrRec
strText = Mid(strText, lngNextSepPos)
lngNextSepPos = InStr(1, strText, septor)
If cntrRec = intRecNum Then
If lngNextSepPos < 1 Then
fDfield = Mid(strText, 1)
Else
fDfield = Mid(strText, 1, lngNextSepPos - 1)
End If
Exit Function
ElseIf lngNextSepPos < 1 Then
Exit Function
End If
lngNextSepPos = lngNextSepPos + intSepLen
Loop
End Function
' Return number of fields in string separated by, strSep (if no strSep, comma is default).
' (uses only built-in instr handling, with no calls to fDfield)
Public Function fDCount(strT As String, Optional ByVal strSep As String)
Dim intOffs As Integer, intLatch As Integer, intFound As Integer, intLenSep As Integer
If Len(strT) = 0 Then
fDCount = 0
Else
strSep = IIf(Len(strSep) = 0, ",", strSep)
intLenSep = Len(strSep)
intOffs = 1
intLatch = 0
intFound = 0
Do
intLatch = intOffs
intOffs = InStr(intOffs, strT, strSep)
If intOffs > 0 Then
' increment only if not an empty field
If intOffs - intLatch > 0 Then Add1 intFound
intOffs = intOffs + intLenSep
Else
Exit Do
End If
Loop
If Len(strT) > intLatch - 1 Then Add1 intFound
fDCount = intFound
End If
End Function
|
This is actually the full fLookup that I use, with this parameter passing
for a particular purpose.
But it will act as simply a DLookup substitute, with the proviso that fLookup
is always returning a string.
So inserting a new category is performed after first checking
that it doesn't already exist.
You could use fLookup.
If it's a go, you could use the SQL INSERT INTO on the table.
And the new sort value could just as easily be at the end of
the list which contains the currently selected category.
So the highest sort number in the list, plus 1.
Let's call, Key - anID. Call, Sup - lngSupID.
Call Data - txCategory.
Call SampleTable - tblCatalogContent.
Another table - tblCatalog (or something) - is just a list of catalogs.
But this content table contains all the entries for the catalogs.
|
' Treeview ActiveX control - tvw - shows the current catalog.
' When that catalog was selected, the form was filtered, and Me!anID
' is the key for that catalog.
' tblCatalog is a list of catalogs,
' but tblCatalogContent is the table for all entries in those catalogs.
Private Sub sInsertCataNode(strKey As String, strType As Long, strText As String)
Dim strSearch As String, nodCurrent As node
Dim idxSup As Long, nextSort
Dim objtree As TreeView
If IsNull(Me!anID) Then
MsgBox "Please first select a catalog." & vbCrLf & vbCrLf & _
"Press the Select catalog button and select from the boxes at the right."
Exit Sub
End If
Set objtree = Me!tvwCatalog.Object
Set nodCurrent = objtree.SelectedItem
If nodCurrent Is Nothing Then
idxSup = 0
Else
If Me!tglInsertMode Then
idxSup = Mid(nodCurrent.Key, 2)
Else
idxSup = fLookUp("[lngSupID]", "tblCatalogContent", "[anID]=" & Mid(nodCurrent.Key, 2))
End If
End If
strSearch = "[lngCatID]=" & Me!anID & " AND [bytItemType]=" & strType
' allow multiple separators in a catalog, just bump the key number
If strType = CATA_SEPARATOR Or strType = CATA_LABEL Then
strKey = fNextFieldIncrement("lngItemID", "tblCatalogContent", strSearch)
End If
nextSort = fNextFieldIncrement("lngSort", "tblCatalogContent", "[lngCatID]=" & Me!anID & " AND [lngSupID]=" & idxSup)
strSearch = strSearch & " AND [lngItemID]=" & strKey
If fLookUp("[anID]", "tblCatalogContent", strSearch) = "" Then
CurrentDB.Execute "INSERT INTO tblCatalogContent ( lngCatID, bytItemType, lngItemID, " & _
"lngSupID, txCategory, txPath, lngSort, txFontSize, txFontFace) " & _
"VALUES(" & Me!anID & "," & _
strType & "," & _
strKey & "," & _
idxSup & ",""" & _
strText & """,""" & _
fZLenForDupe2(strText, fReadCatalogName(strType, strKey)) & """," & _
nextSort & ",""" & _
IIf(strType = CATA_SEPARATOR, "", "+1") & """,""" & _
IIf(strType = CATA_SEPARATOR, "", "Arial,Helvetica") & """)"
sRefreshTvw
Else
MsgBox fLookUp("[txCategory]", "tblCatalogContent", strSearch) & _
"- is already present in this catalog." & _
vbCrLf & vbCrLf & "No duplicates are allowed."
End If
End Sub
' May be be gaps in numbering, so don't just use Count(),
' but read the actual last field, assuming the strSQL uses ORDER BY
Public Function fGetLastField(strSQL As String)
Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset(strSQL)
If rst.RecordCount > 0 Then
rst.MoveLast
fGetLastField = rst(0)
Else
fGetLastField = ""
End If
rst.Close
End Function
' Pick out a field by SELECT query and return 0, if not found, or increment by 1 if it is.
Public Function fNextFieldIncrement(strRtnField As String, strTable As String, Optional strWhere As String)
Dim strT As String
strT = fGetLastField("SELECT " & strRtnField & " FROM " & strTable & _
IIf(Len(strWhere) > 0, " WHERE " & strWhere, "") & " ORDER BY " & strRtnField)
fNextFieldIncrement = IIf(strT = "", 0, Val(strT) + 1)
End Function
' If trimmed str1 and str2 are the same, return zero-length string
' Otherwise, return string 2
Public Function fZLenForDupe2(str1 As String, str2 As String)
If StrComp(Trim(str1), Trim(str2)) = 0 Then
fZLenForDupe2 = ""
Else
fZLenForDupe2 = str2
End If
End Function
|
Here a specific type of entry - strType - is being mentioned, too. But that's something extra.
A toggle button - Me!tglInsertMode - is used to indicate whether the new category is placed
at the end of the same level, or the end of the next level down, from the target category - objtree.SelectedItem.
Here, certain entries can be of a type - label, or separator - which
won't have any unique index, or relation to another table.
So some key is created by examining the keys for similar items, if any, already in the content table,
and just adding 1.
To delete a category, it's assumed that all subcats will be removed, as well.
It also means changing the sort values for any categories following
on the same list, the same level as that deleted.
' Triggered by keypress - keyup event, specifically
' vbKeyDelete is the predefined Visual BASIC constant for the Delete key
' Remove for Treeview control (it will auto-delete all subtrees, as well)
' Remove from table, but then adjust all the sort values down.
Private Sub tvw_KeyUp(KeyCode As Integer, ByVal Shift As Integer)
Dim rst As DAO.Recordset, nodCurrent As node, objtree As TreeView
Dim strSearch As String, strSQL As String, strParentKey As String
Dim strKey As String, strText As String, strNew As String
Set rst = CurrentDB.OpenRecordset("tblCatalogContent", dbOpenDynaset)
Set objtree = Me!tvw.Object
Set nodCurrent = objtree.SelectedItem
sRtnNullOrKey strKey, strText, nodCurrent
Select Case KeyCode
Case vbKeyDelete
If Not nodCurrent.Tag = "locked" Then
If strKey <> "" Then
' Remove node from treeview - Treeview is designed to also removed all subnodes.
objtree.Nodes.Remove nodCurrent.Index
rst.FindFirst "[anID]=" & strKey
' Decrement all the sort values (lngSort) for this level, starting after the deleted record.
CurrentDB.Execute "UPDATE tblCatalogContent SET lngSort =lngSort -1" & _
" WHERE lngSort >" & rst!lngSort & _
" AND lngCatID=" & rst!lngCatID & _
" AND lngSupID=" & rst!lngSupID
sDeleteTreeRecords strKey, "tblCatalogContent"
End If
End If
End Select
rst.Close
End Sub
' In a one-way list, 'recursive', table recursively remove the
' current record and all subcategories from the recordset
' Create a hole by deleting the top record, then simply loop through all orphans (auto cleans list, as well)
' (LEFT JOIN suggested by MS support note ACC2000)
Public Sub sDeleteTreeRecords(lngID, strTableName)
Dim strQuery As String, strWhere As String
' Create a hole, delete selected item
fGetThisDB.Execute "DELETE * FROM " & strTableName & " WHERE anID=" & lngID
strQuery = " FROM " & strTableName & _
" LEFT JOIN " & strTableName & " AS list2 ON " & strTableName & ".lngSupID = list2.anID" & _
" WHERE (" & strTableName & ".lngSupID>0) AND (list2.anID Is Null)"
' Repeatedly delete any records where the lngSupID points to nothing, until there are no more such records.
' (unless lngSupID is 0 - lngSupID=0 is used to indicate a top level record)
Do While fGetThisDB.OpenRecordset("SELECT Count(*) " & strQuery)(0) > 0
fGetThisDB.Execute "DELETE " & strTableName & ".*" & strQuery
Loop
End Sub
|
The last thing, then, is the fairly straightforward
relocation.
All of these are explained in more detail in the context of
the full application is which these are used - on the CD.
But one aspect of the relocation is then resorting the sort
values for that list, on that level.
And this might be a way to go, as follows.
|
' Have to account for the sort field, adjusting all the numbers on a particular level up/down as needed.
' The spacer/separator tag or 'bar' may be added many times.
' The same category, however, can only be included once in a catalog, no matter at which level
Private Sub tvwCatalog_OLEDragDrop(Data As Object, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
On Error GoTo Err_OLEDragDrop
Effect = vbDropEffectNone
Dim nodDragged As node, strKeyDragged As String, strKeyDropped As String
Dim lngSortDropped As Long, lngSortDragged As Long, strWhereSort As String
Dim strSetTo As String, strSetTo2 As String, strT As String
Dim lngCatIDdragged As Long, lngSupIDdragged As Long, lngSupIDdropped As Long
Dim objtree As TreeView
' data is comma delim 'record' from drag tvw - key, tag, table name
' was set in the _OLEStartDrag procedure, in source treeview
strT = Data.GetData(vbCFText)
' Essentially a 'GOTO', redirect/shunt to the dragndrop cover func.
' Not a resort, but this a new addition to tvw from other treeviews.
If Len(strT) > 0 Then
sHandleDragInsert (strT)
Exit Sub
End If
' Otherwise, this is a relocation
Set objtree = Me!tvw.Object
' Obviously if nothing is selected, forget it.
If Not objtree.SelectedItem Is Nothing Then
Set nodDragged = objtree.SelectedItem
strKeyDragged = lngDNKey
' lngCatID is the catalog key from the table, tblCatalog (which lists the catalogs).
strT = fLookUp("lngCatID,lngSupID,lngSort", "tblCatalogContent", "anID=" & strKeyDragged)
lngCatIDdragged = fDfield(strT, 1)
lngSupIDdragged = fDfield(strT, 2)
lngSortDragged = fDfield(strT, 3)
'nothing if dragged to empty space - make top level cat (ignore if already is)
If objtree.DropHighlight Is Nothing Then
If lngSupIDdragged > 0 Then
strSetTo2 = "lngSupID=0, lngSort=" & _
fNextFieldIncrement("lngSort", "tblCatalogContent", _
"[lngCatID]=" & lngCatIDdragged & " AND [lngSupID]=0")
CurrentDb.Execute "UPDATE tblCatalogContent SET " & strSetTo2 & " WHERE anID=" & strKeyDragged
End If
' otherwise just change the one way link, and modify the sort field
ElseIf nodDragged.Index <> objtree.DropHighlight.Index Then
strKeyDropped = Mid(objtree.DropHighlight.Key, 2)
lngDragNodeKey = CLng(strKeyDragged)
strT = fLookUp("lngSort, lngSupID", "tblCatalogContent", "anID=" & strKeyDropped)
lngSortDropped = fDfield(strT, 1)
lngSupIDdropped = fDfield(strT, 2)
If fCantMoveUnder(lngDragNodeKey, CLng(strKeyDropped), False, "lngSupID", "anID", "tblCatalogContent") Then Exit Sub
If Me!tglInsertMode Or lngSupIDdropped <> lngSupIDdragged Then
strWhereSort = "lngSort >" & lngSortDragged
strSetTo = "lngSort =lngSort -1"
strSetTo2 = "lngSupID=" & strKeyDropped & ", lngSort=" & _
fNextFieldIncrement("lngSort", "tblCatalogContent", _
"[lngCatID]=" & lngCatIDdragged & " AND [lngSupID]=" & strKeyDropped)
Else
If lngSortDropped < lngSortDragged Then
strWhereSort = "lngSort >=" & lngSortDropped & " AND lngSort <" & lngSortDragged
strSetTo = "lngSort =lngSort +1"
Else
strWhereSort = "lngSort <" & lngSortDropped & " AND lngSort >=" & lngSortDragged
strSetTo = "lngSort =lngSort -1"
' -1: To correct for insert above target when dragging higher node to lower.
lngSortDropped = lngSortDropped - 1
End If
strSetTo2 = "lngSort=" & lngSortDropped
End If
CurrentDb.Execute "UPDATE tblCatalogContent SET " & strSetTo & " WHERE " & strWhereSort & _
" AND lngCatID=" & lngCatIDdragged & " AND lngSupID=" & lngSupIDdragged
CurrentDb.Execute "UPDATE tblCatalogContent SET " & strSetTo2 & " WHERE anID=" & strKeyDragged
End If
End If
Exit_OLEDragDrop:
sRefreshTvw
Exit Sub
Err_OLEDragDrop:
Resume Exit_OLEDragDrop
End Sub
|
Again, there's a potential problem in presenting bits and pieces
of a larger working application.
There's a lot of extra stuff that might need further explanation.
And that's explained, again, on the CD, in full context.
But, hopefully, there's sufficient here to suggest some of the problems
and solutions when dealing with an adjacency list structure.
There wasn't much need for complicated retrieval in this
general application.
But such would follow, or chase, the pointer to find superior categories,
as previously noted (as seen in the fCantMoveUnder routine, at the very top, here).
A way to 'flatten' the structure, to keep the whole thing 'in view' at once,
is now attempted in order to avoid even recursion that is allowed and
implemented in certain SQL implementations.
A couple of these methods are briefly examined -
NEXT.
|