textimp.frm

《VB6数据库开发指南》所有的例程的源码

VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form frmMain 
   BackColor       =   &H00C0C0C0&
   Caption         =   "Chapter 5.3 Example"
   ClientHeight    =   3255
   ClientLeft      =   2280
   ClientTop       =   1545
   ClientWidth     =   4455
   BeginProperty Font 
      Name            =   "MS Sans Serif"
      Size            =   8.25
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   3255
   ScaleWidth      =   4455
   Begin MSFlexGridLib.MSFlexGrid grdInvoices 
      Height          =   975
      Left            =   90
      TabIndex        =   5
      Top             =   1380
      Width           =   4275
      _ExtentX        =   7541
      _ExtentY        =   1720
      _Version        =   393216
      Cols            =   4
      ScrollBars      =   2
   End
   Begin VB.CommandButton cmdListVendors 
      Caption         =   "&List Vendors"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   1560
      TabIndex        =   4
      Top             =   840
      Width           =   1335
   End
   Begin VB.CommandButton cmdExit 
      Cancel          =   -1  'True
      Caption         =   "E&xit"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   555
      Left            =   3120
      TabIndex        =   3
      Top             =   2580
      Width           =   1215
   End
   Begin VB.CommandButton cmdImport 
      Caption         =   "&Import Data"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   120
      TabIndex        =   2
      Top             =   840
      Width           =   1335
   End
   Begin VB.CommandButton cmdVendorDetails 
      Caption         =   "&Vendor Details"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   3000
      TabIndex        =   1
      Top             =   840
      Width           =   1335
   End
   Begin VB.ListBox lstVendors 
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   645
      Left            =   120
      Sorted          =   -1  'True
      TabIndex        =   0
      Top             =   90
      Width           =   4215
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'Change this constant to whatever path you have installed
Const DATA_PATH = "E:\VB Database How-To"

Private VendorFile As String, InvoiceFile As String, DatabaseFile As String

Private Sub cmdExit_Click()
    End
End Sub
Private Sub cmdImport_Click()
    Dim dbfTemp As Database, tblVendors As Recordset, tblInvoices As Recordset
    Dim objVendor As clsVendor, objInvoice As clsInvoice
    Dim colVendors As New Collection, colInvoices As New Collection
    
    Dim strInputLine As String, strErrMsg As String
    Dim blnNeedRollback As Boolean
    Dim intFileHandle As Integer
    
    On Error GoTo ImportTextError
        Screen.MousePointer = vbHourglass
        
        'Get the vendor text file, and create an instance
        'of objVendor for each line found in the text file,
        'passing the line to the DelimitedString property
        'of the instance of objVendor.
        intFileHandle = FreeFile
        Open VendorFile For Input As intFileHandle
        Do Until EOF(intFileHandle)
            Line Input #intFileHandle, strInputLine
            Set objVendor = New clsVendor
            objVendor.DelimitedString = strInputLine
            colVendors.Add objVendor
        Loop
        Close intFileHandle
        
        'Same as above, but with the invoice text file.
        intFileHandle = FreeFile:
        Open InvoiceFile For Input As intFileHandle
        Do Until EOF(intFileHandle)
            Line Input #intFileHandle, strInputLine
            Set objInvoice = New clsInvoice
            objInvoice.DelimitedString = strInputLine
            colInvoices.Add objInvoice
        Loop
        Close intFileHandle
    
        'Prepare for addition
        Set dbfTemp = DBEngine.Workspaces(0).OpenDatabase(DatabaseFile)
        Set tblVendors = dbfTemp.OpenRecordset("Vendors", dbOpenTable)
        Set tblInvoices = dbfTemp.OpenRecordset("Invoices", dbOpenTable)
    
        'This is where we start the transaction processing.  None of the
        'changes we make will be committed to the database until the
        'CommitTrans line, some lines below.
        Workspaces(0).BeginTrans
        blnNeedRollback = True
        
        'Iterate through our collection of clsVendor objects,
        'calling the StoreNewItem method and passing our newly-opened
        'table.
        If colVendors.Count Then
            For Each objVendor In colVendors
                If objVendor.StoreNewItem(tblVendors) = False Then
                    strErrMsg = "An error occurred while importing vendor #" & _
                    CStr(objVendor.Number)
                    Err.Raise 32767
                End If
            Next
        End If
    
        'Same as above, but for invoices. (Deja vu...?)
        If colInvoices.Count Then
            For Each objInvoice In colInvoices
                If objInvoice.StoreNewItem(tblInvoices) = False Or _
                    objInvoice.VendorNumber = 0 Then
                    strErrMsg = "An error occurred while importing invoice #" & _
                    objInvoice.InvoiceNumber
                    Err.Raise 32767
                End If
            Next
        End If
    
        'Here's where the data is committed to the database.
        'Had an error occurred, we would never reach this point;
        'instead, the Rollback command in our error
        'trapping routine would have removed our changes.
        Workspaces(0).CommitTrans
    
        Screen.MousePointer = vbDefault
    On Error GoTo 0
Exit Sub

ImportTextError:
    Screen.MousePointer = vbDefault
    If strErrMsg = "" Then strErrMsg = "The following error has occurred:" & vbCr _
        & Err.Description
    strErrMsg = strErrMsg & " No records have been added to the database."
    MsgBox strErrMsg, vbExclamation
    'Here's the Rollback method; if the blnNeedRollback variable
    'is still set to True, we undo our uncommitted changes.
    If blnNeedRollback Then Workspaces(0).Rollback
