VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "dwHTMLcollection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
' HTML element collection
' Desaware ActiveX Gallimaufry
' Copyright (c) 1997 by Desaware Inc.  All Rights Reserved

Option Explicit

'local variable to hold collection
Private mCol() As dwHTMLelement
Private mColUsed As Long   ' Number of elements used
Private mColSize As Long   ' Number of elements total
Private Const GRANULARITY = 5

Public Function Append(objNewMember As dwHTMLelement)
   If mColSize = mColUsed Then
      ' Need to increase the array size
      mColSize = mColSize + GRANULARITY
      ReDim Preserve mCol(mColSize)
   End If
   mColUsed = mColUsed + 1
   Set mCol(mColUsed) = objNewMember
End Function


' Retrieve the number of objects in the collection
Public Property Get Count() As Long
   Count = mColUsed
End Property


Public Property Get item(vntIndex As Long) As dwHTMLelement
   If vntIndex < 1 Or vntIndex > mColUsed Then
      RaiseError 9   ' Subscript error
   End If
   Set item = mCol(vntIndex)
End Property

' Remove the specified item
Public Sub Remove(vntIndex As Variant)
   Dim ctr&
   If vntIndex < 1 Or vntIndex > mColUsed Then
      RaiseError 9   ' Subscript error
   End If
   ' Shift contents of array
   For ctr = vntIndex To mColUsed - 1
      Set mCol(ctr) = mCol(ctr + 1)
   Next ctr
   Set mCol(mColUsed) = Nothing
   mColUsed = mColUsed - 1
   
   If mColSize - mColUsed > GRANULARITY * 2 Then
      mColSize = mColSize - GRANULARITY
      ReDim Preserve mCol(mColSize)
   End If
End Sub


Private Sub Class_Initialize()
   ' Dimension space for first element
   ReDim mCol(GRANULARITY)
   mColSize = GRANULARITY
End Sub


Private Sub Class_Terminate()
   ' mCol array objects will terminate when it goes out of scope here.
End Sub

' Parse an entire page into a collection of dwHTMLelements
Public Function LoadFromString(tinputstring As String)
   Dim inputstring$
   inputstring = tinputstring
   Dim CurrentElement As dwHTMLelement
   Do
      Set CurrentElement = New dwHTMLelement
      inputstring = CurrentElement.LoadFromString(inputstring)
      Append CurrentElement
   Loop While Len(inputstring) > 0
End Function

' Find an element that has the specified tag, content pair
' Empty content string matches all
' Case sensitive defaults to True
' Returns 0 if nothing found
Public Function Find(FirstElement As Long, ByVal Tag As String, Optional ByVal Contents As String, Optional CaseSensitive = True) As Long
   Dim LastElement&
   Dim CurElement&
   Dim thtml As dwHTMLelement
   Dim bFoundTag As Boolean
   Dim bFoundContents As Boolean
   LastElement = Count()
   ' Don't bother if already past the limit
   If FirstElement > Count Then Exit Function
   ' Compare upper case if case insensitive
   If Not CaseSensitive Then
      Tag = UCase$(Tag)
      Contents = UCase$(Contents)
   End If
   For CurElement = FirstElement To LastElement
      Set thtml = mCol(CurElement)
      ' First check tag
      If Tag <> "" Then
         If Not CaseSensitive Then
            If Tag = UCase$(thtml.Tag) Then
               bFoundTag = True
            End If
         Else
            If Tag = thtml.Tag Then
               bFoundTag = True
            End If
         End If
      Else
         bFoundTag = True
      End If
      ' Now check contents
      If Contents <> "" Then
         If Not CaseSensitive Then
            If Contents = StripLinefeeds(UCase$(thtml.Contents)) Then
               bFoundContents = True
            End If
         Else
            If Contents = StripLinefeeds(thtml.Contents) Then
               bFoundContents = True
            End If
         End If
      Else
         bFoundContents = True
      End If
      ' Match both is a hit
      If bFoundTag And bFoundContents Then
         Find = CurElement
         Exit Function
      End If
   Next
   
End Function

