Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/sightmap/site.cls

Visual Basic class definition | 1999-02-24 | 18.5 KB | 688 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Site"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'CLASS -- Site -- Site.cls

'--------------------------------------------------------------------------
'<Purpose>
'   Encapsulate the functions and data needed to build a site's map.
'
'--------------------------------------------------------------------------

Private strFiles() As String                'holds files for the site
Private strSmallFiles() As String           'holds small (short) file names
Private strUKFiles() As String              'Unknown files found
Private strFilters() As String              'Filters to look for
Private strFilterLen() As String            'lengths of each filter
Private Matrix() As Integer                 'The adjacency matrix
Private strDirs() As String                 'The directories to search
Private intFilterCt As Integer              'amt of filters
Private intUKFileCt As Integer              'amt of unknown files found
Private intFileCt As Integer                'amt of files
Private intDirCt As Integer                 'amt of directories
Private strName As String                   'name of this site
Private strMainDirectory As String          'main directory to start parsing
Private strID As String                     'internal name for this site
Private blnChooseRoot As Boolean            'did user provide start point
Private strRoot As String                   'start point for map
Private Visited() As Boolean                'Used by traversal algorithms

'*******************************************************************************

Private Function MapName(ByVal Vertex As String) As Integer
Dim i As Integer

    Vertex = UCase$(Vertex)

    For i = 1 To intFileCt
        If strSmallFiles(i) = Vertex Then
            MapName = i
            Exit For
        End If
    Next

End Function
'*******************************************************************************

Public Sub RemoveFilter(intIndex As Integer)
Dim i As Integer


    strFilters(intIndex) = strFilters(intFilterCt)
    ReDim Preserve strFilters(intFilterCt - 1)
    intFilterCt = intFilterCt - 1

End Sub

'*******************************************************************************

Private Sub ResetVisited()
Dim i As Integer

    For i = 1 To intFileCt
        Visited(i) = False
    Next

End Sub

'*******************************************************************************
Public Sub SaveSite(strPath As String)
On Error GoTo SaveSite_Error

Dim i As Integer        'lcv
Dim j As Integer        'lcv

    Open strPath For Output As #1

    If intFileCt < 1 Then
        Err.Raise vbObjectError + 1, "SaveSite", "Site not fully defined.  Cannot save at this time."
    End If

    'write site id and name
    Write #1, strID, strName

    'Write the number of files
    Write #1, intFileCt

    'write the files and short file names
    For i = 1 To intFileCt
        Write #1, strFiles(i), strSmallFiles(i)
    Next

    'write the adjacency matrix, row by row
    For i = 1 To intFileCt
        For j = 1 To intFileCt
            Write #1, Matrix(i, j)
        Next j
    Next i

    'Write the number of filters
    Write #1, intFilterCt

    'write the filters and filter lengths
    For i = 1 To intFilterCt
        Write #1, strFilters(i), strFilterLen(i)
    Next

    'write the unknown file amt
    Write #1, intUKFileCt

    'write out the uk files
    For i = 1 To intUKFileCt
        Write #1, strUKFiles(i)
    Next

    'Write out number of directories
    Write #1, intDirCt

    'Write out the directories holding the site
    For i = 1 To intDirCt
        Write #1, strDirs(i)
    Next

    'write out the site root definition
    Write #1, strMainDirectory, blnChooseRoot, strRoot



    Close #1
Exit Sub
SaveSite_Error:

    Close #1
    Err.Raise vbObjectError + 1, "Save Site", CStr(Err.Number) & " -- " + Err.Description


End Sub

'*******************************************************************************
Public Sub OpenSite(strPath As String)
On Error GoTo OpenSite_Error

