embedded.frm

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

VERSION 5.00
Begin VB.Form Form1 
   BackColor       =   &H00C0C0C0&
   Caption         =   "Object Library"
   ClientHeight    =   4590
   ClientLeft      =   1050
   ClientTop       =   2145
   ClientWidth     =   8010
   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     =   4590
   ScaleWidth      =   8010
   Begin VB.CommandButton cmdCloseObject 
      Caption         =   "&Close Object"
      Height          =   435
      Left            =   6240
      TabIndex        =   8
      Top             =   0
      Width           =   1335
   End
   Begin VB.CommandButton cmdDelete 
      Caption         =   "&Delete"
      Height          =   435
      Left            =   1920
      TabIndex        =   7
      Top             =   3960
      Width           =   1335
   End
   Begin VB.CommandButton cmdAdd 
      Caption         =   "&Add"
      Height          =   435
      Left            =   480
      TabIndex        =   6
      Top             =   3960
      Width           =   1335
   End
   Begin VB.TextBox txtTitle 
      DataField       =   "Title"
      DataSource      =   "datObjects"
      Height          =   315
      Left            =   720
      TabIndex        =   1
      Top             =   0
      Width           =   2235
   End
   Begin VB.Data datObjects 
      Connect         =   "Access"
      DatabaseName    =   "C:\My Documents\Visual Basic 6 Database How-To\Edited\Chapter12\HowTo01\Chapter12.mdb"
      DefaultCursorType=   0  'DefaultCursor
      DefaultType     =   2  'UseODBC
      Exclusive       =   0   'False
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   465
      Left            =   3360
      Options         =   0
      ReadOnly        =   0   'False
      RecordsetType   =   1  'Dynaset
      RecordSource    =   "ObjectLibrary"
      Top             =   3960
      Width           =   1260
   End
   Begin VB.Label Label3 
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Object:"
      Height          =   195
      Left            =   120
      TabIndex        =   4
      Top             =   360
      Width           =   630
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Class:"
      Height          =   195
      Left            =   3120
      TabIndex        =   2
      Top             =   0
      Width           =   525
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Title:"
      Height          =   195
      Left            =   120
      TabIndex        =   0
      Top             =   0
      Width           =   450
   End
   Begin VB.Label lblClass 
      BorderStyle     =   1  'Fixed Single
      DataField       =   "Object Type"
      DataSource      =   "datObjects"
      Height          =   315
      Left            =   3720
      TabIndex        =   3
      Top             =   0
      Width           =   2235
   End
   Begin VB.OLE oleObject 
      DataField       =   "Object"
      DataSource      =   "datObjects"
      Height          =   3195
      Left            =   480
      SizeMode        =   3  'Zoom
      TabIndex        =   5
      Top             =   600
      Width           =   7095
   End
   Begin VB.Menu mnuFile 
      Caption         =   "&File"
      Begin VB.Menu mnuFileExit 
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuEdit 
      Caption         =   "&Edit"
      Begin VB.Menu mnuEditPaste 
         Caption         =   "&Paste"
         Shortcut        =   ^V
      End
      Begin VB.Menu mnuEditPasteSpecial 
         Caption         =   "Paste &Special..."
      End
      Begin VB.Menu mnuSep2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuEditInsertObject 
         Caption         =   "&Insert Object..."
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private mblnDeleting As Boolean

Private Sub cmdAdd_Click()
    datObjects.Recordset.AddNew
End Sub

Private Sub cmdCloseObject_Click()
    
    ' Save the updated object
    If oleObject.DataChanged Or txtTitle.DataChanged Then
        datObjects.UpdateRecord
    End If

End Sub

Private Sub cmdDelete_Click()
    
    On Error GoTo DeleteError
    mblnDeleting = True
    datObjects.Recordset.Delete
    'oleObject.Class = ""
    datObjects.Recordset.MoveNext
    ' Handle the "no current record" case.
    If datObjects.Recordset.EOF Then
        ' Handle the special case of deleting the
        ' last record
        datObjects.Recordset.MoveLast
    End If
    mblnDeleting = False
    
    ' Reset the error handler
    On Error GoTo 0
    Exit Sub

DeleteError:
    If Err.Number = 3021 Then           ' No current record
        Resume Next
    End If
    
End Sub

Private Sub datObjects_Reposition()
    
    If Not mblnDeleting Then
        ' Update the label for the oleObject class if the reposition is
        ' not a MoveNext after deletion of the last record. The change
        ' to the lblClass value forces another validation and
        ' record update attempt. The update attempt after the deletion
        ' of the last record causes a "no current record" error
        If lblClass.Caption = "" Then
            lblClass.Caption = oleObject.Class
        End If
    End If
    
End Sub

Private Sub datObjects_Validate(Action As Integer, Save As Integer)
    'Validate any changed data
    Select Case Action
        Case vbDataActionUpdate
            datObjects.UpdateRecord
    End Select
    
End Sub

Private Sub Form_Load()
    Dim strDbName As String
    Dim strResponse As String
    
    On Error GoTo LoadError
    
    ' Set the database of the data control
    strDbName = App.Path
    strDbName = strDbName & "\Chapter12.mdb"
    datObjects.DatabaseName = strDbName
    
    ' Indicate that we are not currently deleting a
    ' record
    mblnDeleting = False
    
    Exit Sub
    
LoadError:
    MsgBox Err.Description & Chr(13) & "from " & Err.Source _
            & " -- Number: " & CStr(Err.Number)
    Unload Me
    

    
End Sub

Private Sub mnuEditInsertObject_Click()
    oleObject.InsertObjDlg
    If oleObject.DataChanged Then
        lblClass.Caption = oleObject.Class
    End If
End Sub

Private Sub mnuEdit_Click()
    If Me.ActiveControl.Name = "oleObject" Then
        mnuEditPaste.Enabled = oleObject.PasteOK
        mnuEditPasteSpecial.Enabled = oleObject.PasteOK
        mnuEditInsertObject.Enabled = True
    Else
        mnuEditPaste.Enabled = False
        mnuEditPasteSpecial.Enabled = False
        mnuEditInsertObject.Enabled = False
    End If
End Sub

Private Sub mnuEditPaste_Click()
    oleObject.Paste
    lblClass.Caption = oleObject.Class
End Sub

Private Sub mnuEditPasteSpecial_Click()
    oleObject.PasteSpecialDlg
    lblClass.Caption = oleObject.Class
End Sub

Private Sub mnuFileExit_Click()
    If oleObject.DataChanged Or txtTitle.DataChanged Then
        datObjects.UpdateRecord
    End If
    
    Unload Me

End Sub