Exit Sub

End Sub
Private Sub cmdVendorDetails_Click()
    Dim dbfTemp As Database
    Dim tblVendors As Recordset
    Dim intVendorNumber As Integer
    
    On Error GoTo VendorDetailsError
        If lstVendors.ListIndex > -1 Then
            intVendorNumber = lstVendors.ItemData(lstVendors.ListIndex)
            Set dbfTemp = DBEngine.Workspaces(0).OpenDatabase(DatabaseFile, False, True)
            Set tblVendors = dbfTemp.OpenRecordset("Vendors", dbOpenTable)
    
            tblVendors.Index = "PrimaryKey"
            tblVendors.Seek "=", intVendorNumber
            DBEngine.Idle dbFreeLocks
    
            With frmVendorDetails
                .lblNumber = tblVendors![Vendor Number]
                .lblName = IIf(IsNull(tblVendors!Name), "", tblVendors!Name)
                .lblAddress = IIf(IsNull(tblVendors!Address), "", tblVendors!Address)
                .lblFEIN = IIf(IsNull(tblVendors!FEIN), "", tblVendors!FEIN)
            End With
    
            tblVendors.Close
            frmVendorDetails.Show vbModal
        Else
            Beep
            MsgBox "You haven't selected a vendor.", vbExclamation
        End If
    On Error GoTo 0
Exit Sub

VendorDetailsError:
    MsgBox Error(Err)
Exit Sub

End Sub
Private Sub Form_Load()
    Dim dbfTemp As Database

    'Assign fully qualified pathnames to the form level data file variables.
    VendorFile = DATA_PATH & "\CHAPTER05\VENDORS.DAT"
    InvoiceFile = DATA_PATH & "\CHAPTER05\INVOICES.DAT"
    DatabaseFile = DATA_PATH & "\CHAPTER05\ACCTSPAY.MDB"

    ' Initialize the grid control.
    InitializeGrid

    ' Delete any existing data in the Vendors and Invoices tables.
    Set dbfTemp = DBEngine.Workspaces(0).OpenDatabase(DatabaseFile)
    dbfTemp.Execute ("DELETE Vendors.* from Vendors")
    dbfTemp.Execute ("DELETE Invoices.* from Invoices")
End Sub
Private Sub InitializeGrid()

    With grdInvoices
        .ColWidth(0) = 0:
        .ColWidth(1) = 1300
        .ColWidth(2) = 1300
        .ColWidth(3) = 1300
        .ColAlignment(1) = flexAlignLeftCenter
        .ColAlignment(2) = flexAlignCenterCenter
        .ColAlignment(3) = flexAlignRightCenter
        .FixedAlignment(1) = flexAlignLeftCenter
        .FixedAlignment(2) = flexAlignCenterCenter
        .FixedAlignment(3) = flexAlignRightCenter
        .Row = 0
        .Col = 1: .Text = "Inv #"
        .Col = 2: .Text = "Date"
        .Col = 3: .Text = "Amount"
        .Rows = 1
    End With
End Sub
Private Sub FillInvoiceList(intVendor As Integer)
    Dim dbfTemp As Database, recInvoices As Recordset
    Dim intRow As Integer, strSQL As String

    Dim colInvoices As New Collection, objInvoice As clsInvoice

    On Error GoTo FillInvoiceListError
        'Open the database & recordset used to fill the list box
        Set dbfTemp = DBEngine.Workspaces(0).OpenDatabase(DatabaseFile, False, True)
        strSQL = "SELECT [Invoice Number] FROM Invoices " & _
            "WHERE [Vendor Number] = " & intVendor
        Set recInvoices = dbfTemp.OpenRecordset(strSQL, dbOpenSnapshot)
    
        If recInvoices.RecordCount > 0 Then
            recInvoices.MoveFirst
            Do Until recInvoices.EOF
                Set objInvoice = New clsInvoice
                If objInvoice.Retrieve(dbfTemp, intVendor, recInvoices("Invoice Number")) _
                    Then colInvoices.Add objInvoice
                recInvoices.MoveNext
            Loop
    
            grdInvoices.Rows = colInvoices.Count + 1
    
            For intRow = 1 To colInvoices.Count
                Set objInvoice = colInvoices(intRow)
                objInvoice.AddToGrid grdInvoices, intRow
            Next intRow
        Else
            grdInvoices.Rows = 1
        End If
    On Error GoTo 0
Exit Sub

FillInvoiceListError:
    grdInvoices.Rows = 1: lstVendors.ListIndex = -1
    MsgBox Err.Description, vbExclamation
Exit Sub

End Sub
Private Sub lstVendors_Click()
    FillInvoiceList lstVendors.ItemData(lstVendors.ListIndex)
End Sub
Private Sub cmdListVendors_Click()
    Dim dbfTemp As Database, tblVendors As Recordset

    On Error GoTo ListVendorsError
    Set dbfTemp = DBEngine.Workspaces(0).OpenDatabase(DatabaseFile, False, True)
    Set tblVendors = dbfTemp.OpenRecordset("Vendors", dbOpenTable)
    If tblVendors.RecordCount <> 0 Then
        tblVendors.MoveFirst
        Do Until tblVendors.EOF
            lstVendors.AddItem tblVendors!Name
            lstVendors.ItemData(lstVendors.NewIndex) = tblVendors![Vendor Number]
            tblVendors.MoveNext
        Loop
    End If
    tblVendors.Close

Exit Sub

ListVendorsError:
    lstVendors.Clear
    MsgBox Err.Description
End Sub