Dim i As Integer        'lcv
Dim j As Integer

    Open strPath For Input As #1

    Input #1, strID, strName

    'input the number of files
    Input #1, intFileCt

    ReDim strFiles(intFileCt)
    ReDim strSmallFiles(intFileCt)
    ReDim Visited(intFileCt)

    'input the files and short file names
    For i = 1 To intFileCt
        Input #1, strFiles(i), strSmallFiles(i)
    Next

    ReDim Matrix(intFileCt, intFileCt)

    'input the adjacency matrix, row by row
    For i = 1 To intFileCt
        For j = 1 To intFileCt
            Input #1, Matrix(i, j)
        Next j
    Next i

    'input the number of filters
    Input #1, intFilterCt

    ReDim strFilters(intFilterCt)
    ReDim strFilterLen(intFilterCt)

    'input the filters and filter lengths
    For i = 1 To intFilterCt
        Input #1, strFilters(i), strFilterLen(i)
    Next

    'input the unknown file amt
    Input #1, intUKFileCt

    If intUKFileCt > 0 Then
        ReDim strUKFiles(intFileCt)

        'input out the uk files
        For i = 1 To intUKFileCt
            Input #1, strUKFiles(i)
        Next
    End If

    'input out number of directories
    Input #1, intDirCt

    If intDirCt > 0 Then
        ReDim strDirs(intDirCt)

        'input out the directories holding the site
        For i = 1 To intDirCt
            Input #1, strDirs(i)
        Next
    End If

    'input out the site root definition
    Input #1, strMainDirectory, blnChooseRoot, strRoot


    Close #1

Exit Sub
OpenSite_Error:

    Close #1
    Err.Raise vbObjectError + 1, "Open Site", CStr(Err.Number) & " -- " + Err.Description

End Sub
'*******************************************************************************

Private Function AllVisited() As Boolean
Dim i As Integer
Dim blnFlag As Boolean

    blnFlag = True

    For i = 1 To intFileCt
        If Visited(i) = False Then
            blnFlag = False
            Exit For
        End If
    Next

    AllVisited = blnFlag

End Function
'*******************************************************************************

Public Sub DrawTree(tv As TreeView)
Dim n As Node
Dim idx As Integer
Dim j As Integer
Dim intNodeIdx As Integer
Dim blnAllVisited As Boolean

    blnAllVisited = False

    If blnChooseRoot Then
        'Supplied root
        idx = MapName(strRoot)
        If idx = 0 Then
            Exit Sub
        End If
    Else
        'Divine the root!
        idx = DivineRoot()
        If idx > 0 Then
            strRoot = strSmallFiles(idx)
        Else
            Exit Sub
        End If
    End If

    Call ResetVisited

    Set n = tv.Nodes.Add
    n.Text = strName
    intNodeIdx = 1
    Visited(idx) = True
    Set n = tv.Nodes.Add(intNodeIdx, tvwChild)
    n.Text = strRoot


    Call FillBranch(tv, n, idx, n.Index)

End Sub
'*******************************************************************************

Private Sub FillBranch(tv As TreeView, n As Node, idx As Integer, intNodeIdx)
'Recursive
Dim j As Integer


    For j = 1 To intFileCt
        If (Matrix(idx, j) = 1) And (idx <> j) And (Not Visited(j)) Then
            'We have an edge
            Set n = tv.Nodes.Add(intNodeIdx, tvwChild)
            n.Text = strSmallFiles(j)
            Visited(j) = True
            If Not AllVisited() Then
                Call FillBranch(tv, n, j, n.Index)
            End If
        End If
    Next

End Sub
'*******************************************************************************

Function DivineRoot() As Integer

Dim i As Integer
Dim j As Integer
Dim intFreq As Integer
Dim intCurFreq As Integer
Dim intFreqIdx As Integer

    'Examine matrix.  The row with the most 1's (higest frequency) will be our root.
    For i = 1 To intFileCt
        intCurFreq = 0
        For j = 1 To intFileCt
            If Matrix(i, j) > 0 Then
                intCurFreq = intCurFreq + 1
            End If
        Next j
        If intCurFreq > intFreq Then
            intFreq = intCurFreq
            intFreqIdx = i
        End If
    Next i

    DivineRoot = intFreqIdx

End Function
'*******************************************************************************

