frmxtremeorders.frm

报表是数据库应用程序中非常重要的组成部分

         Height          =   375
         Left            =   240
         TabIndex        =   28
         Top             =   960
         Width           =   3495
      End
   End
   Begin VB.Label Label1 
      Alignment       =   2  'Center
      Caption         =   "报表设计模块"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   14.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FF0000&
      Height          =   375
      Left            =   1080
      TabIndex        =   8
      Top             =   0
      Width           =   3015
   End
   Begin VB.Label Label4 
      Alignment       =   1  'Right Justify
      Caption         =   "&To:"
      Height          =   255
      Left            =   5880
      TabIndex        =   2
      Top             =   4920
      Width           =   495
   End
   Begin VB.Label Label3 
      Alignment       =   1  'Right Justify
      Caption         =   "&From:"
      Height          =   255
      Left            =   5520
      TabIndex        =   0
      Top             =   5760
      Width           =   975
   End
End
Attribute VB_Name = "frmXtremeOrders"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdOK_Click()
    Dim txtFromD As String
    Dim txtToD As String

    On Error GoTo cmdOK_Click_Error
    
    Dim strSelectionFormula As String
    Dim strSubHeading As String
    
    txtFromD = Trim(Combo1) & "-" & Trim(Combo2) & "-" & Trim(Combo3)
    txtToD = Trim(Combo4) & "-" & Trim(Combo5) & "-" & Trim(Combo6)
    
    
    'Validate controls
    If Not IsDate(txtFromD) Then
        MsgBox "请选择报表数据开始日期!", vbOKOnly + vbCritical, "报表设计"
        Combo1.SetFocus
        Exit Sub
    End If  'IsNull(txtFromDate)...

    If Not IsDate(txtToD) Then
        MsgBox "请选择报表数据结束日期!", vbOKOnly + vbCritical, "报表设计"
        Combo4.SetFocus
        Exit Sub
    End If  'IsNull(txtFromDate)...


    If OptEmail And txtAddress = "" Then
        MsgBox "请输入电子邮件地址", vbOKOnly + vbCritical, "报表设计"
        txtAddress.SetFocus
        Exit Sub
    End If  'OptEmail And IsNull(txtAddress)
    
    If CDate(txtFromD) > CDate(txtToD) Then
        MsgBox "结束日期必须不早于开始时间", vbOKOnly + vbCritical, "报表设计"
        Combo4.SetFocus
        Exit Sub
    End If  'CDate(txtFromDate) > CDate(txtToDate)
    
    Screen.MousePointer = vbHourglass
    Report.DiscardSavedData 'required for consistent results
    
    'Supply record selection based on dates
    strSelectionFormula = "{Orders.Order Date} in #" & _
    txtFromD & "# to #" & txtToD & "#"
    'txtFromDate & "# to #" & txtToDate & "#"
    
    Report.RecordSelectionFormula = strSelectionFormula
    
    'Set @Order + Tax formula
    Dim FormulaField As CRAXDRT.FormulaFieldDefinition
    Set FormulaField = Report.FormulaFields.GetItemByName("Order + Tax")
    
    If txtTaxRate = "" Then
        'Report.FormulaFields(1).Text = "{Orders.Order Amount}"
        FormulaField.Text = "{Orders.Order Amount}"
    Else
        'Report.FormulaFields(1).Text = "{Orders.Order Amount} * " & Str(txtTaxRate / 100 + 1)
        FormulaField.Text = "{Orders.Order Amount} * " & Str(txtTaxRate / 100 + 1)
    End If  'txtTaxRate = ""
    
    'Set parameter value
    'Alternative method is to format details section within VB
    'If txtHighlight = "" Then
    '    Report.ParameterFields(1).AddCurrentValue (0)
    'Else
    '    Report.ParameterFields(1).AddCurrentValue (Val(txtHighlight))
    'End If  'txtHighlight = ""
    
    'Set grouping
    If cboGroupBy = "季度" Then
        Report.Areas("GH").GroupConditionField = _
            Report.Database.Tables(1).Fields(5) 'Orders.Order Date
        Report.Areas("GH").GroupCondition = crGCQuarterly
    Else
        Report.Areas("GH").GroupConditionField = _
            Report.Database.Tables(2).Fields(3) 'Customer.Customer Name
        Report.Areas("GH").GroupCondition = crGCAnyValue
    End If  'cboGroupBy = "Quarter"
    
    'Hide/show sections
    With Report
        If chkSummary Then
            .Areas("D").HideForDrillDown = True
            .PHb.Suppress = True
            .Areas("GH1").HideForDrillDown = True
            .GH1A.Suppress = False
            .GH1B.Suppress = False
        Else
            .Areas("D").HideForDrillDown = False
            .PHb.Suppress = False
            .Areas("GH1").HideForDrillDown = False
            .GH1A.Suppress = False
            .GH1B.Suppress = True
        End If  'chkSummary
    End With    'Report
    
    'Set SubHeading text object
    'strSubHeading = txtFromDate & " through " & txtToDate
    strSubHeading = txtFromD & " 到 " & txtToD
    strSubHeading = strSubHeading & ", 按 " & cboGroupBy
    If txtTaxRate = "" Then
        strSubHeading = strSubHeading & ", 没有税"
    Else
        strSubHeading = strSubHeading & ", Sales Tax = " & txtTaxRate & "%"
    End If  'txtTaxRate = ""
    Report.SubHeading.SetText (strSubHeading)
    'Note: parentheses around argument to SetText method are optional
    
    'Set output destination
    If optPreview Then frmViewer.Show
    If OptPrint Then Report.PrintOut (True)
    If OptEmail Then
        With Report
            .ExportOptions.DestinationType = crEDTEMailMAPI
            .ExportOptions.MailToList = txtAddress
            .ExportOptions.MailSubject = "Here's the Xtreme Orders Report"
            .ExportOptions.MailMessage = "Attached is a PDF file showing the latest Xtreme Orders Report."
            .ExportOptions.FormatType = crEFTPortableDocFormat
            .Export (True)
        End With  'Report
    End If  'optEmail
    Screen.MousePointer = vbDefault
    Exit Sub
    
