' In the declaration section of the CFileOp class module
Event Parsing(file As String, Cancel As Boolean)

' ... inside the ParseFileSpec routine
        Dim Cancel As Boolean
        Do While Len(file)
            Cancel = False
            RaiseEvent Parsing(file, Cancel)
            If Not Cancel Then 
                m_Filenames.Add MakeFilename(Path, file)
            End If
            file = Dir$
        Loop

' In the client form module
Private Sub Fop_Parsing(file As String, Cancel As Boolean)
    Dim ext As String
    ' GetExtension is a handy method exposed by CFileOp.
    ext = LCase$(Fop.GetExtension(file))
    If ext = "tmp" Or ext = "$$$" Or ext = "bak" Then Cancel = True
End Sub

' Prepare to copy EXE files, using the standard FileSpec property.
Fop.FileSpec = "C:\Windows\*.exe"
' But also copy all executable files from another directory.
Fop.ParseFileSpec "C:\Windows\System\*.Exe", vbHidden
Fop.ParseFileSpec "C:\Windows\System\*.Com", vbHidden

' Create the internal Collection if necessary.
        If m_Filenames Is Nothing Then Set m_Filenames = New Collection
        ' Support for semicolon delimited multiple file specifications
        Dim MultiSpecs() As String, i As Integer
        If InStr(FileSpec, ";") Then
            MultiSpecs = Split(FileSpec, ";")
            For i = LBound(MultiSpecs) To UBound(MultiSpecs)
                ' Recursive call to this routine
                ParseFileSpec MultiSpecs(i)
            Next
            Exit Sub
        End If
        Path = GetPath(FileSpec)
        ' And so on....

Enum ActionConstants
    foContinue = 1
    foSkip
    foAbort
End Enum
Event WillCopyFile(file As String, DestPath As String, _
    Action As ActionConstants)

Sub Copy(DestPath As String)
    Dim var As Variant, file As String, dest As String
    Dim Action As ActionConstants
    On Error Resume Next
    For Each var In Filenames
        file = var
        dest = MakeFilename(DestPath, GetFileName(file))
        Action = foContinue
        RaiseEvent WillCopyFile(file, dest, Action)
        If Action = foAbort Then Exit Sub
        If Action = foContinue Then
            FileCopy file, dest
            If Err = 0 Then
                RaiseEvent FileCopyComplete(file, GetPath(dest))
            Else
                Err.Clear
            End If
        End If
    Next
End Sub

Private Sub Fop_WillCopyFile(File As String, DestPath As String, _
    Action As ActionConstants)
    ' Exit if user isn't interested in file-by-file confirmation.
    If chkConfirm = vbUnchecked Then Exit Sub
    Dim ok As Integer
    ok = MsgBox("Copying file " & File & " to " & DestPath & vbCr _
        & "Click YES to proceed, NO to skip, CANCEL to abort", _
        vbYesNoCancel + vbInformation)
    Select Case ok
        Case vbYes: Action = foContinue
        Case vbNo: Action = foSkip
        Case vbCancel: Action = foAbort
    End Select
End Sub

' Inside the WillCopyFile event procedure (in the client)...
        If LCase$(Fop.GetExtension(file)) = "bak" Then
            DestPath = "C:\Backup"
        End If

Event Error(OpName As String, File As String, File2 As String, _
    ErrCode As Integer, ErrMessage As String, Action As ActionConstants)

' Inside the Copy method in the CFileOp class module...
FileCopy File, dest
If Err = 0 Then
    RaiseEvent FileCopyComplete(File, DestPath)
Else
    Dim ErrCode As Integer, ErrMessage As String
    ErrCode = Err.Number: ErrMessage = Err.Description
    RaiseEvent Error("Copy", File, DestPath, ErrCode, _
        ErrMessage, Action)
    ' Report the error to the client if user aborted the process.
    If Action = foAbort Then
        ' You need to cancel error handling, otherwise the Err.Raise
        ' method won't return the control to the client.
        On Error GoTo 0           
        Err.Raise ErrCode, , ErrMessage
    End If
Err.Clear
End If

Private Sub Fop_Error(OpName As String, File As String, File2 As String, _
    ErrCode As Integer, ErrMessage As String, Action As ActionConstants)
    If ErrCode = 76 Then
        MsgBox ErrMessage, vbCritical
        Action = foAbort
    End If
End Sub

