vbAccelerator - Contents of code file: cBugList.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cBugList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
 As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal
 hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Declare Function FrameRect Lib "user32" (ByVal hDC As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function DrawTextA Lib "user32" (ByVal hDC As Long, ByVal lpStr
 As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hDC As Long, lpRect
 As RECT) As Long

Implements IGridCellOwnerDraw

Private m_sFile As String
Private m_bDirty As Boolean
Private m_grd As vbalGrid
Private m_fnt As StdFont
Private m_lArticleId As Long
Private m_lMaxBugId As Long

Public Sub Initialise(grd As vbalGrid)
   Set m_grd = grd
   configureGrid
End Sub

Public Property Get Dirty() As Boolean
   Dirty = m_bDirty
End Property
Public Sub SetDirty()
   m_bDirty = True
End Sub

Public Property Get ArticleId() As Long
   ArticleId = m_lArticleId
End Property
Public Property Let ArticleId(ByVal lID As Long)
   m_lArticleId = lID
   m_bDirty = True
End Property

Public Sub AddNewBug( _
      ByVal sType As String, _
      ByVal sStatus As String, _
      ByVal sHeadline As String, _
      ByVal sAuthor As String _
   )
Dim lRow As Long
Dim lNewRow As Long
   
   m_grd.Redraw = False
   
   m_lMaxBugId = m_lMaxBugId + 1
   
   ' Add the bug to the end of the list:
   m_grd.AddRow
   lRow = m_grd.Rows
   m_grd.CellText(lRow, 1) = m_lMaxBugId
   m_grd.CellText(lRow, 2) = sType
   m_grd.CellText(lRow, 3) = sAuthor
   m_grd.CellText(lRow, 4) = Now
   m_grd.CellText(lRow, 5) = Now
   m_grd.CellText(lRow, 6) = sStatus
   m_grd.CellText(lRow, 7) = sHeadline
   
   ' Then move it to the right place:
   lNewRow = m_grd.ShiftLastRowToSortLocation()
   
   expandAllGroups
   
   m_grd.Redraw = True
   
End Sub

Public Sub NewBugList(ByVal lArticleId As Long)
   
   m_lArticleId = lArticleId
   m_lMaxBugId = 0
   m_sFile = CStr(m_lArticleId) & ".xml"
   m_bDirty = True
   
   m_grd.Clear
   
End Sub


Public Sub SaveAs(ByVal sFile As String)
   
   If (saveBugList(sFile)) Then
      m_sFile = sFile
      m_bDirty = False
   End If
   
End Sub

Private Function saveBugList(ByVal sFile As String) As Boolean
   MsgBox "Not implemented in this demonstration.", vbInformation
End Function

Public Property Get File() As String
   File = m_sFile
End Property
Public Property Let File(ByVal sFile As String)
   
   If m_grd Is Nothing Then
      Err.Raise 500, App.EXEName & ".cBugList", "cBugList class needs to be
       initialised with a grid before use."
      Exit Property
   End If
   
   m_lArticleId = -1
   m_sFile = ""
   m_lMaxBugId = 0
   
   Dim dom As DOMDocument
   Set dom = loadBugList(sFile)
   If Not (dom Is Nothing) Then
      m_grd.Redraw = False
      m_grd.Clear
      loadBugTrackInfo dom
      setGroups
      m_grd.Redraw = True
      m_sFile = sFile
   Else
      Err.Raise 501, App.EXEName & ".cBugList", _
         "An error occurred trying to read the data file '" & sFile & "'" & _
         vbCrLf & vbCrLf & dom.parseError.reason
   End If
   
End Property

Private Function loadBugList(ByVal sFile As String) As DOMDocument
   
   Dim dom As New DOMDocument
   If dom.Load(sFile) Then
      Set loadBugList = dom
   End If

End Function

Private Function parseDate(ByVal sIsoDate As String) As Date
   parseDate = DateSerial(CLng(Mid(sIsoDate, 1, 4)), CLng(Mid(sIsoDate, 6, 2)),
    CLng(Mid(sIsoDate, 9, 2)))
End Function

Private Function parseType(ByVal sType As String) As String
   Select Case UCase(left(sType, 1))
   Case "B"
      parseType = "Bug"
   Case "C"
      parseType = "Issue"
   Case "Q"
      parseType = "Question"
   End Select
End Function

Private Sub setRowBackColor(ByVal lRow As Long, ByVal sStatus As String)
Dim iCol As Long
Dim lColor As Long
   If left(Trim(LCase(sStatus)), 3) = "res" Then
      lColor = RGB(225, 237, 226)
   Else
      lColor = RGB(251, 246, 206)
   End If
   For iCol = 1 To 7
      m_grd.CellBackColor(lRow, iCol) = lColor
   Next iCol
End Sub

Private Function getBugTypeIconIndex(ByVal sType As String) As Long
   '
End Function

Private Sub loadBugTrackInfo(dom As DOMDocument)
   
   Dim topLevelChildren As IXMLDOMNodeList
   Set topLevelChildren = dom.documentElement.childNodes
   
   Dim i As Long
   For i = 0 To topLevelChildren.length - 1
      
      Dim childNode As IXMLDOMNode
      Set childNode = topLevelChildren.Item(i)
      
      Select Case childNode.nodeName
      Case "ArticleId"
         m_lArticleId = CLng(childNode.firstChild.nodeValue)
      Case "IssueDetails"
         loadDetailsIntoGrid childNode
      Case "Bugs"
         '
      Case "Issues"
         '
      Case "Questions"
         '
      End Select
   Next i
   
End Sub

Private Sub loadDetailsIntoGrid(nod As IXMLDOMNode)
      
   Dim issueNodes As IXMLDOMNodeList
   Set issueNodes = nod.childNodes
   
   Dim i As Long
   Dim j As Long
   
   For i = 0 To issueNodes.length - 1
      Dim issueNode As IXMLDOMNode
      Set issueNode = issueNodes.Item(i)
      
      Dim lRow As Long
      m_grd.AddRow
      lRow = m_grd.Rows
      
      Dim childNodes As IXMLDOMNodeList
      Set childNodes = issueNode.childNodes
      For j = 0 To childNodes.length - 1
         
         Dim childNode As IXMLDOMNode
         Set childNode = childNodes.Item(j)
         Dim sParse As String
         
         Select Case childNode.nodeName
         Case "IssueId"
            m_grd.CellText(lRow, 1) = CLng(childNode.firstChild.nodeValue)
            If (m_grd.CellText(lRow, 1) > m_lMaxBugId) Then
               m_lMaxBugId = m_lMaxBugId + 1
            End If
         Case "Title"
            m_grd.CellText(lRow, 7) = childNode.firstChild.nodeValue
         Case "FirstPosted"
            m_grd.CellText(lRow, 4) = parseDate(childNode.firstChild.nodeValue)
         Case "MostRecentUpdate"
            m_grd.CellText(lRow, 5) = parseDate(childNode.firstChild.nodeValue)
         Case "IssueType"
            sParse = parseType(childNode.firstChild.nodeValue)
            m_grd.CellText(lRow, 2) = sParse
            m_grd.CellIcon(lRow, 2) = getBugTypeIconIndex(sParse)
         Case "CurrentStatus"
            sParse = childNode.firstChild.nodeValue
            m_grd.CellText(lRow, 6) = sParse
            setRowBackColor lRow, sParse
         Case "Author"
            m_grd.CellText(lRow, 3) = childNode.firstChild.firstChild.nodeValue
         End Select
      Next j
      
   Next i
   
   For i = 1 To 6
      If (m_grd.ColumnVisible(i)) Then
         m_grd.AutoWidthColumn i
      End If
   Next i
   
End Sub

Private Sub configureGrid()
   
   With m_grd
      
      ' Allow the grid to be grouped, but
      ' don't show the grouping box
      .HideGroupingBox = True
      .AllowGrouping = True
      
      ' Group rows will be shown by
      ' a gradient underline
      .GroupRowBackColor = vbWindowBackground
      .GroupRowForeColor = vbWindowText
      
      .GridLineColor = vbWindowBackground
      .GridFillLineColor = vbWindowBackground
      .GridLines = True
      
      .SelectionAlphaBlend = True
      .SelectionOutline = True
      .DrawFocusRectangle = False
      
      .RowMode = True
      
      .AddColumn "ID", "Id", eSortType:=CCLSortNumeric
      .AddColumn "Type", "Type", eSortType:=CCLSortStringNoCase
      .AddColumn "Author", "Author", eSortType:=CCLSortStringNoCase
      .AddColumn "Raised", "Raised", sFmtString:="short date",
       eSortType:=CCLSortDateDayAccuracy
      .AddColumn "Updated", "Updated", sFmtString:="short date",
       eSortType:=CCLSortDateDayAccuracy
      .AddColumn "Status", "Status"
      .AddColumn "Title", "Title", eSortType:=CCLSortStringNoCase
      
      .StretchLastColumnToFit = True
      
      
      .OwnerDrawImpl = Me
   End With
   
End Sub

Private Sub setGroups()
   
   ' group by issue type, then by status
   m_grd.ColumnIsGrouped(2) = True
   m_grd.ColumnIsGrouped(6) = True
   
   expandAllGroups
   
End Sub

Private Sub expandAllGroups()
   ' Expand all of the groups
   Dim iRow As Long
   For iRow = 1 To m_grd.Rows
      If (m_grd.RowIsGroup(iRow)) Then
         m_grd.RowGroupingState(iRow) = ecgExpanded
      End If
   Next iRow
End Sub

Private Sub Class_Initialize()
   Set m_fnt = New StdFont
   m_fnt.Name = "Tahoma"
   m_fnt.Size = 8
   m_fnt.Bold = True
End Sub

Private Property Get IFontOf(sFnt As StdFont) As IFont
   Set IFontOf = sFnt
End Property

Private Sub IGridCellOwnerDraw_Draw(cell As vbAcceleratorSGrid.cGridCell, ByVal
 lHDC As Long, ByVal eDrawStage As vbAcceleratorSGrid.ECGDrawStage, ByVal lLeft
 As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long,
 bSkipDefault As Boolean)
   '
   If (eDrawStage = ecgBeforeIconAndText) Then
      If m_grd.RowIsGroup(cell.Row) Then
         drawGroupRow cell, lHDC, lLeft, lTop, lRight, lBottom
         bSkipDefault = True
      End If
   End If
   '
End Sub

Private Sub drawGroupRow( _
      cell As cGridCell, _
      ByVal lHDC As Long, _
      ByVal lLeft As Long, _
      ByVal lTop As Long, _
      ByVal lRight As Long, _
      ByVal lBottom As Long _
   )
Dim hFont As Long
Dim hFontOld As Long
Dim tR As RECT
Dim tBR As RECT
   
   tR.left = lLeft
   tR.top = lTop
   tR.right = lRight
   tR.bottom = lBottom
   
   LSet tBR = tR
   tBR.top = tBR.bottom - 5
   tBR.bottom = tBR.bottom - 2
   If (cell.Selected) Then
      GradientFillRect lHDC, tBR, vbHighlight, vbWindowBackground,
       GRADIENT_FILL_RECT_H
   Else
      GradientFillRect lHDC, tBR, vbButtonShadow, vbWindowBackground,
       GRADIENT_FILL_RECT_H
   End If
   
   hFont = IFontOf(m_fnt).hFont
   hFontOld = SelectObject(lHDC, hFont)
   tR.bottom = tR.bottom - 3
   DrawTextA lHDC, " " & cell.Text, -1, tR, cell.TextAlign
   SelectObject lHDC, hFontOld

End Sub