' Searches for a sequence of tags starting with element FirstElement.
' CaseSensitive determines if the search is case sensitive
' Then follows a list of tags to find. Tags must appear in the specified order
Public Function FindTagSequence(FirstElement As Long, CaseSensitive As Boolean, ParamArray TagSequence() As Variant) As Long
   Dim CurrentBase As Long
   Dim LastElement As Long
   Dim CurrentParam As Long
   Dim FirstParam As Long
   Dim LastParam As Long
   Dim bCompareFailed As Boolean
   ' Expected and current position of tag
   Dim ExpectedPosition As Long
   Dim CurrentPosition As Long
   
   LastElement = Count()
   CurrentBase = FirstElement
   LastParam = UBound(TagSequence)
   FirstParam = LBound(TagSequence)
   Do
      bCompareFailed = False
      ' Try first match
      CurrentBase = Find(CurrentBase, TagSequence(FirstParam), , CaseSensitive)
      ' If no match, exit now
      If CurrentBase = 0 Then Exit Function
      ' Now try the other parameters
      ExpectedPosition = CurrentBase + 1
      For CurrentParam = FirstParam + 1 To LastParam
         CurrentPosition = Find(ExpectedPosition, TagSequence(CurrentParam), , CaseSensitive)
         ' If it's not the correct position, exit right away
         If ExpectedPosition <> CurrentPosition Then
            bCompareFailed = True
            Exit For
         End If
         ' Increment the expected value
         ExpectedPosition = ExpectedPosition + 1
      Next CurrentParam
      If Not bCompareFailed Then
         ' Compare succeeded on all tags!
         FindTagSequence = CurrentBase
         Exit Function
      End If
      CurrentBase = CurrentBase + 1
   Loop While CurrentBase <= LastElement
   
End Function

' Find next element that has no tag
' Stops search at closetag if present
Public Function FindNextNonTag(Optional FirstLoc As Long = 1, Optional CloseTag As String) As Long
   Dim LastElement&
   Dim CurElement&
   Dim thtml As dwHTMLelement
   LastElement = Count()
   For CurElement = FirstLoc To LastElement
      Set thtml = mCol(CurElement)
      If thtml.Tag = "" Then
         FindNextNonTag = CurElement
         Exit Function
      Else
         If thtml.Tag = CloseTag Then Exit For
      End If
   Next
End Function

' FindNextContent starts at FirstLoc,
' Looks for string "FirstContent" in a content field using CaseSensitive
' Then looks for the next non-tag field and returns it
' Updates the FirstLoc parameter to the location of the content tag returned
' Returns empty string on failure
' This function is useful for finding content pairs
Public Function FindNextContent(FirstLoc As Long, FirstContent As String, Optional CaseSensitive As Boolean = True) As String
   Dim HtmlFoundIdx&
   HtmlFoundIdx = FirstLoc
   HtmlFoundIdx = Find(HtmlFoundIdx, "", FirstContent, CaseSensitive)
   If HtmlFoundIdx > 0 Then HtmlFoundIdx = FindNextNonTag(HtmlFoundIdx + 1)
   If HtmlFoundIdx > 0 Then
      FindNextContent = mCol(HtmlFoundIdx).Contents
      FirstLoc = HtmlFoundIdx
   End If

End Function

' AppendThroughTag  starts at FirstLoc,
' Looks for string "FirstContent" in a content field
' Then appends all non-tag fields through the specified closing tag
' Updates the FirstLoc parameter to the location of the content tag returned
' Returns empty string on failure
' This function is useful for combining content fields that are separated by formatting tags.
Public Function AppendThroughTag(FirstLoc As Long, FirstContent As String, ByVal CloseTag As String) As String
   Dim HtmlFoundIdx&
   Dim BuildString$
   HtmlFoundIdx = FirstLoc
   CloseTag = UCase$(CloseTag)
   If FirstContent <> "" Then HtmlFoundIdx = Find(HtmlFoundIdx, "", FirstContent)
   If HtmlFoundIdx > 0 Then HtmlFoundIdx = FindNextNonTag(HtmlFoundIdx + 1, CloseTag)
   If HtmlFoundIdx > 0 Then
      Do While HtmlFoundIdx <= Me.Count
         If UCase$(mCol(HtmlFoundIdx).Tag) = CloseTag Then Exit Do
         If mCol(HtmlFoundIdx).Tag = "" Then
            BuildString = BuildString & StripLinefeeds(mCol(HtmlFoundIdx).Contents)
         End If
         HtmlFoundIdx = HtmlFoundIdx + 1
      Loop
      FirstLoc = HtmlFoundIdx
   End If
   AppendThroughTag = BuildString
End Function


' Raises an internal error
Private Sub RaiseError(ByVal errnum&)
   Dim ErrNumToUse&
   If errnum >= 1000 Then
      ' Custom error
      Err.Raise vbObjectError + errnum, "dwHTMLcollection", GetErrorString(errnum), App.HelpFile, errnum + HelpBaseOffset
   Else
      ' Raise VB error
      Err.Raise errnum, "dwHTMLcollection", GetErrorString(errnum)
   End If
End Sub
