ctlexpensedetail.ctl

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

        With mrecExpense
            .Edit
            Call SetRecordset(mrecExpense)
            .Update
            'Move to the most recently modified record
            .Bookmark = .LastModified
            Call GetRecordset(mrecExpense)
            RaiseEvent DataChanged
        End With
    End If
    
    Exit Sub

UpdateError:
    ' Return the error description
    Err.Raise Number:=Err.Number, Source:=Err.Source, _
        Description:=Err.Description
    Err.Clear
    Exit Sub

End Sub

Private Sub UserControl_Initialize()
' Initialize control's core variables
    
    ' Trace behavior, but we can't use the name because
    ' the extender object is not available
    Debug.Print "Initialize"
    
    mblnRecSetOpen = False
    
End Sub

Private Sub UserControl_InitProperties()
    ' Trace behavior.
    Debug.Print Extender.Name & ": InitProperties"
    ' Set the Caption property
    Caption = Extender.Name

End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    
    ' Trace behavior.
    Debug.Print Extender.Name & ": ReadProperties"
    'Retrieve the caption
    Caption = PropBag.ReadProperty("Caption", _
                Extender.Name)

End Sub

Private Sub UserControl_Resize()
' Resize constituent controls to look "nice"
Dim intMargin As Integer
Dim intHeight As Integer
Dim intWidth As Integer

    ' Trace our behavior
    Static intCountResized As Integer
    intCountResized = intCountResized + 1
    Debug.Print Extender.Name & " Resized " _
        & Str$(intCountResized) & " times"
        
    ' Adjust the placement of the border frame
    fraBorder.Move 0, 0, ScaleWidth, ScaleHeight
    
    ' Calculate the standard margin as a proportion of
    ' the total control width.
    intMargin = ScaleWidth / 30
    
    ' Calculate and adjust the sizes of the internal frames.
    intHeight = (ScaleHeight - (1.5 * intMargin) - intMargin) / 2
    intWidth = ScaleWidth - (2 * intMargin)
    fraMaintain.Move intMargin, (intMargin * 2), _
        intWidth, intHeight
    fraNavigate.Move intMargin, _
        (fraMaintain.Top + fraMaintain.Height), _
        intWidth, intHeight
    
    ' Adjust the maintenance button sizes and locations
    ' based on the number of buttons and margins required.
    ' We need an extra margin in the heigh because the frame
    ' caption takes about one margin.
    intHeight = fraMaintain.Height - (3 * intMargin)
    intWidth = (fraMaintain.Width - (4 * intMargin)) / 3
    cmdNew.Move intMargin, _
        2 * intMargin, _
        intWidth, intHeight
    cmdUpdate.Move cmdNew.Left + intWidth + intMargin, _
        2 * intMargin, _
        intWidth, intHeight
    cmdDelete.Move cmdUpdate.Left + cmdUpdate.Width + intMargin, _
        2 * intMargin, _
        intWidth, intHeight
    
    ' Adjust the movement button sizes and locations based on
    ' the number of buttons and margins required.
    intHeight = fraNavigate.Height - (3 * intMargin)
    intWidth = (fraNavigate.Width - (5 * intMargin)) / 4
    cmdFirst.Move intMargin, _
        2 * intMargin, _
        intWidth, intHeight
    cmdPrev.Move cmdFirst.Left + intWidth + intMargin, _
        2 * intMargin, _
        intWidth, intHeight
    cmdNext.Move cmdPrev.Left + intWidth + intMargin, _
        2 * intMargin, _
        intWidth, intHeight
    cmdLast.Move cmdNext.Left + intWidth + intMargin, _
        2 * intMargin, _
        intWidth, intHeight

End Sub

Public Property Get Caption() As String

    Caption = fraBorder.Caption

End Property

Public Property Let Caption(ByVal strNewValue As String)
    
    ' Place the caption in the border frame.
    fraBorder.Caption = strNewValue
    ' Notify the container so that the property
    ' window may be updated
    PropertyChanged "Caption"
    
End Property

Private Sub UserControl_Terminate()
    
    ' Trace behavior.
    Debug.Print "UserControl_Terminate"
    
    ' We don't really care about errors when cleaning up.
    On Error Resume Next
    ' Close the recordset
    mrecExpense.Close
    ' Close the expense database
    mdbExpense.Close
    ' Reset the error handler
    On Error GoTo 0
    Exit Sub
    
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    
    ' Trace behavior.
    Debug.Print Extender.Name & ": WriteProperties"
    'Save the caption property to the property bag.
    PropBag.WriteProperty "Caption", Caption, _
        Extender.Name
        
End Sub

Public Property Get strDatabaseName() As String
' Returns the database name to the container
    strDatabaseName = mstrDbName
    
End Property

