dataanal.frm

VB6数据库开发指南》的配套源程序

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.1#0"; "COMDLG32.OCX"
Begin VB.Form frmDataAnal 
   Caption         =   "Data Analysis"
   ClientHeight    =   5640
   ClientLeft      =   1515
   ClientTop       =   1725
   ClientWidth     =   6840
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   5640
   ScaleWidth      =   6840
   Begin VB.ComboBox lstResults 
      Height          =   300
      Left            =   1080
      TabIndex        =   8
      Top             =   1080
      Width           =   3972
   End
   Begin VB.CommandButton cmdLoadSS 
      Caption         =   "&Load Spreadsheet"
      Enabled         =   0   'False
      Height          =   330
      Left            =   5172
      TabIndex        =   6
      Top             =   636
      Width           =   1575
   End
   Begin VB.ComboBox lstTables 
      Height          =   300
      Left            =   1080
      TabIndex        =   5
      Top             =   720
      Width           =   3972
   End
   Begin VB.CommandButton cmdQuit 
      Caption         =   "&Quit"
      Default         =   -1  'True
      Height          =   330
      Left            =   5160
      TabIndex        =   3
      Top             =   1044
      Width           =   1575
   End
   Begin VB.CommandButton cmdSelectDB 
      Caption         =   "&Select Database"
      Height          =   330
      Left            =   5160
      TabIndex        =   2
      Top             =   225
      Width           =   1575
   End
   Begin VB.TextBox txtFileName 
      BackColor       =   &H00C0C0C0&
      Height          =   285
      Left            =   1080
      TabIndex        =   1
      TabStop         =   0   'False
      Top             =   240
      Width           =   3975
   End
   Begin MSComDlg.CommonDialog cdSelectFile 
      Left            =   6360
      Top             =   600
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   327680
      DefaultExt      =   "MDB"
      DialogTitle     =   "Open Database File"
      Filter          =   "Access Db (*.mdb)|*.mdb|All Files (*.*)|*.*"
   End
   Begin VB.Label Label3 
      Alignment       =   1  'Right Justify
      Caption         =   "Results:"
      Height          =   252
      Left            =   120
      TabIndex        =   9
      Top             =   1080
      Width           =   852
   End
   Begin VB.OLE oleExcel 
      Height          =   3855
      Left            =   240
      OLETypeAllowed  =   1  'Embedded
      TabIndex        =   7
      Top             =   1560
      Width           =   6375
   End
   Begin VB.Label Label2 
      Alignment       =   1  'Right Justify
      Caption         =   "Table:"
      Height          =   255
      Left            =   120
      TabIndex        =   4
      Top             =   720
      Width           =   855
   End
   Begin VB.Label Label1 
      Alignment       =   1  'Right Justify
      Caption         =   "Database:"
      Height          =   255
      Left            =   120
      TabIndex        =   0
      Top             =   240
      Width           =   855
   End
   Begin VB.Menu mnuRaisan 
      Caption         =   "Raisan"
      Visible         =   0   'False
   End
End
Attribute VB_Name = "frmDataAnal"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'This project makes use of an Excel 5.0 worksheet,
'so the Excel 5.0 Object Library must be specified
'in the VB Tools Reference menu.

Dim dbSS As Database

Const OLE_CreateEmbed As Integer = 0
Const OLE_Activate As Integer = 7


Private Function ColName(colNo As Integer)
    Dim alpha As String
    
    alpha = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    ColName = Mid$(alpha, colNo, 1)
End Function