' Use a custom error scheme for this client.
    If OpName = "Copy" Then 
        ErrCode = ErrCode + 1000: ErrMessage = "Unable to Copy"
    ElseIf OpName = "Move" Then
        ErrCode = ErrCode + 2000: ErrMessage = "Unable to Move"
    End If
    Action = foAbort

Event ProgressPercent(Percent As Integer)

Private Sub CheckProgressPercent(Optional NewValue As Variant, _
    Optional MaxValue As Variant)
    Static Value As Variant, Limit As Variant
    Static LastPercent As Integer
    Dim CurrValue As Variant, CurrPercent As Integer
    If Not IsMissing(MaxValue) Then
        Limit = MaxValue
        If IsMissing(NewValue) Then Err.Raise 9998, , _
            "NewValue can't be omitted in the first call"
        Value = NewValue
    Else
        If IsEmpty(Limit) Then Err.Raise 9999, , "Not initialized!"
        Value = Value + IIf(IsMissing(NewValue), 1, NewValue)
    End If
    CurrPercent = (Value * 100) \ Limit
    If CurrPercent <> LastPercent Or Not IsMissing(MaxValue) Then
        LastPercent = CurrPercent
        RaiseEvent ProgressPercent(CurrPercent)
    End If
End Sub

' In the Copy method 
On Error Resume Next
CheckProgressPercent 0, Filenames.Count     ' Reset internal counters.
For Each var In Filenames
    CheckProgressPercent                    ' Increment by 1.
    File = var
    ...

Private Sub Fop_ProgressPercent(Percent As Integer)
    ShowProgress picStatus, Percent
End Sub
' A reusable routine that prints to a generic PictureBox
Private Sub ShowProgress(pic As PictureBox, Percent As Integer, _
    Optional Color As Long = vbBlue)
    pic.Cls
    pic.Line (0, 0)-(pic.ScaleWidth * Percent / 100, _
        pic.ScaleHeight), Color, BF
    pic.CurrentX = (pic.ScaleWidth - pic.TextWidth(CStr(Percent) _
        & " %")) / 2
    pic.CurrentY = (pic.ScaleHeight - pic.TextHeight("%")) / 2
    pic.Print CStr(Percent) & " %";
End Sub

Public WithEvents TextBox As TextBox

Private Sub TextBox_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case 0 To 31                   ' Accept control chars.
        Case 48 To 57                  ' Accept digits.
        Case Else
            KeyAscii = 0               ' Reject anything else.
    End Select
End Sub

Dim Amount As CtextBxN
Private Sub Form_Load()
    Set Amount = New CTextBxN
    Set Amount.TextBox = Text1
End Sub

Dim Amount As CTextBxN, Percentage As CtextBxN
Private Sub Form_Load()
    Set Amount = New CTextBxN
    Set Amount.TextBox = Text1
    Set Percentage = New CTextBxN
    Set Percentage.TextBox = Text2
End Sub

Public WithEvents TextBox As TextBox
Public IsDecimal As Boolean
Public FormatMask As String
Public SelectOnEntry As Boolean
Private Sub TextBox_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case 0 To 31                   ' Accept control chars.
        Case 48 To 57                  ' Accept digits.
        Case Asc(Format$(0.1, "."))    ' Accept the Decimal separator.
            If Not IsDecimal Then KeyAscii = 0
        Case Else
            KeyAscii = 0               ' Reject anything else.
    End Select
End Sub
Private Sub TextBox_GotFocus()
    TextBox.Text = FilterNumber(TextBox.Text, True)
    If SelectOnEntry Then 
        TextBox.SelStart = 0
        TextBox.SelLength = Len(TextBox.Text)
    End If
End Sub
Private Sub TextBox_LostFocus()
    If Len(FormatMask) Then 
        TextBox.Text = Format$(TextBox.Text, FormatMask)
    End If
End Sub
' Code for FilterNumber is omitted. (See Chapter 3.)

' In the Form_Load event procedure
Amount.FormatMask = "#,###,###"
Amount.SelectOnEntry = True
Percentage.FormatMask = "0.00"
Percentage.IsDecimal = True
Percentage.SelectOnEntry = True

' Change the BackColor property for all the controls on the form.
Sub SetBackColor(frm As Form, NewColor As Long)
    Dim ctrl As Control
    On Error Resume Next            ' Account for invisible controls.
    For Each ctrl In frm.Controls
        ctrl.BackColor = NewColor
    Next
