VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsReportToXL"
Attribute VB_Creatable = True
Attribute VB_Exposed = True
'*********************************************************************
' REPRT2XL.CLS - Sends data from a bug report database to Excel.
'*********************************************************************
Option Explicit
Private Excel As Object, CloseExcel As Boolean
Private BugDBase As New GenericDB
'*********************************************************************
' Expose the Excel Object for further processing.
'*********************************************************************
Public Property Set GetExcel(obj As Object)
    Set obj = Excel
End Property
'*********************************************************************
' Set the Excel object, if possible.
'*********************************************************************
Private Sub Class_Initialize()
    On Error Resume Next
    SplashVisible True, "Establishing a connection with Excel..."
    OLEConnect Excel, "Excel.Application"
    SplashVisible False
End Sub
'*********************************************************************
' Close the workbook (or Excel) without saving any changes.
'*********************************************************************
Private Sub Class_Terminate()
    On Error Resume Next
    Excel.ActiveWorkbook.Saved = True
    If CloseExcel Then
        Excel.Quit
    Else
        Excel.ActiveWorkbook.Close saveChanges:=False
        Excel.WindowState = -4140 'xlMinimized
    End If
    SplashVisible False
    Set Excel = Nothing
End Sub
'*********************************************************************
' Create a summary report in Excel from a database file.
'*********************************************************************
Public Sub ReportToExcel(Optional ByVal FileName)
Dim XLSFile$
    '*****************************************************************
    ' Open the default or create a new workbook, then open the dbase.
    '*****************************************************************
    On Error Resume Next
    SplashVisible True, "Sending data to Excel..."
    XLSFile = App.Path & "\useall.xls"
    If Dir(XLSFile) = "" Then
        Excel.Workbooks.Add
    Else
        Excel.Workbooks.Open XLSFile
    End If
    BugDBase.OpenDB IIf(IsMissing(FileName), App.Path & "\bugs.mdb", _
                        FileName)
    '*****************************************************************
    ' Set the current cell to bold blue with a grey background.
    '*****************************************************************
    With Excel.Range("A1")
        .Font.Bold = True
        .Font.ColorIndex = 11
        .Interior.ColorIndex = 15
        .Interior.Pattern = 1
    End With
    '*****************************************************************
    ' Autofill to the ajacent cells
    '*****************************************************************
    Excel.Selection.AutoFill Destination:=Excel.Range("A1:E1"), Type:=0
    '*****************************************************************
    ' Write the data to Excel.
    '*****************************************************************
    LoadColumn "Bug Details", "Product", "A"
    LoadColumn "Bug Details", "Build", "B"
    LoadColumn "Bug Details", "Title", "C"
    LoadColumn "Bug Details", "Reproducible", "D"
    LoadColumn "Bug Details", "BetaID", "E"
    '*****************************************************************
    ' Select all of the data, and format it. Make XL visible when done.
    '*****************************************************************
    With Excel
        .Range("A2").Select
        .Selection.End(-4121).Select
        .Selection.End(-4161).Select
        .Range(Excel.Selection.Address, "A1").Select
        .ActiveWindow.Zoom = 86
        .Selection.Columns.AutoFit
        .Selection.Sort Key1:=Excel.Range("A2"), Order1:=1, Header:=0, _
        OrderCustom:=1, MatchCase:=False, Orientation:=1
        .Visible = True
        .Range("A1").Select
    End With
    SplashVisible False
End Sub
'*********************************************************************
' Load a column in Excel with the values from the bug database.
'*********************************************************************
Private Sub LoadColumn(TableName$, FieldName$, XLColumn$)
Dim i%, NumItems%, retArray() As String
    '*****************************************************************
    ' Create a dynaset and load an array with its values.
    '*****************************************************************
    On Error Resume Next
    BugDBase.CreateRecordSet TableName
    BugDBase.GetArrayData FieldName, retArray()
    '*****************************************************************
    ' Determine how many items were returned.
    '*****************************************************************
    NumItems = UBound(retArray)
    '*****************************************************************
    ' Print a column heading, then continue.
    '*****************************************************************
    Excel.Range(XLColumn & "1").Select
    Excel.ActiveCell.FormulaR1C1 = FieldName
    Excel.Range(XLColumn & "2").Select
    '*****************************************************************
    ' Iterate through the array and write its value to Excel.
    '*****************************************************************
    For i = 0 To NumItems
        Excel.ActiveCell.FormulaR1C1 = retArray(i)
        Excel.Range(XLColumn & Format(i + 3)).Select
    Next i
End Sub
'*********************************************************************
' OLEConnect takes a pointer to an object variable and class name. If
' this function is successful, then the function returns true and the
' obj argument points to a valid OLE Automation object.
'*********************************************************************
Private Function OLEConnect(obj As Object, sClass As String) As Boolean
    '*****************************************************************
    ' Temporarily turn off error handling
    '*****************************************************************
    On Error Resume Next
    Set obj = GetObject(, sClass)
    '*****************************************************************
    ' If GetObject failed, then try Create
    '*****************************************************************
    If Err = 429 Then
        '*************************************************************
        ' Resume Error Handling
        '*************************************************************
        On Error GoTo OLEConnect_Err
        Set obj = CreateObject(sClass)
        If Err = 0 Then CloseExcel = True
    '*****************************************************************
    ' If any other error, then display & exit
    '*****************************************************************
    ElseIf Err <> 0 Then
        GoSub OLEConnect_Err
    End If
    '*****************************************************************
    ' If this line is executed, then the function succeded
    '*****************************************************************
    OLEConnect = True
    Exit Function
'*********************************************************************
' Display error message and abort
'*********************************************************************
OLEConnect_Err:
    MsgBox Err.Description, vbCritical
    Exit Function
End Function
