io Programmo 32/IOPROG_32.ISO/SOFT/SqlEval7/MSOLAP/samples/Samples.exe/VbMdHTMLdll/Table.cls

Visual Basic class definition | 1998-10-30 | 10.6 KB | 305 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 = "Table"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'
' MDTHML Table
'
' This class implements a middle-tier object that an HTML table from a
' passed-in ADO/MD Cellset.  The object requires IIS 4.0 or better as it
' uses IIS's ScriptingContext object to acquire access to an output
' stream for the HTML.
'
' Typical usage:
'
' Set tbl = Server.CreateObject ("MDHTML.Table")
' tbl.Display (cs)
'
' 10.12.98  BillBak     Initial coding
' 10.14.98  BillBak     Clean-up, documentation
'

Option Explicit

Public m_sc As ScriptingContext         ' passed to us by IIS on the start page event

' Variables to hold the property values
Public m_szTableHTMLStart As String     ' HTML for <TABLE> tag
Public m_szTableHTMLEnd As String       ' HTML for </TABLE> tag
Public m_szRowHeaderHTMLStart As String ' HTML for <TD> tag for row headers
Public m_szRowHeaderHTMLEnd As String   ' HTML for </TD> tag for row headers
Public m_szColHeaderHTMLStart As String ' HTML for <TD> tag for col headers
Public m_szColHeaderHTMLEnd As String   ' HTML for </TD> tag for col headers
Public m_szDataCellHTMLStart As String  ' HTML for <TD> tag for data cells
Public m_szDataCellHTMLEnd As String    ' HTML for </TD> tag for data cells

Public Sub OnStartPage(sContext As ScriptingContext)

    ' IIS calls us here when it loads a page containing the control.  The IIS
    ' ScriptingContext object has methods to return references to the IIS
    ' Application, Session, Response and Request objects.  We use the Write
    ' method on the Response object to emit HTML streams.

    Set m_sc = sContext                 ' saved for use during the Display method

    ' Default HTML tags for the various elements of the table
    m_szTableHTMLStart = "<TABLE>"
    m_szTableHTMLEnd = "</TABLE>"
    m_szRowHeaderHTMLStart = "<TD>"
    m_szRowHeaderHTMLEnd = "</TD>"
    m_szColHeaderHTMLStart = "<TD>"
    m_szColHeaderHTMLEnd = "</TD>"
    m_szDataCellHTMLStart = "<TD>"
    m_szDataCellHTMLEnd = "</TD>"

End Sub