End Sub

' In a complete implementation, we would use property procedures.
Public Left As Single, Top As Single
Public Width As Single, Height As Single
Public Color As Long, FillColor As Long    

Private Sub Class_Initialize()
    Color = vbBlack
    FillColor = -1              ' -1 means "not filled"
End Sub
' A pseudoconstructor method
Friend Sub Init(Left As Single, Top As Single, Width As Single, Height As _
    Single, Optional Color As Variant, Optional FillColor As Variant)
    ' .... code omitted for brevity
End Sub
' Draw this shape on a form, a picture box, or the Printer object.
Sub Draw(pic As Object)
    If FillColor <> -1 Then
        pic.Line (Left, Top)-Step(Width, Height), FillColor, BF
    End If
    pic.Line (Left, Top)-Step(Width, Height), Color, B
End Sub

Dim rect As New Crect
' Create a white rectangle with a red border.
rect.Init 1000, 500, 2000, 1500, vbRed, vbWhite
' Display it wherever you want.
If PreviewMode Then
    rect.Draw Picture1          ' A picture box
Else
    rect.Draw Printer           ' A printer
End If

' The CEllipse class
Public Left As Single, Top As Single
Public Width As Single, Height As Single
Public Color As Long, FillColor As Long    

Private Sub Class_Initialize()
    Color = vbBlack
    FillColor = -1             ' -1 means "not filled"
End Sub
' Draw this shape on a form, a picture box, or the Printer object.
Sub Draw(pic As Object)
    Dim aspect As Single, radius As Single
    Dim saveFillColor As Long, saveFillStyle As Long
    aspect = Height / Width
    radius = IIf(Width > Height, Width / 2, Height / 2)
    If FillColor <> -1 Then
        saveFillColor = pic.FillColor
        saveFillStyle = pic.FillStyle
        pic.FillColor = FillColor
        pic.FillStyle = vbSolid
        pic.Circle (Left + Width / 2, Top + Height / 2), radius, Color, _
            , , aspect
        pic.FillColor = saveFillColor
        pic.FillStyle = saveFillStyle
    Else
        pic.Circle (Left + Width / 2, Top + Height / 2), radius, Color, _
            , , aspect
    End If
End Sub

' The CLine class
Public X As Single, Y As Single
Public X2 As Single, Y2 As Single
Public Color As Long

Private Sub Class_Initialize()
    Color = vbBlack
End Sub
' Draw this shape on a form, a picture box, or the Printer object.
Sub Draw(pic As Object)
    pic.Line (X, Y)-(X2, Y2), Color
End Sub

' This is a module-level variable.
Dim Figures As Collection

Private Sub Form_Load()
    CreateFigures
End Sub
Private Sub cmdRedraw_Click()
    RedrawFigures
End Sub
' Create a set of figures.
Private Sub CreateFigures()
    Set Figures = New Collection
    Figures.Add New_CRectangle(1000, 500, 1400, 1200, , vbRed)
    Figures.Add New_CRectangle(4000, 500, 1400, 1200, , vbCyan)
    Figures.Add New_CEllipse(2500, 2000, 1400, 1200, , vbGreen)
    Figures.Add New_CEllipse(3500, 3000, 2500, 2000, , vbYellow)
    Figures.Add New_CRectangle(4300, 4000, 1400, 1200, , vbBlue)
    Figures.Add New_CLine(2400, 1100, 4000, 1100, vbBlue)
    Figures.Add New_CLine(1700, 1700, 1700, 4000, vbBlue)
    Figures.Add New_CLine(1700, 4000, 3500, 4000, vbBlue)
End Sub
' Redraw figures.
Sub RedrawFigures()
    Dim Shape As Object
    picView.Cls
    For Each Shape In Figures
        Shape.Draw picView
    Next
End Sub

On Error Resume Next     ' CLine doesn't support the FillColor property.
For Each Shape In Figures
    Shape.FillColor = -1
Next

' In CRectangle class module...
' Move this object.
Sub Move(stepX As Single, stepY As Single)
    Left = Left + stepX
    Top = Top + stepY
End Sub

' Enlarge or shrink this object on its center.
Sub Zoom(ZoomFactor As Single)
    Left = Left + Width * (1 - ZoomFactor) / 2
    Top = Top + Height * (1 - ZoomFactor) / 2
    Width = Width * ZoomFactor
    Height = Height * ZoomFactor
End Sub