Private Sub cmdLoadSS_Click()
    'If button is enabled, we can start
    Dim rsTable As Recordset
    Dim fld As Field
    Dim fieldTypes() As String
    Dim i As Integer, j As Integer
    Dim rowNo As Integer
    Dim cellRange As String
    Dim cellValue As Variant
    Dim cellPlace As String
    Dim cellName As String
    Dim totalRows As Integer
    Dim nameExcel As String
    Dim temp As String
    Dim ssName As String
    Dim saveCursor
    
    saveCursor = Me.MousePointer
    Me.MousePointer = vbHourglass
    
    'Create an array of all numerical fields to include in
    'the spreadsheet
    i = 0
    For Each fld In dbSS.TableDefs(lstTables.Text).Fields
        If fld.Type = dbInteger Or _
               fld.Type = dbLong Or _
               fld.Type = dbCurrency Or _
               fld.Type = dbSingle Or _
               fld.Type = dbDouble Then
            i = i + 1
            ReDim Preserve fieldTypes(i)
            fieldTypes(i) = fld.Name
        End If
    Next
    
    If i = 0 Then
        MsgBox "There are no numeric columns in the table. Exiting procedure."
        Me.MousePointer = saveCursor
        Exit Sub
    End If
    
    'For convenience, limit the number of columns to 26 so
    'we don't have to do anything fancy to columns AA, AB,
    'and so on
    i = IIf(i > 26, 26, i)
    
    'Open the recordset of the table
    Set rsTable = dbSS.OpenRecordset(lstTables.Text)

    On Error GoTo OLError
    oleExcel.CreateEmbed "", "Excel.Sheet.8"
    On Error GoTo 0
    ssName = oleExcel.object.Name
    
    Do While Not rsTable.EOF
        rowNo = rowNo + 1
        For j = 1 To i
            cellValue = rsTable(fieldTypes(j))
            oleExcel.object.Worksheets(1).Cells(rowNo, j).Value = cellValue
        Next
        rsTable.MoveNext
    Loop
    
    'Insert the formulas to calculate the average, median, and
    'standard deviation, and name the cells
    totalRows = rowNo
    rowNo = totalRows + 2
    For j = 1 To i
        cellRange = ColName(j) & "1:" & ColName(j) & Trim(Str(totalRows))
        cellValue = "=AVERAGE(" & cellRange & ")"
        cellPlace = "=Sheet1!$" & ColName(j) & "$" & Trim(Str(rowNo)) _
                    & ":$" & ColName(j) & "$" & Trim(Str(rowNo))
        oleExcel.object.Worksheets(1).Cells(rowNo, j).Value = cellValue
        cellName = "average" & Trim(Str(j))
        oleExcel.object.Parent.Names.Add Name:=cellName, RefersTo:=cellPlace
    Next
    rowNo = rowNo + 1
    For j = 1 To i
        cellRange = ColName(j) & "1:" & ColName(j) & Trim(Str(totalRows))
        cellValue = "=MEDIAN(" & cellRange & ")"
        cellPlace = "=Sheet1!$" & ColName(j) & "$" & Trim(Str(rowNo)) _
                    & ":$" & ColName(j) & "$" & Trim(Str(rowNo))
        oleExcel.object.Worksheets(1).Cells(rowNo, j).Value = cellValue
        cellName = "median" & Trim(Str(j))
        oleExcel.object.Parent.Names.Add Name:=cellName, RefersTo:=cellPlace
    Next
    rowNo = rowNo + 1
    For j = 1 To i
        cellRange = ColName(j) & "1:" & ColName(j) & Trim(Str(totalRows))
        cellValue = "=STDEV(" & cellRange & ")"
        cellPlace = "=Sheet1!$" & ColName(j) & "$" & Trim(Str(rowNo)) _
                    & ":$" & ColName(j) & "$" & Trim(Str(rowNo))
        oleExcel.object.Worksheets(1).Cells(rowNo, j).Value = cellValue
        cellName = "stdev" & Trim(Str(j))
        oleExcel.object.Parent.Names.Add Name:=cellName, RefersTo:=cellPlace
    Next
    
    'Lastly, put the results in the lstResults control
    lstResults.Clear
    For j = 1 To i
        nameExcel = "average" & Trim(Str(j))
        lstResults.AddItem fieldTypes(j) & " Average = " _
                & oleExcel.object.Worksheets(1).Range(nameExcel).Value
    Next
    For j = 1 To i
        nameExcel = "median" & Trim(Str(j))
        lstResults.AddItem fieldTypes(j) & " Median = " _
                & oleExcel.object.Worksheets(1).Range(nameExcel).Value
    Next
    For j = 1 To i
        nameExcel = "stdev" & Trim(Str(j))
        lstResults.AddItem fieldTypes(j) & " Standard Deviation = " _
                & oleExcel.object.Worksheets(1).Range(nameExcel).Value
    Next
    lstResults.ListIndex = 0

    Me.MousePointer = saveCursor
    Exit Sub

OLError:
    MsgBox "An OLE error occurred, probably because Excel is not installed on this computer."
    Unload Me
End Sub

Private Sub cmdSelectDB_Click()
    'Select a new database file to analyze
    Dim strFileName As String
    Dim X As TableDef
    Dim saveCursor
        
    'Open the file open common dialog
    cdSelectFile.InitDir = App.Path
    cdSelectFile.ShowOpen
    If Len(cdSelectFile.filename) Then
        saveCursor = Me.MousePointer
        Me.MousePointer = vbHourglass
        
        txtFileName = cdSelectFile.filename
        
        'Open the database
        Set dbSS = OpenDatabase(txtFileName)
        
        'Load the lstTables combo box
        lstTables.Clear
        If dbSS.TableDefs.Count Then
            For Each X In dbSS.TableDefs
                'Exclude system tables
                If Not X.Name Like "MSys*" Then
                    lstTables.AddItem X.Name
                End If
            Next
            lstTables.ListIndex = 0
        End If
        Me.MousePointer = saveCursor
    Else
        MsgBox "No file selected."
    End If
End Sub

Private Sub cmdQuit_Click()
    Set dbSS = Nothing
    End
End Sub


Private Sub lstTables_Click()
    If Len(lstTables.Text) Then
        cmdLoadSS.Enabled = True
    Else
        cmdLoadSS.Enabled = False
    End If
End Sub