Option Explicit

Private WithEvents mevtXLWkb As Excel.Workbook
Private mobjXLShape As Excel.Shape

Private Sub Class_Terminate()
  Set mobjXLShape = Nothing
  Set mevtXLWkb = Nothing
End Sub

Public Property Set Workbook(ByRef objXLWkb As Excel.Workbook)
  Set mevtXLWkb = objXLWkb
End Property

Public Property Get Workbook() As Excel.Workbook
  Set Workbook = mevtXLWkb
End Property

Private Sub mevtXLWkb_BeforeClose(Cancel As Boolean)
  Cancel = True

  Dim strMsg As String
  strMsg = "Excel-Ereignisse des Workbook-Objekts" & vbLf & vbLf
  strMsg = strMsg & "Die Arbeitsmappe '" & mevtXLWkb.Name
  strMsg = strMsg & "' kann nur über den Button <Beenden> im "
  strMsg = strMsg & "VB-Programm geschlossen werden."

  Call DisplayXLShape(300, 110, strMsg)
End Sub

Private Sub DisplayXLShape(ByVal sngWdth As Single, _
      ByVal sngHght As Single, ByVal strMsg As String)

  Const msoShapeRoundedRectangle As Long = 5
  Dim i As Integer

  On Error Resume Next
  mobjXLShape.Delete
  Set mobjXLShape = mevtXLWkb.ActiveSheet.Shapes.AddShape _
        (msoShapeRoundedRectangle, 50, 50, sngWdth, sngHght)

  With mobjXLShape
    .Line.Weight = 1.5
    .Line.ForeColor.SchemeColor = 64
    .Line.BackColor.RGB = RGB(255, 255, 255)
    .Placement = xlFreeFloating
  End With

  With mobjXLShape.TextFrame
    .Characters.Text = ""
    For i = 0 To Int(Len(strMsg) / 255)
      .Characters(.Characters.Count + 1).Insert _
            Mid(strMsg, (i * 255) + 1, 255)
    Next

    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlVAlignCenter
    .AutoSize = False
  End With

  With mobjXLShape.TextFrame.Characters.Font
    .Name = "Arial"
    .FontStyle = "Standard"
    .Size = 10
    .ColorIndex = xlAutomatic
  End With
  On Error GoTo 0
End Sub

Option Explicit

Private mcolXLWkbs As Collection

Private Sub Class_Initialize()
  Set mcolXLWkbs = New Collection
End Sub

Private Sub Class_Terminate()
  Set mcolXLWkbs = Nothing
End Sub

Public Function Add(ByRef objXLWkb As Excel.Workbook) As CWkbEvents
  Dim objCWkb As CWkbEvents

  On Error GoTo err_Add
  Set objCWkb = New CWkbEvents
  Set objCWkb.Workbook = objXLWkb
  mcolXLWkbs.Add objCWkb
  Set Add = objCWkb
  Set objCWkb = Nothing

exit_Func:
  On Error GoTo 0
  Exit Function

err_Add:
  MsgBox "Fehler: " & Err.Number & vbCrLf & _
        Err.Description, vbOKOnly + vbCritical
  Resume exit_Func
End Function

Public Property Get Item(ByVal Index As Variant) As CWkbEvents
  Set Item = mcolXLWkbs.Item(Index)
End Property

Public Property Get Count() As Long
  Count = mcolXLWkbs.Count
End Property

Public Sub Remove(ByVal Index As Variant)
  mcolXLWkbs.Remove Index
End Sub

Option Explicit

Private mobjXLApp   As Excel.Application
Private mcolXLWkbs  As col_Workbooks

Private Sub cmdStartXL_Click()
  Dim objXLWkb As Excel.Workbook

  On Error GoTo err_Excel
  Set mobjXLApp = CreateObject("Excel.Application")

  Set mcolXLWkbs = New col_Workbooks
  Set objXLWkb = mobjXLApp.Workbooks.Add
  mcolXLWkbs.Add objXLWkb
  Set objXLWkb = Nothing

  Set objXLWkb = mobjXLApp.Workbooks.Add
  mcolXLWkbs.Add objXLWkb
  Set objXLWkb = Nothing

  mcolXLWkbs.Item(1).Workbook.Activate
  mobjXLApp.Visible = True
  mobjXLApp.UserControl = True

exit_Sub:
  On Error Resume Next
  Me.cmdStartXL.Enabled = False
  Me.cmdQuit.Default = True
  On Error GoTo 0
  Exit Sub

err_Excel:
  MsgBox "Fehler bei der Verbindung zu Excel!", vbCritical
  Resume exit_Sub
End Sub

Private Sub cmdQuit_Click()
  Unload Me
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, _
      UnloadMode As Integer)
  On Error Resume Next
  mobjXLApp.EnableEvents = False

  Dim i As Integer
  For i = 1 To mcolXLWkbs.Count
    mcolXLWkbs.Item(1).Workbook.Close False
    mcolXLWkbs.Remove 1
  Next
  Set mcolXLWkbs = Nothing

  mobjXLApp.EnableEvents = True
  mobjXLApp.Quit
  Set mobjXLApp = Nothing
  On Error GoTo 0
End Sub