Chip 2001 Special/chip-cd_2001_spec_05.zip/spec_05/apps/crystal/disk18/Xvb388._/Xvb388.

Text File | 1999-08-23 | 7KB | 193 lines

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

Private m_strFilename As String
Private m_strReportPath

Private m_crwApplication As CRPEAuto.Application
Private m_crwReport As CRPEAuto.Report
Private m_crwView As CRPEAuto.View
Private m_crwDatabase As CRPEAuto.Database
Private m_crwDatabaseTable As CRPEAuto.DatabaseTable
Private m_crwSubReport As CRPEAuto.Report

Public WithEvents m_crwWindow As CRPEAuto.Window
Attribute m_crwWindow.VB_VarHelpID = -1


Public Sub CloseWindow()
  If Not m_crwWindow Is Nothing Then
    frmMain.mnuFileClose.Enabled = False
    m_crwWindow.Close
    Set m_crwWindow = Nothing
    Set m_crwView = Nothing
  End If
End Sub

Public Sub LaunchReport(strReportName As String)
  On Error GoTo LaunchReport_Error

  Screen.MousePointer = vbHourglass

  If m_crwApplication Is Nothing Then Set m_crwApplication = CreateObject("Crystal.CRPE.Application")

  If m_strReportPath = "" Then
    m_strReportPath = Mid(App.Path, 1, (Len(App.Path) - 23)) & "\reports\xtreme\"
  End If

  m_strFilename = m_strReportPath & strReportName & ".rpt"
  While Dir(m_strFilename) = ""
    If MsgBox("Could not open " & m_strFilename & vbCrLf & vbCrLf & _
    "Would you like to browse?", vbYesNo) = vbYes Then
      frmMain.dlgCommonDialog.CancelError = True
      frmMain.dlgCommonDialog.filename = m_strFilename
      frmMain.dlgCommonDialog.Filter = "*.rpt"
      frmMain.dlgCommonDialog.ShowOpen
      m_strFilename = frmMain.dlgCommonDialog.filename
    Else
      GoTo LaunchReport_Error
    End If
  Wend

  Screen.MousePointer = vbHourglass

  'open the report (but not start it)
  Set m_crwReport = m_crwApplication.OpenReport(m_strFilename)

  Set m_crwDatabase = m_crwReport.Database
  For Each m_crwDatabaseTable In m_crwDatabase.Tables
    m_crwDatabaseTable.Location = frmMain.gsDatabase
  Next

  Screen.MousePointer = vbNormal

  frmOptions.ResetSpecial
  Select Case strReportName
    Case "empprof"
      frmOptions.SetSpecial "Change the 'name' formula to display 'first last' instead of 'last, first'.", "Formula"
    Case "wwsales"
      frmOptions.SetSpecial "Change the graph from pie to bar.", "Graph"
    Case "customer"
      Set m_crwSubReport = m_crwReport.OpenSubreport("orders.rpt")
      Set m_crwDatabase = m_crwSubReport.Database
      For Each m_crwDatabaseTable In m_crwDatabase.Tables
        m_crwDatabaseTable.Location = frmMain.gsDatabase
      Next
      frmOptions.SetSpecial "Change the customer name group sort direction from ascending to descending.", "GroupSortDirection"
    Case "invent"
      frmOptions.SetSpecial "Select only items that need to be ordered.", "RecordSelect"
  End Select

  If frmOptions.Display(m_crwReport) = orCancel Then GoTo LaunchReport_Exit

  Dim strWindowTitle As String
  If frmOptions.txtWindowTitle.Text = "" Then
    strWindowTitle = m_strFilename
  Else
    strWindowTitle = frmOptions.txtWindowTitle.Text
  End If

  Select Case strReportName
    Case "empprof"

      If frmOptions.GetSpecial(1) Then
        'Change the 'name' formula to display 'first last' instead of 'last, first'.
        m_crwReport.FormulaFields.Item("name").Text = "{Employee.First Name} + ' ' + {Employee.Last Name}"
      End If
    Case "wwsales"
      If frmOptions.GetSpecial(1) Then
        'get the section with the graph
        Dim crwSection As Section
        Set crwSection = m_crwReport.Sections.Item(3)
        'get the graph on it
        Dim crwGraph As GraphObject
        Set crwGraph = crwSection.ReportObjects.Item(1)
        'change the graph from pie to bar
        crwGraph.DisplayType = crFaked3DSideBySideBarGraph
      End If
    Case "customer"
      If frmOptions.GetSpecial(1) Then
        'get the area with the group on name
        Dim crwArea As Area
        Set crwArea = m_crwReport.Areas.Item(5)
        'get the group area options for it
        Dim crwGrpOpts As GroupAreaOptions
         Set crwGrpOpts = crwArea.GroupOptions
        'change the sort direction
        crwGrpOpts.SortDirection = crDescendingOrder
      End If
    Case "invent"
      If frmOptions.GetSpecial(1) Then
        'add statement to select only items that need to be ordered
        m_crwReport.RecordSelectionFormula = m_crwReport.RecordSelectionFormula & "AND {@status} = 'ORDER'"
      End If
  End Select

  If frmOptions.optOutputPreview.Value Then
    'preview the report, get references to the view and window for future use
    Set m_crwView = m_crwReport.Preview(strWindowTitle)
    Set m_crwWindow = m_crwView.Parent

  ElseIf frmOptions.optOutputApplication.Value Then
    'preview the report, get references to the view and window for future use
    frmMain.mnuFileClose.Enabled = True
    Set m_crwView = m_crwReport.Preview(strWindowTitle, 0, 0, CInt(frmMain.ScaleWidth / Screen.TwipsPerPixelX), CInt((frmMain.ScaleHeight - frmMain.sbStatusBar.Height) / Screen.TwipsPerPixelY), , frmMain.hwnd)
    Set m_crwWindow = m_crwView.Parent

  ElseIf frmOptions.optOutputPrinter.Value Then
    'print the report
    m_crwReport.PrintOut

  ElseIf frmOptions.optOutputExportEmailWord.Value Then
    Err.Number = 1
    Err.Source = "XtremeDemo"
    Err.Description = "Sorry, email export not implemented yet.  Please try again later."
    GoTo LaunchReport_Error

  ElseIf frmOptions.optOutputExportFileExcel.Value Then
    Err.Number = 1
    Err.Source = "XtremeDemo"
    Err.Description = "Sorry, file export not implemented yet.  Please try again later."
    GoTo LaunchReport_Error

  End If

LaunchReport_Exit:
  Screen.MousePointer = vbNormal
  Exit Sub

LaunchReport_Error:
  m_strFilename = ""
  If Not m_crwReport Is Nothing Then Set m_crwReport = Nothing
  If m_crwApplication Is Nothing Then Err.Description = "Unable to CreateObject(""Crystal.CRPE.Application"")"
  MsgBox Err.Description, vbCritical, Err.Source, Err.HelpFile, Err.HelpContext
  GoTo LaunchReport_Exit
End Sub

'event handler for drill down on detail


Private Sub m_crwWindow_DrillOnDetail(ByVal FieldValues As Variant, ByVal SelectedFieldIndex As Long, useDefault As Boolean, ByVal ReportName As Variant)
 Dim fldval As CRPEAuto.FieldValue
  Select Case SelectedFieldIndex

  Case -1
    ' User clicked on detail, but not on a field
    MsgBox "No field selected", , "Drill Down on Detail Event Captured"
  Case Else
    ' User clicked on detail, and on a valid field
    Set fldval = FieldValues(SelectedFieldIndex)
    MsgBox "Drilled on " & fldval.Name & ", value is: " & fldval.Value, , "Drill Down on Detail Event Captured "

  End Select
End Sub