home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Programmer'…arterly (Limited Edition) / Visual_Basic_Programmers_Journal_VB-CD_Quarterly_Limited_Edition_1995.iso / code / ch28code / reprt2xl.cls < prev    next >
Encoding:
Text File  |  1995-08-02  |  7.5 KB  |  168 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "clsReportToXL"
  6. Attribute VB_Creatable = True
  7. Attribute VB_Exposed = True
  8. '*********************************************************************
  9. ' REPRT2XL.CLS - Sends data from a bug report database to Excel.
  10. '*********************************************************************
  11. Option Explicit
  12. Private Excel As Object, CloseExcel As Boolean
  13. Private BugDBase As New GenericDB
  14. '*********************************************************************
  15. ' Expose the Excel Object for further processing.
  16. '*********************************************************************
  17. Public Property Set GetExcel(obj As Object)
  18.     Set obj = Excel
  19. End Property
  20. '*********************************************************************
  21. ' Set the Excel object, if possible.
  22. '*********************************************************************
  23. Private Sub Class_Initialize()
  24.     On Error Resume Next
  25.     SplashVisible True, "Establishing a connection with Excel..."
  26.     OLEConnect Excel, "Excel.Application"
  27.     SplashVisible False
  28. End Sub
  29. '*********************************************************************
  30. ' Close the workbook (or Excel) without saving any changes.
  31. '*********************************************************************
  32. Private Sub Class_Terminate()
  33.     On Error Resume Next
  34.     Excel.ActiveWorkbook.Saved = True
  35.     If CloseExcel Then
  36.         Excel.Quit
  37.     Else
  38.         Excel.ActiveWorkbook.Close saveChanges:=False
  39.         Excel.WindowState = -4140 'xlMinimized
  40.     End If
  41.     SplashVisible False
  42.     Set Excel = Nothing
  43. End Sub
  44. '*********************************************************************
  45. ' Create a summary report in Excel from a database file.
  46. '*********************************************************************
  47. Public Sub ReportToExcel(Optional ByVal FileName)
  48. Dim XLSFile$
  49.     '*****************************************************************
  50.     ' Open the default or create a new workbook, then open the dbase.
  51.     '*****************************************************************
  52.     On Error Resume Next
  53.     SplashVisible True, "Sending data to Excel..."
  54.     XLSFile = App.Path & "\useall.xls"
  55.     If Dir(XLSFile) = "" Then
  56.         Excel.Workbooks.Add
  57.     Else
  58.         Excel.Workbooks.Open XLSFile
  59.     End If
  60.     BugDBase.OpenDB IIf(IsMissing(FileName), App.Path & "\bugs.mdb", _
  61.                         FileName)
  62.     '*****************************************************************
  63.     ' Set the current cell to bold blue with a grey background.
  64.     '*****************************************************************
  65.     With Excel.Range("A1")
  66.         .Font.Bold = True
  67.         .Font.ColorIndex = 11
  68.         .Interior.ColorIndex = 15
  69.         .Interior.Pattern = 1
  70.     End With
  71.     '*****************************************************************
  72.     ' Autofill to the ajacent cells
  73.     '*****************************************************************
  74.     Excel.Selection.AutoFill Destination:=Excel.Range("A1:E1"), Type:=0
  75.     '*****************************************************************
  76.     ' Write the data to Excel.
  77.     '*****************************************************************
  78.     LoadColumn "Bug Details", "Product", "A"
  79.     LoadColumn "Bug Details", "Build", "B"
  80.     LoadColumn "Bug Details", "Title", "C"
  81.     LoadColumn "Bug Details", "Reproducible", "D"
  82.     LoadColumn "Bug Details", "BetaID", "E"
  83.     '*****************************************************************
  84.     ' Select all of the data, and format it. Make XL visible when done.
  85.     '*****************************************************************
  86.     With Excel
  87.         .Range("A2").Select
  88.         .Selection.End(-4121).Select
  89.         .Selection.End(-4161).Select
  90.         .Range(Excel.Selection.Address, "A1").Select
  91.         .ActiveWindow.Zoom = 86
  92.         .Selection.Columns.AutoFit
  93.         .Selection.Sort Key1:=Excel.Range("A2"), Order1:=1, Header:=0, _
  94.         OrderCustom:=1, MatchCase:=False, Orientation:=1
  95.         .Visible = True
  96.         .Range("A1").Select
  97.     End With
  98.     SplashVisible False
  99. End Sub
  100. '*********************************************************************
  101. ' Load a column in Excel with the values from the bug database.
  102. '*********************************************************************
  103. Private Sub LoadColumn(TableName$, FieldName$, XLColumn$)
  104. Dim i%, NumItems%, retArray() As String
  105.     '*****************************************************************
  106.     ' Create a dynaset and load an array with its values.
  107.     '*****************************************************************
  108.     On Error Resume Next
  109.     BugDBase.CreateRecordSet TableName
  110.     BugDBase.GetArrayData FieldName, retArray()
  111.     '*****************************************************************
  112.     ' Determine how many items were returned.
  113.     '*****************************************************************
  114.     NumItems = UBound(retArray)
  115.     '*****************************************************************
  116.     ' Print a column heading, then continue.
  117.     '*****************************************************************
  118.     Excel.Range(XLColumn & "1").Select
  119.     Excel.ActiveCell.FormulaR1C1 = FieldName
  120.     Excel.Range(XLColumn & "2").Select
  121.     '*****************************************************************
  122.     ' Iterate through the array and write its value to Excel.
  123.     '*****************************************************************
  124.     For i = 0 To NumItems
  125.         Excel.ActiveCell.FormulaR1C1 = retArray(i)
  126.         Excel.Range(XLColumn & Format(i + 3)).Select
  127.     Next i
  128. End Sub
  129. '*********************************************************************
  130. ' OLEConnect takes a pointer to an object variable and class name. If
  131. ' this function is successful, then the function returns true and the
  132. ' obj argument points to a valid OLE Automation object.
  133. '*********************************************************************
  134. Private Function OLEConnect(obj As Object, sClass As String) As Boolean
  135.     '*****************************************************************
  136.     ' Temporarily turn off error handling
  137.     '*****************************************************************
  138.     On Error Resume Next
  139.     Set obj = GetObject(, sClass)
  140.     '*****************************************************************
  141.     ' If GetObject failed, then try Create
  142.     '*****************************************************************
  143.     If Err = 429 Then
  144.         '*************************************************************
  145.         ' Resume Error Handling
  146.         '*************************************************************
  147.         On Error GoTo OLEConnect_Err
  148.         Set obj = CreateObject(sClass)
  149.         If Err = 0 Then CloseExcel = True
  150.     '*****************************************************************
  151.     ' If any other error, then display & exit
  152.     '*****************************************************************
  153.     ElseIf Err <> 0 Then
  154.         GoSub OLEConnect_Err
  155.     End If
  156.     '*****************************************************************
  157.     ' If this line is executed, then the function succeded
  158.     '*****************************************************************
  159.     OLEConnect = True
  160.     Exit Function
  161. '*********************************************************************
  162. ' Display error message and abort
  163. '*********************************************************************
  164. OLEConnect_Err:
  165.     MsgBox Err.Description, vbCritical
  166.     Exit Function
  167. End Function
  168.