Private Sub cmdMove_Click(Index As Integer)
    Dim shape As Object
    For Each shape In Figures
        Select Case Index
            Case 0: shape.Move 0, -100    ' Up
            Case 1: shape.Move 0, 100     ' Down
            Case 2: shape.Move -100, 0    ' Left
            Case 3: shape.Move 100, 0     ' Right
        End Select
    Next
    RedrawFigures
End Sub
Private Sub cmdZoom_Click(Index As Integer)
    Dim shape As Object
    For Each shape In Figures
        If Index = 0 Then
            shape.Zoom 1.1                ' Enlarge
        Else
            shape.Zoom 0.9                ' Reduce
        End If
    Next
    RedrawFigures
End Sub

' The IShape class module
Public Hidden As Boolean

Sub Draw(pic As Object)
    ' (Empty comment to prevent automatic deletion of this routine)
End Sub
Sub Move(stepX As Single, stepY As Single)
    '
End Sub
Sub Zoom(ZoomFactor As Single)
    '
End Sub

' In the CRectangle class module
Implements Ishape

' A (private) variable to store the IShape_Hidden property
Private Hidden As Boolean

Private Sub IShape_Draw(pic As Object)
    If Hidden Then Exit Sub
    If FillColor >= 0 Then
        pic.Line (Left, Top)-Step(Width, Height), FillColor, BF
    End If
    pic.Line (Left, Top)-Step(Width, Height), Color, B
End Sub
Private Sub IShape_Move(stepX As Single, stepY As Single)
    Left = Left + stepX
    Top = Top + stepY
End Sub
Private Sub IShape_Zoom(ZoomFactor As Single)
    Left = Left + Width * (1 - ZoomFactor) / 2
    Top = Top + Height * (1 - ZoomFactor) / 2
    Width = Width * ZoomFactor
    Height = Height * ZoomFactor
End Sub
Private Property Let IShape_Hidden(ByVal RHS As Boolean)
    Hidden = RHS
End Property
Private Property Get IShape_Hidden() As Boolean
    IShape_Hidden = Hidden
End Property

' In the client code ...
Dim Shape As IShape    ' A variable that points to an interface
Set Shape = Figures(1) ' Get the first figure in the list.
Shape.Draw picView     ' Call the Draw method in the IShape interface.

' An IIf replacement that accepts just one argument 
' If FalsePart is omitted and the expression is False, it returns Empty.
Function IIf(Expression As Boolean, TruePart As Variant, _
    Optional FalsePart As Variant) As Variant
    If Expression Then
        IIf = TruePart
    ElseIf Not IsMissing(FalsePart) Then
        IIf = FalsePart
    End If
End Function

Function Hex(Value As Long, Optional Digits As Variant) As String
    If IsMissing(Digits) Then
        Hex = VBA.Hex(Value)
    Else
        Hex = Right$(String$(Digits, "0") & VBA.Hex(Value), Digits)
    End If
End Function

' In the Csquare class module
Implements IShape
Implements CRectangle

' The primary and the IShape interface are identical... (omitted).... 
' This is the secondary CRectangle interface.
Private Property Let CRectangle_Color(ByVal RHS As Long)
    Rect.Color = RHS
End Property
Private Property Get CRectangle_Color() As Long
    CRectangle_Color = Rect.Color
End Property
Private Property Let CRectangle_FillColor(ByVal RHS As Long)
    Rect.FillColor = RHS
End Property
Private Property Get CRectangle_FillColor() As Long
    CRectangle_FillColor = Rect.FillColor
End Property
' The rect's Height property is replaced by the Width property.
Private Property Let CRectangle_Height(ByVal RHS As Single)
    rect.Width = RHS
End Property
Private Property Get CRectangle_Height() As Single
    CRectangle_Height = rect.Width
End Property
Private Property Let CRectangle_Left(ByVal RHS As Single)
    Rect.Left = RHS
End Property
Private Property Get CRectangle_Left() As Single
    CRectangle_Left = Rect.Left
End Property
Private Property Let CRectangle_Top(ByVal RHS As Single)
    Rect.Top = RHS
End Property
Private Property Get CRectangle_Top() As Single
    CRectangle_Top = Rect.Top
End Property
Private Property Let CRectangle_Width(ByVal RHS As Single)
    Rect.Width = RHS
End Property
Private Property Get CRectangle_Width() As Single
    CRectangle_Width = Rect.Width