Public Sub PrintMatrix()
Dim iRow As Integer
Dim iCol As Integer
Dim i As Integer
Dim strRow As String
Dim blnHasLink As Boolean


    Open "c:\matrix.xls" For Output As #1

    Print #1, "Site:"; strName
    Print #1, vbCrLf
    Print #1, "Files (vertices)"
    For i = 1 To intFileCt
        Print #1, i; Tab; strSmallFiles(i); vbCrLf
    Next

    Print #1, vbCrLf
    Print #1, vbCrLf

    Print #1, "Unknown files"
    For i = 1 To intUKFileCt - 1
        Print #1, i; Tab; strUKFiles(i); vbCrLf
    Next

    blnHasLink = False
    Print #1, "Files with no links"
    For iRow = 1 To intFileCt
        blnHasLink = False
        For iCol = 1 To intFileCt
            If Matrix(iRow, iCol) = 1 Then
                blnHasLink = True
                Exit For
            End If
        Next
        If Not blnHasLink Then
            Print #1, iRow; Tab; strSmallFiles(iRow)
        End If
    Next

    Print #1, vbCrLf
    Print #1, vbCrLf

    Print #1, "Adjacency Matrix"

    strRow = ""
    For i = 1 To intFileCt
        strRow = strRow & vbTab & CStr(i)
    Next
    Print #1, strRow
    For iRow = 1 To intFileCt
        strRow = CStr(iRow) & vbTab
        For iCol = 1 To intFileCt
            strRow = strRow & CStr(Matrix(iRow, iCol)) & vbTab
        Next
        Print #1, strRow
    Next

    Print #1, vbCrLf
    Print #1, vbCrLf

    Print #1, "Adjacency List"
    For iRow = 1 To intFileCt
        Print #1, iRow; strSmallFiles(iRow) & ":"
        For iCol = 1 To intFileCt
            If Matrix(iRow, iCol) = 1 Then
                Print #1, Tab; strSmallFiles(iCol)
            End If
        Next
        Print #1, vbCrLf
    Next


    Close #1

End Sub
'*******************************************************************************

Private Sub MakeSmallFiles()

Dim i As Integer
Dim ch As String
Dim j As Integer

    For i = 1 To intFileCt
        For j = Len(strFiles(i)) To 1 Step -1
            ch = Mid$(strFiles(i), j, 1)
            If ch = "\" Then
                strSmallFiles(i) = UCase$(Right$(strFiles(i), Len(strFiles(i)) - j))
                Exit For
            End If
        Next
    Next


End Sub
'*******************************************************************************

Public Sub BuildMatrix()
On Error GoTo BuildMatrix_Error

Dim i As Integer
Dim j As Integer
Dim strLine As String


    'Resize working structures

    ReDim Matrix(intFileCt, intFileCt)
    ReDim Visited(intFileCt)
    UKFileCount = 0

    Call MakeSmallFiles

    'Go through list of files (verticies) and construct adjacency matrix
    For i = 1 To intFileCt
        Open strFiles(i) For Input As #1
        Do While Not EOF(1)
            Line Input #1, strLine

            For j = 1 To intFilterCt
                If InStr(1, strLine, strFilters(j), vbTextCompare) Then
                    Call UnstringName(strFilters(j), strLine, i, strFilterLen(j))
                End If
            Next
        Loop
        Close #1
    Next

   Call PrintMatrix

Exit Sub
BuildMatrix_Error:

    Close #1
    Err.Raise vbObjectError + 1, "Build Matrix", CStr(Err.Number) & " -- " + Err.Description

End Sub

'*******************************************************************************

Private Sub UnstringName(strFilter As String, strLine As String, _
    intIndex As Integer, intFiltLen)