Public Property Let strDatabaseName(ByVal strNewValue As String)
' Assigns database name to control and closes and opens the
' control's recordset

    ' Trace behavior.
    Debug.Print Extender.Name & ": Let strDatabaseName"
    
    ' Don't allow database to be set at design-time
    If Ambient.UserMode = False Then
        Err.Raise Number:=31013, _
            Description:= _
            "Property is read-only at design time."
        Exit Property
    End If
    
    On Error GoTo OpenError
    
    If mblnRecSetOpen Then
        mrecExpense.Close
        mdbExpense.Close
    End If
    mstrDbName = strNewValue
    Set mdbExpense = DBEngine.Workspaces(0).OpenDatabase(mstrDbName)
    Set mrecExpense = mdbExpense.OpenRecordset("Expenses")
    mblnRecSetOpen = True
    
    Exit Property

OpenError:
    ' Since we are designing this class for potential unattended operation,
    ' we'll have to raise an error on our own
    Err.Raise Number:=Err.Number, Description:=Err.Description
    Err.Clear
    Exit Property

End Property
Private Sub SetRecordset(recExp As Recordset)
' Copies current values to Recordset

    With recExp
        !EmployeeId = mstrEmployeeId
        !ExpenseType = mstrExpenseType
        !AmountSpent = mcurAmountSpent
        !Description = mstrDescription
        !DatePurchased = mdtmDatePurchased
        !DateSubmitted = mdtmDateSubmitted
    End With
    
End Sub
Private Sub GetRecordset(recExp As Recordset)
' Copies current values to Recordset

    With recExp
        mlngExpenseId = 0 + !expenseid
        mstrEmployeeId = "" & !EmployeeId
        mstrExpenseType = "" & !ExpenseType
        mcurAmountSpent = 0 + !AmountSpent
        mstrDescription = "" & !Description
        mdtmDatePurchased = !DatePurchased
        mdtmDateSubmitted = !DateSubmitted
    End With
    
End Sub

Public Property Get lngExpenseId() As Long
Attribute lngExpenseId.VB_MemberFlags = "400"
    ' Return the database-assigned ExpenseID.
    ' Note that there is no Property Let procedure
    ' because the database makes the key assignment.
    
    lngExpenseId = mlngExpenseId

End Property
Public Property Get strEmployeeId() As String
Attribute strEmployeeId.VB_MemberFlags = "400"
    ' Return the control's current employee ID
    strEmployeeId = mstrEmployeeId

End Property

Public Property Let strEmployeeId(ByVal strNewValue As String)
    ' Set the employee ID
    mstrEmployeeId = strNewValue
    
End Property
Public Property Get strExpenseType() As String
Attribute strExpenseType.VB_MemberFlags = "400"
    ' Return the control's current expense type
    strExpenseType = mstrExpenseType

End Property

Public Property Let strExpenseType(ByVal strNewValue As String)
' Sets the expense type to an allowed value
    Dim strTemp As String
    
    strTemp = UCase$(strNewValue)
    If strTemp = "TRAVEL" _
    Or strTemp = "MEALS" _
    Or strTemp = "OFFICE" _
    Or strTemp = "AUTO" _
    Or strTemp = "TOLL/PARK" Then
        mstrExpenseType = strTemp
    Else
        Err.Raise Number:=31013, _
            Description:="Expense type must be TRAVEL, MEALS, " _
                            & "OFFICE, AUTO, or TOLL/PARK"
        'Err.Clear
        Exit Property
    End If
    
End Property
Public Property Get curAmountSpent() As Currency
Attribute curAmountSpent.VB_MemberFlags = "400"
    ' Return the control's current amount
    curAmountSpent = mcurAmountSpent

End Property

Public Property Let curAmountSpent(ByVal curNewValue As Currency)
    ' Set the amount spent
    mcurAmountSpent = curNewValue
    
End Property
Public Property Get strDescription() As String
Attribute strDescription.VB_MemberFlags = "400"
    ' Return the control's current description
    strDescription = mstrDescription

End Property

Public Property Let strDescription(ByVal strNewValue As String)
    ' Set the expense description
    mstrDescription = strNewValue
    
End Property
Public Property Get dtmDatePurchased() As Date
Attribute dtmDatePurchased.VB_MemberFlags = "400"
    ' Return the control's current purchase date
    dtmDatePurchased = mdtmDatePurchased

End Property

Public Property Let dtmDatePurchased(ByVal dtmNewValue As Date)
    ' Set the purchase date
    mdtmDatePurchased = dtmNewValue
    
End Property

Public Property Get dtmDateSubmitted() As Date
Attribute dtmDateSubmitted.VB_MemberFlags = "400"
    ' Return the control's current submitted date.
    ' There is no property Let procedure because the
    ' value is set only when the record is created.
    dtmDateSubmitted = mdtmDateSubmitted

End Property

Private Sub ClearObject()
' Clears all object variables
    
    mlngExpenseId = 0
    mstrEmployeeId = ""
    mstrExpenseType = ""
    mcurAmountSpent = 0
    mstrDescription = ""
    mdtmDatePurchased = CDate("1/1/1980")
    mdtmDateSubmitted = CDate("1/1/1980")
    
End Sub