End Property

Dim figures As New Collection
Dim rect As CRectangle, Top As Single

' Create a collection of rectangles and squares.
figures.Add New_CRectangle(1000, 2000, 1500, 1200)
figures.Add New_CSquare(1000, 2000, 1800)
figures.Add New_CRectangle(1000, 2000, 1500, 1500)
figures.Add New_CSquare(1000, 2000, 1100)

' Fill them, and stack them one over the other using early binding!
For Each rect In figures
    rect.FillColor = vbRed
    rect.Left = 0: rect.Top = Top
    Top = Top + rect.Height
Next

' In the CInvoice class module
Public Customer As CCustomer           ' In a real app, these would
Public SendFrom As CAddress            ' be implemented as pairs
Public ShipTo As CAddress              ' of property procedures.

Dim inv As New CInvoice, cust As CCustomer
inv.Number = GetNextInvoiceNumber()    ' A routine defined somewhere else
' For simplicity, let's not worry about how the CUST object is created.
Set cust = GetThisCustomer()           ' This returns a CCustomer object.
Set inv.Customer = cust                ' This creates the relationship.
' You don't always need an explicit variable.
Set inv.SendFrom = GetFromAddress()    ' This returns a CAddress object,
Set inv.ShipTo = GetToAddress()        ' as does this one.

' In the CInvoice class module
Sub PrintHeader(obj As Object)
    ' Print the invoice on a form, PictureBox, or the Printer.
    obj.Print "Number " & Number
    obj.Print "Customer: " & Customer.Name
    obj.Print "Send From: " & SendFrom.CompleteAddress
    obj.Print "Ship To: " & ShipTo.CompleteAddress
End Sub

Private m_ShipTo As Caddress
Property Get ShipTo() As CAddress
    If m_ShipTo Is Nothing Then
        Set ShipTo = Customer.Address
    Else
        Set ShipTo = m_ShipTo
    End If
End Property
Property Let ShipTo(newValue As CAddress)
    Set m_ShipTo = newValue
End Property

' A workable CinvoiceLine class module
Public Qty As Long
Public Product As String
Public UnitPrice As Currency

Property Get Total() As Currency
    Total = Qty * UnitPrice
End Property

' We can't expose arrays as Public members.
Private m_InvoiceLines(1 To 10) As CInvoiceLine

Property Get InvoiceLines(Index As Integer) As CInvoiceLine
    If Index < 1 Or Index > 10 Then Err.Raise 9   ' Subscript out of range
    Set InvoiceLines(Index) = m_InvoiceLines(Index)
End Property
Property Set InvoiceLines(Index As Integer, newValue As CInvoiceLine)
    If Index < 1 Or Index > 10 Then Err.Raise 9   ' Subscript out of range
    Set m_InvoiceLines(Index) = newValue
End Property
' In the client code
' (Assumes that we defined a constructor for the CInvoiceLine class)
Set inv.InvoiceLine(1) = New_CInvoiceLine(10, "Monitor ZX100", 225.25)
Set inv.InvoiceLine(2) = New_CInvoiceLine(14, "101-key Keyboard", 19.99)
' etc.

' In the CInvoice class
Public InvoiceLines As New Collection

' In the client code (no need to keep track of line index)
inv.InvoiceLines.Add New_CInvoiceLine(10, "Monitors ZX100", 225.25)
inv.InvoiceLines.Add New_CInvoiceLine(14, "101-key Keyboards", 19.99)

Sub PrintBody(obj As Object)
    ' Print the invoice body on a form, PictureBox, or the Printer.
    Dim invline As CInvoiceLine, Total As Currency
    For Each invline In InvoiceLines
        obj.Print invline.Description
        Total = Total + invline.Total
    Next
    obj.Print "Grand Total = " & Total
End Sub

inv.InvoiceLines.Add New CCustomer          ' No error!

' The private collection that holds the real data
Private m_InvoiceLines As New Collection

Sub Add(newItem As CInvoiceLine, Optional Key As Variant, _
    Optional Before As Variant, Optional After As Variant)
    m_InvoiceLines.Add newItem, Key
End Sub
Sub Remove(index As Variant)
    m_InvoiceLines.Remove index
End Sub
Function Item(index As Variant) As CInvoiceLine
    Set Item = m_InvoiceLines.Item(index)
End Function
Property Get Count() As Long
    Count = m_InvoiceLines.Count
End Property