Sub Display(cs As ADOMD.Cellset)

    ' This is where we do the work.  We handle Cellsets with one or two
    ' axes.  We punt if the Cellset has zero axes.

    ' Get the IIS response object for our HTML output
    Dim response As response
    Set response = m_sc.response

    ' Do we have any interesting axes?
    If cs.Axes.Count < 1 Then
        response.Write "The cellset has no displayable axes.<BR>"
    End If

    Dim x As Integer, y As Integer      ' general purpose loop variables

    'These variables store the number of "layers" on each axis
    Dim nColHeaderDepth As Integer, nRowHeaderWidth As Integer

    ' How many "layers" do the headers have?
    nColHeaderDepth = cs.Axes(0).DimensionCount
    If cs.Axes.Count > 1 Then
        nRowHeaderWidth = cs.Axes(1).DimensionCount
    Else
        nRowHeaderWidth = 0
    End If

    ' Create the HTML for the upper-left cell.  This requires modifying the
    ' m_szRowHeaderHTMLStart variable to have a COLSPAN modifier.  So for
    ' example, if Axis(1) (the row labels) contains two dimensions, the
    ' width of the row labels is two columns.  The upper left cells are
    ' empty (because they are left of the leftmost column and above the
    ' first row.)  So we need to convert the HTML from "<TD></TD>" into
    ' "<TD COLSPAN=2></TD>".

    Dim szULHTML As String
    szULHTML = InsertColspan(m_szColHeaderHTMLStart, nRowHeaderWidth) & _
                        m_szColHeaderHTMLEnd

    ' Write the <TABLE> tag
    response.Write m_szTableHTMLStart

    ' Write out the layers of the column header.  We have one layer for
    ' each dimension in the axis.  So if the MDX query contains a CrossJoin,
    ' we have to emit more than one HTML Table row.  For example the function
    ' CrossJoin ({A, B, C}, {[1], [2], [3]}) produces an axis with nine
    ' positions.  Each position contains two members.  It looks like:
    '
    '   A  A  A  B  B  B  C  C  C
    '   1  2  3  1  2  3  1  2  3
    '
    ' The first pass through the loop will display A  A  A  B  etc.
    ' The second pass gets the inner members.

    Dim p As ADOMD.Position
    Dim nLayer As Integer
    For nLayer = 0 To nColHeaderDepth - 1

        response.Write "<TR>"               ' start this row
        response.Write szULHTML             'upper-left cell
        ' Run across the positions collection in axis 0 using only one
        ' of the members for each position.  We only output a cell when we notice
        ' that the caption for the current column (position) in this layer is
        ' different than the previous caption.  When we do output a cell, we use
        ' the COLSPAN tag to make that cell of the table span multiple columns.
        ' The goal is to display:
        '
        '   A  A  A  B  B  B  C  C  C
        '   1  2  3  1  2  3  1  2  3
        '
        ' as:
        '
        '   A        B        C
        '   1  2  3  1  2  3  1  2  3
        '

        ' Seed the previous-caption variable with the first caption.  We need to
        ' trigger output when we finally see something different, or hit the
        ' end of the position list.
        Dim szPreviousCaption As String, nColCount As Integer
        szPreviousCaption = cs.Axes(0).Positions(0).Members(nLayer).Caption
        nColCount = 0

        For Each p In cs.Axes(0).Positions
            If (p.Members(nLayer).Caption = szPreviousCaption) Then
                nColCount = nColCount + 1   ' one more just like the previous
            Else
                ' A new caption, write what we've saved up (szPreviousCaption and
                ' nColCount) and then reset these variables.
                response.Write InsertColspan(m_szColHeaderHTMLStart, nColCount)
                response.Write szPreviousCaption
                response.Write m_szColHeaderHTMLEnd
                nColCount = 1
                szPreviousCaption = p.Members(nLayer).Caption
            End If
        Next
        ' Write the last column
        response.Write InsertColspan(m_szColHeaderHTMLStart, nColCount)
        response.Write szPreviousCaption
        response.Write m_szColHeaderHTMLEnd
        response.Write "</TR>"          ' finish off this row

    Next nLayer

    ' Write out the rows of data including the row headers.  We have the same goal
    ' as before, to only write repeating captions once.  In this case we are able
    ' to write the caption at the front of the span since we are not using ROWSPAN.
    ' So we use an array of previous captions and check each caption against the
    ' previous caption at that level.
    '
    Dim m As ADOMD.Member
    ReDim szPrevCaption(nRowHeaderWidth) As String  ' an array of previous captions
    For x = 1 To nRowHeaderWidth
        szPrevCaption(x) = ""                       ' init to null strings
    Next x

    y = 0
    ' Loop over the Rows access or Axis(1)
    For Each p In cs.Axes(1).Positions

        response.Write ("<TR>")         ' start this row

        ' First write a cell for each member in the axis at this position
        x = 1
        For Each m In p.Members
            response.Write m_szRowHeaderHTMLStart
            If m.Caption <> szPrevCaption(x) Then
                ' This caption is different that the last one we wrote for this
                ' level.  Write it and update the previous caption for this level.
                response.Write m.Caption
                szPrevCaption(x) = m.Caption
            End If
            response.Write m_szRowHeaderHTMLEnd
            x = x + 1
        Next

        ' Now write the data cells for this row
        For x = 0 To cs.Axes(0).Positions.Count - 1
            response.Write m_szDataCellHTMLStart
            response.Write cs(x, y).FormattedValue
            response.Write m_szDataCellHTMLEnd
        Next x

        response.Write "</TR>"          ' finish this row
        y = y + 1
    Next

    ' Finish the table
    response.Write m_szTableHTMLEnd

End Sub

Public Property Let RowHeaderHTMLStart(ByVal myVal As String)

    m_szRowHeaderHTMLStart = myVal

End Property

Public Property Let RowHeaderHTMLEnd(ByVal myVal As String)

    m_szRowHeaderHTMLEnd = myVal

End Property


Public Property Let ColHeaderHTMLStart(ByVal myVal As String)

    m_szColHeaderHTMLStart = myVal

End Property

Public Property Let ColHeaderHTMLEnd(ByVal myVal As String)

    m_szColHeaderHTMLEnd = myVal

End Property


Public Property Let DataCellHTMLStart(ByVal myVal As String)

    m_szDataCellHTMLStart = myVal

End Property

Public Property Let DataCellHTMLEnd(ByVal myVal As String)

    m_szDataCellHTMLEnd = myVal

End Property


Public Property Let TableHTMLStart(ByVal myVal As String)

    m_szTableHTMLStart = myVal

End Property

Public Property Let TableHTMLEnd(ByVal myVal As String)

    m_szTableHTMLEnd = myVal

End Property

Function InsertColspan(szTag, nCols)

    ' Takes the passed tag string (similar to <TD Property=VALUE><B>) and adds
    ' COLSPAN=n (where n is nCols) right after the tag name

    Dim iInsertPoint As Integer         ' index to where we open the string
    Dim iFirstCaret As Integer          ' index to the caret

    iFirstCaret = InStr(1, szTag, "<")
    If iFirstCaret = 0 Then
        ' No HTML tag in the passed string, make our own
        InsertColspan = "<TD COLSPAN=" & Str(nCols) & ">"
        Exit Function
    End If

    ' Get first space after the tag
    iInsertPoint = InStr(iFirstCaret, szTag, " ")
    If iInsertPoint = 0 Then
        ' No spaces, insert before the first close caret
        iInsertPoint = InStr(iFirstCaret, szTag, ">")
        If iInsertPoint = 0 Then
            ' Sheesh, no closing caret!  Append the COLSPAN modifier and be done
            InsertColspan = szTag & " COLSPAN=" & Str(nCols) & " >"
            Exit Function
        End If
    End If

    ' Split the string into left and right parts around the insertion point
    Dim szLeft As String, szRight As String
    szLeft = Left(szTag, iInsertPoint - 1)
    szRight = Right(szTag, Len(szTag) - iInsertPoint + 1)

    InsertColspan = szLeft & " COLSPAN=" & Str(nCols) & szRight

End Function