On Error GoTo UnstringName_Error
Dim intStart As Integer             'Starting point for search
Dim intFileEnd As Integer
Dim intFileStart As Integer
Dim strFile As String
Dim i As Integer
Dim blnMoreFiles As Boolean
Dim intMappedName As Integer
Dim ch As String

    blnMoreFiles = True

    'Get starting point
    intStart = InStr(1, strLine, strFilter, vbTextCompare)

    Do While blnMoreFiles
        intMappedName = 0
        For i = intStart To 1 Step -1
            ch = Mid$(strLine, i, 1)
            If (ch = "/") Or (ch = "\") Or (Asc(ch) = 34) Or (ch = "?") Or (ch = "=") Then
                intFileStart = i + 1
                intFileEnd = intStart + intFiltLen - 1
                strFile = Mid$(strLine, intFileStart, (intFileEnd - intFileStart + 1))
                intMappedName = MapName(strFile)
                If intMappedName > 0 Then
                    'Found a vertex
                    Matrix(intIndex, intMappedName) = 1
                Else
                    'This file is a dead link
                    If (UCase(strFile) <> "HTM") And (UCase(strFile) <> "HTML") Then
                        UKFileCount = UKFileCount + 1
                        strUKFiles(UKFileCount) = strFile & " found in " & strFiles(intIndex)
                    End If
                End If
                Exit For
            End If
        Next

        'Move start point one over to loop for another instance of the filter
        intStart = intStart + 1
        If InStr(intStart, strLine, strFilter, vbTextCompare) Then
            intStart = InStr(intStart, strLine, strFilter, vbTextCompare)
        Else
            blnMoreFiles = False
        End If
    Loop

Exit Sub
UnstringName_Error:

     Err.Raise vbObjectError + 1, "UnstringName", CStr(Err.Number) & " -- " + Err.Description

End Sub




'*******************************************************************************

Public Property Get MainDirectory() As String
    MainDirectory = strMainDirectory
End Property

Public Property Let MainDirectory(ByVal NewDir As String)
    strMainDirectory = NewDir
End Property

'*******************************************************************************

Public Property Get FileEntry(intIndex As Integer) As String
    FileEntry = strFiles(intIndex)
End Property

Public Property Let FileEntry(intIndex As Integer, ByVal strNewFile As String)
    strFiles(intIndex) = strNewFile
End Property
'*******************************************************************************

Public Property Get FilterEntry(intIndex As Integer) As String
    FilterEntry = strFilters(intIndex)
End Property

Public Property Let FilterEntry(intIndex As Integer, ByVal strNewFilterEntry As String)
    strFilters(intIndex) = strNewFilterEntry
    strFilterLen(intIndex) = Len(strNewFilterEntry)
End Property
'*******************************************************************************

Public Property Get DirEntry(intIndex As Integer) As String
    DirEntry = strDirs(intIndex)
End Property

Public Property Let DirEntry(intIndex As Integer, ByVal strNewDirEntry As String)
    strDirs(intIndex) = strNewDirEntry
End Property

'*******************************************************************************

Public Property Get DirectoryCount() As Integer
    DirectoryCount = intDirCt
End Property

Public Property Let DirectoryCount(ByVal NewCount As Integer)
    intDirCt = NewCount
    If intDirCt > 0 Then
        ReDim Preserve strDirs(intDirCt)
    Else
        Erase strDirs
    End If
End Property
'*******************************************************************************

Public Property Get UKFileEntry(intIndex As Integer) As String
    UKFileEntry = strUKFiles(intIndex)
End Property

Public Property Let UKFileEntry(intIndex As Integer, ByVal strNewFile As String)
    strUKFiles(intIndex) = strNewFile
End Property

'*******************************************************************************

Public Property Get UKFileCount() As Integer
    UKFileCount = intUKFileCt
End Property

Private Property Let UKFileCount(ByVal NewCount As Integer)
    intUKFileCt = NewCount
    If intUKFileCt > 0 Then
        ReDim Preserve strUKFiles(intUKFileCt)
    Else
        Erase strUKFiles
    End If
End Property

'*******************************************************************************

Public Property Get FilterCount() As Integer
    FilterCount = intFilterCt
End Property

Public Property Let FilterCount(ByVal NewCount As Integer)
    intFilterCt = NewCount
    If intFilterCt > 0 Then
        ReDim Preserve strFilters(intFilterCt)
        ReDim Preserve strFilterLen(intFilterCt)
    Else
        Erase strFilters
        Erase strFilterLen
    End If
End Property
'*******************************************************************************

Public Property Get SiteName() As String
    SiteName = strName
End Property

Public Property Let SiteName(ByVal NewName As String)
    strName = NewName
End Property
'*******************************************************************************

Public Property Get SiteID() As String
    SiteID = strID
End Property

Public Property Let SiteID(ByVal NewID As String)
    strID = NewID
End Property
'*******************************************************************************

Public Property Get FileCount() As Integer
    FileCount = intFileCt
End Property

Public Property Let FileCount(ByVal NewCount As Integer)
    intFileCt = NewCount
    If intFileCt > 0 Then
        ReDim Preserve strFiles(intFileCt)
        ReDim Preserve strSmallFiles(intFileCt)
        ReDim Preserve Visited(intFileCt)
    Else
        Erase strFiles
        Erase strSmallFiles
        Erase Visited
    End If
End Property


'*******************************************************************************

Public Property Get ChooseRoot() As Boolean
    ChooseRoot = blnChooseRoot
End Property

Public Property Let ChooseRoot(ByVal NewChoice As Boolean)
    blnChooseRoot = NewChoice
End Property

'*******************************************************************************

Public Property Get Root() As String
    Root = strRoot
End Property

Public Property Let Root(ByVal NewRoot As String)
    strRoot = NewRoot
End Property