cmdOK_Click_Error:
    Screen.MousePointer = vbDefault
    Select Case Err.Number
        Case -2147190889
            MsgBox "Report Cancelled", vbInformation, "Xtreme Order Report"
        Case -2147190908
            MsgBox "Invalid E-Mail address or other e-mail problem", vbCritical, "Xtreme Order Report"
            txtAddress.SetFocus
        Case Else
            MsgBox "Error " & Err.Number & " - " & Err.Description, vbCritical, "Xtreme Order Report"
    End Select  'Case Err.Number
        
End Sub

Private Sub Form_Load()
    Dim mrc As ADODB.Recordset
    Dim txtSQL As String
    Dim MsgTxt As String
    Dim i As Integer
        
    'txtFromDate = Format(#1/1/2001#, "Short Date")
    'txtToDate = Format(#12/31/2001#, "Short Date")
    cboGroupBy.Text = "季度"
    
    txtSQL = "select distinct year(订单日期) from 订单"
    Set mrc = ExecuteSQL(txtSQL, MsgTxt)
    
    If Not mrc.EOF Then
        Do While Not mrc.EOF
            Combo1.AddItem mrc.Fields(0)
            Combo4.AddItem mrc.Fields(0)
            mrc.MoveNext
        Loop
    End If
    
    mrc.Close
    
    For i = 1 To 12
        Combo2.AddItem i
        Combo5.AddItem i
    Next i
    
    For i = 1 To 31
        Combo3.AddItem i
        Combo6.AddItem i
    Next i
    
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set Report = Nothing
End Sub

Private Sub OptEmail_Click()
    txtAddress.Enabled = True
    lblAddress.Enabled = True
End Sub

Private Sub optPreview_Click()
    txtAddress.Enabled = False
    lblAddress.Enabled = False
End Sub

Private Sub OptPrint_Click()
    txtAddress.Enabled = False
    lblAddress.Enabled = False
End Sub


Private Sub txtAddress_GotFocus()
    txtAddress.SelStart = 0
    txtAddress.SelLength = Len(txtAddress)
End Sub

Private Sub txtFromDate_GotFocus()
    txtFromDate.SelStart = 0
    txtFromDate.SelLength = Len(txtFromDate)
End Sub

Private Sub txtFromDate_LostFocus()
    txtFromDate = Format(txtFromDate, "Short Date")
End Sub

Private Sub txtHighlight_GotFocus()
    txtHighlight.SelStart = 0
    txtHighlight.SelLength = Len(txtHighlight)
End Sub

Private Sub txtHighlight_LostFocus()
    If txtHighlight <> "" Then
        txtHighlight = Val(txtHighlight)
    End If  'txtHighlight <> ""
End Sub

Private Sub txtTaxRate_GotFocus()
    txtTaxRate.SelStart = 0
    txtTaxRate.SelLength = Len(txtTaxRate)
End Sub

Private Sub txtTaxRate_LostFocus()
    If txtTaxRate <> "" Then
        txtTaxRate = Val(txtTaxRate)
    End If  'txtTaxRate <> ""
End Sub

Private Sub txtToDate_GotFocus()
    txtToDate.SelStart = 0
    txtToDate.SelLength = Len(txtToDate)
End Sub

Private Sub txtToDate_LostFocus()
    txtToDate = Format(txtToDate, "Short Date")
End Sub